pretty-show-ansi-wl (empty) → 1.9.2
raw patch · 6 files changed
+524/−0 lines, 6 filesdep +ansi-wl-pprintdep +arraydep +basesetup-changed
Dependencies added: ansi-wl-pprint, array, base, ghc-prim, haskell-lexer
Files
- LICENSE +20/−0
- Setup.hs +6/−0
- Text/Show/Parser.y +176/−0
- Text/Show/Pretty.hs +182/−0
- Text/Show/Value.hs +97/−0
- pretty-show-ansi-wl.cabal +43/−0
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple (defaultMain)++main :: IO ()+main = defaultMain
+ Text/Show/Parser.y view
@@ -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]+++}
+ Text/Show/Pretty.hs view
@@ -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 ]+++
+ Text/Show/Value.hs view
@@ -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++
+ pretty-show-ansi-wl.cabal view
@@ -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++