diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,8 @@ +Changes in 1.9 + * Add support for pre-processing values before printing. + In particular, we add a pre-processor which will hide some constructors + from the output. + Changes in 1.8.2 * Switch to using version 3.3.1 of jquery (jquery 1 seems to be long gone) diff --git a/Text/Show/Pretty.hs b/Text/Show/Pretty.hs --- a/Text/Show/Pretty.hs +++ b/Text/Show/Pretty.hs @@ -27,7 +27,7 @@ ppDocList, ppShowList, pPrintList -- * Values using the 'PrettyVal' class - , dumpDoc, dumpStr, PrettyVal(..) + , dumpDoc, dumpStr, dumpIO, PrettyVal(..) -- * Rendering values to Html , valToHtml, HtmlOpts(..), defaultHtmlOpts, htmlPage, Html(..) @@ -35,6 +35,9 @@ -- * Get location of data files , getDataDir + , -- * Preprocessing of values + PreProc(..), ppHide, ppHideNested, hideCon + -- * Deprecated , ppValue ) where @@ -111,7 +114,11 @@ dumpStr :: PrettyVal a => a -> String dumpStr = show . dumpDoc +-- | Render a value using the 'PrettyVal' class and show it to standard out. +dumpIO :: PrettyVal a => a -> IO () +dumpIO = putStrLn . dumpStr + -- | 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. @@ -145,6 +152,31 @@ 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 @@ -182,5 +214,6 @@ 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 --- a/Text/Show/Value.hs +++ b/Text/Show/Value.hs @@ -12,8 +12,10 @@ -------------------------------------------------------------------------------- {-# LANGUAGE Safe #-} -module Text.Show.Value ( Name, Value(..) ) where +module Text.Show.Value ( Name, Value(..), hideCon ) where +import Data.Maybe(fromMaybe,isNothing) + -- | A name. type Name = String @@ -39,3 +41,57 @@ | 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/bin/ppsh.hs b/bin/ppsh.hs --- a/bin/ppsh.hs +++ b/bin/ppsh.hs @@ -1,11 +1,18 @@ import Text.Show.Pretty -import System.Environment +import Data.Either(partitionEithers) +import Data.List(isPrefixOf) +import Data.Char(isSpace) +import System.Environment(getArgs) import System.IO(hPutStrLn,stderr) main :: IO () main = do as <- getArgs - case as of + let (opts,hiding) = partitionEithers (map isHiding as) + preproc v = case hiding of + [] -> v + xs -> hideCon False (`elem` hiding) v + case opts of ["--test"] -> interactLn (show . selftest1) ["--html"] -> @@ -14,17 +21,26 @@ Just v -> do dir <- getDataDir let opts = defaultHtmlOpts { dataDir = dir } - putStrLn (valToHtmlPage opts v) + -- XXX: perhaps for HTML the "hidden" values should + -- just start off collapsed, rahter than being deleted? + putStrLn (valToHtmlPage opts (preproc v)) Nothing -> hPutStrLn stderr "Failed to parse value." [] -> interactLn $ \s -> case parseValue s of - Just v -> show (valToDoc v) + Just v -> show (valToDoc (preproc v)) Nothing -> s _ -> hPutStrLn stderr $ unlines [ "usage: ppsh < showed_value > pretty_value" + , " --hide=CON Hide this constructor." , " --html Generate HTML." , " --test Self test: True means we passed." ] + where + isHiding a + | pref `isPrefixOf` a = Right $ dropWhile isSpace + $ drop (length pref) a + | otherwise = Left a + where pref = "--hide=" interactLn :: (String -> String) -> IO () diff --git a/dist/build/Text/Show/Parser.hs b/dist/build/Text/Show/Parser.hs --- a/dist/build/Text/Show/Parser.hs +++ b/dist/build/Text/Show/Parser.hs @@ -1052,7 +1052,7 @@ {-# LINE 10 "" #-} -{-# LINE 1 "/home/diatchki/tools/ghc-8.4.1/lib/ghc-8.4.1/include/ghcversion.h" #-} +{-# LINE 1 "/home/diatchki/tools/ghc-8.4.3/lib/ghc-8.4.3/include/ghcversion.h" #-} @@ -1069,79 +1069,7 @@ {-# LINE 10 "" #-} -{-# LINE 1 "/tmp/ghc12202_0/ghc_2.h" #-} - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - +{-# LINE 1 "/tmp/ghc21054_0/ghc_2.h" #-} diff --git a/pretty-show.cabal b/pretty-show.cabal --- a/pretty-show.cabal +++ b/pretty-show.cabal @@ -1,5 +1,5 @@ name: pretty-show -version: 1.8.2 +version: 1.9 category: Text synopsis: Tools for working with derived `Show` instances and generic @@ -25,7 +25,8 @@ tested-with: GHC == 7.10.3 GHC == 8.0.2 GHC == 8.2.2 - GHC == 8.4.3 + GHC == 8.4.4 + GHC == 8.6.1 data-files: style/jquery.js