diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018 Liam O'Connor-Davis +Copyright (c) 2008 Iavor S. Diatchki + +Permission is hereby granted, free of charge, to any person obtaining a copy of +this software and associated documentation files (the "Software"), to deal in +the Software without restriction, including without limitation the rights to +use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies +of the Software, and to permit persons to whom the Software is furnished to do +so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +module Main (main) where + +import Distribution.Simple (defaultMain) + +main :: IO () +main = defaultMain diff --git a/Text/Show/Parser.y b/Text/Show/Parser.y new file mode 100644 --- /dev/null +++ b/Text/Show/Parser.y @@ -0,0 +1,176 @@ +{ +-- We use these options because Happy generates code with a lot of warnings. +{-# LANGUAGE Trustworthy #-} +module Text.Show.Parser (parseValue) where + +import Text.Show.Value +import Language.Haskell.Lexer +} + +%token + + '=' { (Reservedop, (_,"=")) } + '(' { (Special, (_,"(")) } + ')' { (Special, (_,")")) } + '{' { (Special, (_,"{")) } + '}' { (Special, (_,"}")) } + '[' { (Special, (_,"[")) } + ']' { (Special, (_,"]")) } + '<' { (Varsym, (_,"<")) } + '>' { (Varsym, (_,">")) } + ',' { (Special, (_,",")) } + '-' { (Varsym, (_,"-")) } + '%' { (Varsym, (_,"%")) } + '`' { (Special, (_,"`")) } + + INT { (IntLit, (_,$$)) } + FLOAT { (FloatLit, (_,$$)) } + STRING { (StringLit, (_,$$)) } + CHAR { (CharLit, (_,$$)) } + + VARID { (Varid, (_,$$)) } + QVARID { (Qvarid, (_,$$)) } + VARSYM { (Varsym, (_,$$)) } + QVARSYM { (Qvarsym, (_,$$)) } + CONID { (Conid, (_,$$)) } + QCONID { (Qconid, (_,$$)) } + CONSYM { (Consym, (_,$$)) } + QCONSYM { (Qconsym, (_,$$)) } + RESOP { (Reservedop, (_,$$)) } + RESID { (Reservedid, (_,$$)) } + + + +%monad { Maybe } { (>>=) } { return } +%name parseValue value +%tokentype { PosToken } + + +%% + +value :: { Value } + : value '%' app_value { Ratio $1 $3 } + | app_value { $1 } + | app_value list1(infixelem) { mkInfixCons $1 $2 } + +infixelem :: { (String,Value) } + : infixcon app_value { ($1,$2) } + +app_value :: { Value } + : list1(avalue) { mkValue $1 } + + +avalue :: { Value } + : '(' value ')' { $2 } + | '[' sep(value,',') ']' { List $2 } + | '(' tuple ')' { Tuple $2 } + | con '{' sep(field,',') '}' { Rec $1 $3 } + | con { Con $1 [] } + | INT { Integer $1 } + | FLOAT { Float $1 } + | STRING { String $1 } + | CHAR { Char $1 } + | '-' avalue { Neg $2 } + +con :: { String } + : CONID { $1 } + | QCONID { $1 } + | prefix(CONSYM) { $1 } + | prefix(QCONSYM) { $1 } + -- to support things like "fromList x" + | VARID { $1 } + | QVARID { $1 } + | prefix(VARSYM) { $1 } + | prefix(QVARSYM) { $1 } + | '<' VARID '>' { "<" ++ $2 ++ ">" } -- note: looses space + | '<' CONID '>' { "<" ++ $2 ++ ">" } -- ditto + | RESID { $1 } + +infixcon :: { String } + : CONSYM { $1 } + | QCONSYM { $1 } + | VARSYM { $1 } + | QVARSYM { $1 } + | '`' CONID '`' { backtick $2 } + | '`' QCONID '`' { backtick $2 } + | RESOP { $1 } + +field :: { (Name,Value) } + : VARID '=' value { ($1,$3) } + +tuple :: { [Value] } + : { [] } + | value ',' sep1(value,',') { $1 : $3 } + +-- Common Rule Patterns -------------------------------------------------------- +prefix(p) : '(' p ')' { "(" ++ $2 ++ ")" } + +sep1(p,q) : p list(snd(q,p)) { $1 : $2 } +sep(p,q) : sep1(p,q) { $1 } + | { [] } + +snd(p,q) : p q { $2 } + +list1(p) : rev_list1(p) { reverse $1 } +list(p) : list1(p) { $1 } + | { [] } + +rev_list1(p) : p { [$1] } + | rev_list1(p) p { $2 : $1 } + + + +{ +backtick :: String -> String +backtick s = "`" ++ s ++ "`" + +happyError :: [PosToken] -> Maybe a +happyError ((_,(p,_)) : _) = Nothing -- error ("Parser error at: " ++ show p) +happyError [] = Nothing -- error ("Parser error at EOF") + +mkValue :: [Value] -> Value +mkValue [v] = v +mkValue (Con "" [] : vs) = mkValue vs +mkValue (Con x [] : vs) = Con x vs +mkValue (InfixCons v xs : Neg x : more) + = mkValue (mkInfixCons v (xs ++ [("-",x)]) : more) +mkValue (v : Neg x : more) = mkValue (mkInfixCons v [("-",x)] : more) +mkValue vs = mkFakeCon vs + +{- When we see a sequence of thins: +1 2 3 + x + y +we parse it as: +1 2 (3 + x + y) + +we do this to make parsing of dates to look a little nicer: + +(2018-08-05) 09 : 31 + +ends up as + +(2018-08-05) (09:31) +-} + +mkInfixCons :: Value -> [(Name,Value)] -> Value +mkInfixCons (Con "" as) bs | not (null as) = + mkFakeCon (init as ++ [mkInfixConsLast (last as) bs]) +mkInfixCons a bs = mkInfixConsLast a bs + +mkInfixConsLast :: Value -> [(Name,Value)] -> Value +mkInfixConsLast v [] = v +mkInfixConsLast v vs = mk [] vs + where + inf xs = InfixCons v (reverse xs) + + mk ps [(x,Con "" (a:as))] = mkFakeCon (inf ((x,a):ps) : as) + mk ps [x] = inf (x:ps) + mk ps (x : xs) = mk (x : ps) xs + mk _ [] = error "impossible" + +mkFakeCon :: [Value] -> Value +mkFakeCon vs = Con "" (concatMap expand vs) + where expand (Con "" vs) = vs + expand v = [v] + + +} diff --git a/Text/Show/Pretty.hs b/Text/Show/Pretty.hs new file mode 100644 --- /dev/null +++ b/Text/Show/Pretty.hs @@ -0,0 +1,182 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Text.Show.Pretty +-- Copyright : (c) Iavor S. Diatchki 2009 +-- License : MIT +-- +-- Maintainer : iavor.diatchki@gmail.com +-- Stability : provisional +-- Portability : Haskell 98 +-- +-- Functions for human-readable derived 'Show' instances. +-------------------------------------------------------------------------------- + +{-# LANGUAGE CPP #-} +{-# LANGUAGE Safe #-} +module Text.Show.Pretty + ( -- * Generic representation of values + Value(..), Name + , valToStr + , valToDoc + + -- * Values using the 'Show' class + , parseValue, reify, ppDoc, ppShow, pPrint + + , -- * Working with listlike ("foldable") collections + ppDocList, ppShowList, pPrintList + + , -- * Preprocessing of values + PreProc(..), ppHide, ppHideNested, hideCon + + ) where + +import qualified Text.Show.Parser as P +import Text.Show.Value +import Data.Foldable(Foldable,toList) +import Language.Haskell.Lexer(rmSpace,lexerPass0) +import Text.PrettyPrint.ANSI.Leijen hiding (hang) +import Prelude hiding ( (<>) ) + + +hang :: Doc -> Int -> Doc -> Doc +hang d1 n d2 = sep [d1, nest n d2] + +reify :: Show a => a -> Maybe Value +reify = parseValue . show + +parseValue :: String -> Maybe Value +parseValue = P.parseValue . rmSpace . lexerPass0 + +-- | Convert a generic value into a pretty 'String', if possible. +ppShow :: Show a => a -> String +ppShow = show . ppDoc + +-- | Pretty print something that may be converted to a list as a list. +-- Each entry is on a separate line, which means that we don't do clever +-- pretty printing, and so this works well for large strucutures. +ppShowList :: (Foldable f, Show a) => f a -> String +ppShowList = show . ppDocList + +-- | Try to show a value, prettily. If we do not understand the value, then we +-- just use its standard 'Show' instance. +ppDoc :: Show a => a -> Doc +ppDoc a = case parseValue txt of + Just v -> valToDoc v + Nothing -> text txt + where txt = show a + +-- | Pretty print something that may be converted to a list as a list. +-- Each entry is on a separate line, which means that we don't do clever +-- pretty printing, and so this works well for large strucutures. +ppDocList :: (Foldable f, Show a) => f a -> Doc +ppDocList = blockWith vcat '[' ']' . map ppDoc . toList + +-- | Pretty print a generic value to stdout. This is particularly useful in the +-- GHCi interactive environment. +pPrint :: Show a => a -> IO () +pPrint = putStrLn . ppShow + +-- | Pretty print something that may be converted to a list as a list. +-- Each entry is on a separate line, which means that we don't do clever +-- pretty printing, and so this works well for large strucutures. +pPrintList :: (Foldable f, Show a) => f a -> IO () +pPrintList = putStrLn . ppShowList + +-- | Pretty print a generic value. Our intention is that the result is +-- equivalent to the 'Show' instance for the original value, except possibly +-- easier to understand by a human. +valToStr :: Value -> String +valToStr = show . valToDoc + +-- | Pretty print a generic value. Our intention is that the result is +-- equivalent to the 'Show' instance for the original value, except possibly +-- easier to understand by a human. +valToDoc :: Value -> Doc +valToDoc val = case val of + Con c vs -> ppCon c vs + InfixCons v1 cvs -> hang_sep (go v1 cvs) + where + go v [] = [ppInfixAtom v] + go v ((n,v2):cvs') = (ppInfixAtom v <+> text n):go v2 cvs' + + hang_sep [] = empty + hang_sep (x:xs) = hang x 2 (sep xs) + -- hang (ppInfixAtom v1) 2 (sep [ text n <+> ppInfixAtom v | (n,v) <- cvs ]) + Rec c fs -> hang (text c) 2 $ block '{' '}' (map ppField fs) + where ppField (x,v) = hang (text x <+> char '=') 2 (valToDoc v) + + List vs -> block '[' ']' (map valToDoc vs) + Tuple vs -> block '(' ')' (map valToDoc vs) + Neg v -> char '-' <> ppAtom v + Ratio x y -> hang (ppAtom x <+> text "%") 2 (ppAtom y) + Integer x -> text x + Float x -> text x + Char x -> text x + String x -> text x + + +-- | This type is used to allow pre-processing of values before showing them. +data PreProc a = PreProc (Value -> Value) a + +instance Show a => Show (PreProc a) where + showsPrec p (PreProc f a) cs = + case parseValue txt of + Nothing -> txt ++ cs + Just v -> wrap (valToStr (f v)) + where + txt = showsPrec p a "" + wrap t = case (t,txt) of + (h:_,'(':_) | h /= '(' -> '(' : (t ++ ')' : cs) + _ -> t ++ cs + +-- | Hide the given constructors when showing a value. +ppHide :: (Name -> Bool) -> a -> PreProc a +ppHide p = PreProc (hideCon False p) + +-- | Hide the given constructors when showing a value. +-- In addition, hide values if all of their children were hidden. +ppHideNested :: (Name -> Bool) -> a -> PreProc a +ppHideNested p = PreProc (hideCon True p) + + + +-- Private --------------------------------------------------------------------- + +ppAtom :: Value -> Doc +ppAtom v + | isAtom v = valToDoc v + | otherwise = parens (valToDoc v) + +ppInfixAtom :: Value -> Doc +ppInfixAtom v + | isInfixAtom v = valToDoc v + | otherwise = parens (valToDoc v) + +ppCon :: Name -> [Value] -> Doc +ppCon "" vs = sep (map ppAtom vs) +ppCon c vs = hang (text c) 2 (sep (map ppAtom vs)) + +isAtom :: Value -> Bool +isAtom (Con _ (_:_)) = False +isAtom (InfixCons {}) = False +isAtom (Ratio {}) = False +isAtom (Neg {}) = False +isAtom _ = True + +-- Don't put parenthesis around constructors in infix chains +isInfixAtom :: Value -> Bool +isInfixAtom (InfixCons {}) = False +isInfixAtom (Ratio {}) = False +isInfixAtom (Neg {}) = False +isInfixAtom _ = True + +block :: Char -> Char -> [Doc] -> Doc +block = blockWith sep + +blockWith :: ([Doc] -> Doc) -> Char -> Char -> [Doc] -> Doc +blockWith _ a b [] = char a <> char b +blockWith f a b (d:ds) = f $ + (char a <+> d) : [ char ',' <+> x | x <- ds ] ++ [ char b ] + + + diff --git a/Text/Show/Value.hs b/Text/Show/Value.hs new file mode 100644 --- /dev/null +++ b/Text/Show/Value.hs @@ -0,0 +1,97 @@ +-------------------------------------------------------------------------------- +-- | +-- Module : Text.Show.Value +-- Copyright : (c) Iavor S. Diatchki 2009 +-- License : MIT +-- +-- Maintainer : iavor.diatchki@gmail.com +-- Stability : provisional +-- Portability : Haskell 98 +-- +-- Generic representation of Showable values. +-------------------------------------------------------------------------------- + +{-# LANGUAGE Safe #-} +module Text.Show.Value ( Name, Value(..), hideCon ) where + +import Data.Maybe(fromMaybe,isNothing) + +-- | A name. +type Name = String + +-- | Generic Haskell values. +-- 'NaN' and 'Infinity' are represented as constructors. +-- The 'String' in the literals is the text for the literals \"as is\". +-- +-- A chain of infix constructors means that they appeared in the input string +-- without parentheses, i.e +-- +-- @1 :+: 2 :*: 3@ is represented with @InfixCons 1 [(":+:",2),(":*:",3)]@, whereas +-- +-- @1 :+: (2 :*: 3)@ is represented with @InfixCons 1 [(":+:",InfixCons 2 [(":*:",3)])]@. +data Value = Con Name [Value] -- ^ Data constructor + | InfixCons Value [(Name,Value)] -- ^ Infix data constructor chain + | Rec Name [ (Name,Value) ] -- ^ Record value + | Tuple [Value] -- ^ Tuple + | List [Value] -- ^ List + | Neg Value -- ^ Negated value + | Ratio Value Value -- ^ Rational + | Integer String -- ^ Non-negative integer + | Float String -- ^ Non-negative floating num. + | Char String -- ^ Character + | String String -- ^ String + deriving (Eq,Show) + +{- | Hide constrcutros matching the given predicate. +If the hidden value is in a record, we also hide +the corresponding record field. + +If the boolean flag is true, then we also hide +constructors all of whose fields were hidden. -} +hideCon :: Bool -> (Name -> Bool) -> Value -> Value +hideCon collapse hidden = toVal . delMaybe + where + hiddenV = Con "_" [] + + toVal = fromMaybe hiddenV + + delMany vals + | collapse && all isNothing newVals = Nothing + | otherwise = Just (map toVal newVals) + where + newVals = map delMaybe vals + + delMaybe val = + case val of + Con x vs + | hidden x -> Nothing + | null vs -> Just val + | otherwise -> Con x `fmap` delMany vs + + Rec x fs + | hidden x -> Nothing + | null fs -> Just val + | collapse && all isNothing mbs -> Nothing + | otherwise -> Just (Rec x [ (f,v) | (f,Just v) <- zip ls mbs ]) + where (ls,vs) = unzip fs + mbs = map delMaybe vs + + InfixCons v ys + | any hidden cs -> Nothing + | otherwise -> do ~(v1:vs1) <- delMany (v:vs) + Just (InfixCons v1 (zip cs vs1)) + where (cs,vs) = unzip ys + + Tuple vs | null vs -> Just val + | otherwise -> Tuple `fmap` delMany vs + List vs | null vs -> Just val + | otherwise -> List `fmap` delMany vs + Neg v -> Neg `fmap` delMaybe v + Ratio v1 v2 -> do ~[a,b] <- delMany [v1,v2] + Just (Ratio a b) + Integer {} -> Just val + Float {} -> Just val + Char {} -> Just val + String {} -> Just val + + diff --git a/pretty-show-ansi-wl.cabal b/pretty-show-ansi-wl.cabal new file mode 100644 --- /dev/null +++ b/pretty-show-ansi-wl.cabal @@ -0,0 +1,43 @@ +name: pretty-show-ansi-wl +version: 1.9.2 +category: Text + +synopsis: Like pretty-show, but only for ansi-wl-pprint +description: + This is an adapted version of Iavor S. Diatchki's pretty-show package, + but using ansi-wl-pprint as the underlying pretty-printing library, + and without certain extra features like HTML rendering. + +license: MIT +license-file: LICENSE +author: Iavor S. Diatchki, Liam O'Connor +maintainer: me@liamoc.net + +homepage: https://github.com/liamoc/pretty-show-ansi-wl + +cabal-version: >= 1.8 +build-type: Simple + +tested-with: GHC == 8.6.1 + +library + exposed-modules: + Text.Show.Pretty + other-modules: + Text.Show.Parser + Text.Show.Value + build-depends: + array >= 0.5 && < 1, + base >= 4.5 && < 5, + haskell-lexer >= 1 && < 2, + ansi-wl-pprint >= 0.6.8.2 && < 2, + ghc-prim + ghc-options: -Wall -O2 + build-tool-depends: happy:happy + build-tools: happy + +source-repository head + type: git + location: https://github.com/liamoc/pretty-show-ansi-wl.git + +