pretty-show 1.4.1 → 1.5

raw patch · 6 files changed

+152/−102 lines, 6 filesdep ~basePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Text/Show/Html.hs +81/−64
• Text/Show/Pretty.hs +40/−18
• bin/ppsh.hs +3/−3
• pretty-show.cabal +5/−3
• style/pretty-show.css +21/−14
• style/pretty-show.js +2/−0

@@ -1,71 +1,79 @@ module Text.Show.Html   ( HtmlOpts(..), defaultHtmlOpts-  , dumpHtml, toHtml, htmlPage+  , valToHtml, valToHtmlPage, htmlPage+  , Html(..)   ) where  import Text.Show.Value import Prelude hiding (span) -dumpHtml :: HtmlOpts -> Value -> Html-dumpHtml opts = htmlPage opts . toHtml opts+-- | Make an Html page representing the given value.+valToHtmlPage :: HtmlOpts -> Value -> String+valToHtmlPage opts = htmlPage opts . valToHtml opts +-- | Options on how to generate Html (more to come). data HtmlOpts = HtmlOpts-  { dataDir :: FilePath-  }+  { dataDir :: FilePath   -- ^ Path for extra files.  If empty, we look in+                          -- directory `style`, relative to document.+  , wideListWidth :: Int  -- ^ Max. number of columns in wide lists.+  } deriving Show +-- | Default options. defaultHtmlOpts :: HtmlOpts defaultHtmlOpts = HtmlOpts-  { dataDir = ""+  { dataDir       = ""+  , wideListWidth = 80   } --toHtml :: HtmlOpts -> Value -> Html-toHtml opts val =-  case val of-    Con con []  -> span "con" (text con)-    Con con vs  -> tallRecord con (map conLab vs) (map (toHtml opts) vs)-    Rec con fs  -> tallRecord con (map fst fs) (map (toHtml opts . snd) fs)-    Tuple vs    -> wideTuple (map (toHtml opts) vs)+-- | Convert a value into an Html fragment.+valToHtml :: HtmlOpts -> Value -> Html+valToHtml opts = loop+  where+  loop val =+    case val of+      Con con []  -> span "con" (text con)+      Con con vs  -> tallRecord con (map conLab vs) (map loop         vs)+      Rec con fs  -> tallRecord con (map fst fs)    (map (loop . snd) fs)+      Tuple vs    -> wideTuple                      (map loop vs) -    List []     -> span "list" (text "[]")-    List vs@(v : vs1) ->-      case v of+      List []     -> span "list" (text "[]")+      List vs@(v : vs1) ->+        case v of -        Con c fs-          | all (isCon c) vs1  -> recordList c (map conLab fs)-                                   [ map (toHtml opts) xs | Con _ xs <- vs ]-          | otherwise          -> tallList $ map (toHtml opts) vs+          Con c fs+            | all (isCon c) vs1  -> recordList c (map conLab fs)+                                     [ map loop xs | Con _ xs <- vs ]+            | otherwise          -> tallList $ map (loop) vs -        Rec c fs-          | all (isRec c) vs1   -> recordList c (map fst fs)-                                 [ map (toHtml opts . snd) xs | Rec _ xs <- vs ]-          | otherwise           -> tallList $ map (toHtml opts) vs+          Rec c fs+            | all (isRec c) vs1   -> recordList c (map fst fs)+                                   [ map (loop . snd) xs | Rec _ xs <- vs ]+            | otherwise           -> tallList $ map (loop) vs -        Tuple fs -> tupleList (length fs)-                          [ map (toHtml opts) xs | Tuple xs <- vs ]+          Tuple fs -> tupleList (length fs)+                            [ map (loop) xs | Tuple xs <- vs ] -        List {}    -> tallList    $ map (toHtml opts) vs+          List {}    -> tallList    $ map loop vs -        Neg {}     -> wideList 80 $ map (toHtml opts) vs-        Ratio {}   -> wideList 80 $ map (toHtml opts) vs-        Integer {} -> wideList 80 $ map (toHtml opts) vs-        Float {}   -> wideList 80 $ map (toHtml opts) vs-        Char {}    -> wideList 80 $ map (toHtml opts) vs-        String {}  -> tallList    $ map (toHtml opts) vs+          Neg {}     -> wideList (wideListWidth opts) $ map loop vs+          Ratio {}   -> wideList (wideListWidth opts) $ map loop vs+          Integer {} -> wideList (wideListWidth opts) $ map loop vs+          Float {}   -> wideList (wideListWidth opts) $ map loop vs+          Char {}    -> wideList (wideListWidth opts) $ map loop vs+          String {}  -> tallList                      $ map loop vs -    Neg v       ->-      case v of-        Integer txt -> span "integer" ('-' : txt)-        Float txt   -> span "float"   ('-' : txt)-        _           -> neg (toHtml opts v)+      Neg v       ->+        case v of+          Integer txt -> span "integer" $ text ('-' : txt)+          Float txt   -> span "float"   $ text ('-' : txt)+          _           -> neg (loop v) -    Ratio v1 v2 -> ratio (toHtml opts v1) (toHtml opts v2)-    Integer txt -> span "integer" (text txt)-    Float txt   -> span "float"   (text txt)-    Char txt    -> span "char"    (text txt)-    String txt  -> span "string"  (text txt)+      Ratio v1 v2 -> ratio (loop v1) (loop v2)+      Integer txt -> span "integer" (text txt)+      Float txt   -> span "float"   (text txt)+      Char txt    -> span "char"    (text txt)+      String txt  -> span "string"  (text txt) -  where   conLab _          = " "    isCon c (Con d _) = c == d@@ -123,37 +131,43 @@   row n es  = tr $ (th "ix" 1 (int (n*w))) : map td es  ---------------------------------------------------------------------------------type Html = String+newtype Html = Html { exportHtml :: String }  table :: String -> [Html] -> Html-table cl body = "<table class=" ++ show cl ++ ">" ++ concat body ++ "</table>"+table cl body = Html $ "<table class=" ++ show cl ++ ">" +++                       concatMap exportHtml body +++                       "</table>"  tr :: [Html] -> Html-tr body = "<tr>" ++ concat body ++ "</tr>"+tr body = Html $ "<tr>" ++ concatMap exportHtml body ++ "</tr>"  th :: String -> Int -> Html -> Html-th cl n body = "<th class=" ++ show cl ++ " colspan=" ++ show (show n) ++ ">"-                                          ++ body ++ "</th>"+th cl n body = Html $ "<th class=" ++ show cl +++                         " colspan=" ++ show (show n) ++ ">" +++                      exportHtml body +++                      "</th>"  td :: Html -> Html-td body = "<td>" ++ body ++ "</td>"+td body = Html $ "<td>" ++ exportHtml body ++ "</td>"  td' :: String -> Html -> Html-td' cl body = "<td class=" ++ show cl ++ ">" ++ body ++ "</td>"--+td' cl body = Html $ "<td class=" ++ show cl ++ ">" +++                     exportHtml body +++                     "</td>"  span :: String -> Html -> Html-span cl body = "<span class=" ++ show cl ++ ">" ++ body ++ "</span>"+span cl body = Html $ "<span class=" ++ show cl ++ ">" +++                      exportHtml body +++                      "</span>"  empty :: Html-empty = ""+empty = Html  ""  int :: Int -> Html-int = show+int = Html . show  text :: String -> Html-text = concatMap esc+text = Html . concatMap esc   where   esc '<' = "&lt;"   esc '>' = "&gt;"@@ -161,7 +175,8 @@   esc ' ' = "&nbsp;"   esc c   = [c] -htmlPage :: HtmlOpts -> Html -> Html+-- | Wrap an Html fragment to make an Html page.+htmlPage :: HtmlOpts -> Html -> String htmlPage opts body =   unlines   [ "<html>"@@ -170,15 +185,17 @@   , "<script src=" ++ show jquery ++ "></script>"   , "<script src=" ++ show pjs    ++ "></script>"   , "<body>"-  , body+  , exportHtml  body   , "</body>"   , "</html>"   ]   where-  dir    = dataDir opts   -- XXX: slashes on Windows?-  jquery = dir ++ "/style/jquery.js"-  pjs    = dir ++ "/style/pretty-show.js"-  pstyle = dir ++ "/style/pretty-show.css"+  dir    = case dataDir opts of+             "" -> ""+             d  -> d ++ "/"+  jquery = dir ++ "style/jquery.js"+  pjs    = dir ++ "style/pretty-show.js"+  pstyle = dir ++ "style/pretty-show.css"  

@@ -13,10 +13,23 @@   module Text.Show.Pretty-  ( Name, Value(..)-  , parseValue, reify, ppValue, ppDoc, ppShow-  , PrettyVal(..), dumpDoc, dumpStr-  , HtmlOpts(..), defaultHtmlOpts, dumpHtml, htmlPage, toHtml+  ( -- * Generic representation of values+    Value(..), Name+  , valToStr+  , valToDoc+  , valToHtmlPage++    -- * Values using the 'Show' class+  , parseValue, reify, ppDoc, ppShow++    -- * Values using the 'PrettyVal' class+  , dumpDoc, dumpStr, PrettyVal(..)++    -- * Rendering values to Html+  , valToHtml, HtmlOpts(..), defaultHtmlOpts, htmlPage, Html(..)++    -- * Deprecated+  , ppValue   ) where  import Text.PrettyPrint@@ -26,6 +39,10 @@ import Text.Show.Html import Language.Haskell.Lexer(rmSpace,lexerPass0) +{-# DEPRECATED ppValue "Please use `valToDoc` instead." #-}+ppValue :: Value -> Doc+ppValue = valToDoc+ reify :: Show a => a -> Maybe Value reify = parseValue . show @@ -40,15 +57,15 @@ --   just use its standard 'Show' instance. ppDoc :: Show a => a -> Doc ppDoc a = case parseValue txt of-            Just v  -> ppValue v+            Just v  -> valToDoc v             Nothing -> text txt   where txt = show a --- | Render a value in the 'PrettyVal' class to a 'Doc.+-- | Render a value in the 'PrettyVal' class to a 'Doc'. -- The benefit of this function is that 'PrettyVal' instances may -- be derived automatically using generics. dumpDoc :: PrettyVal a => a -> Doc-dumpDoc = ppValue . prettyVal+dumpDoc = valToDoc . prettyVal  -- | Render a value in the 'PrettyVal' class to a 'String'. -- The benefit of this function is that 'PrettyVal' instances may@@ -57,18 +74,23 @@ dumpStr = show . dumpDoc  +-- | 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.-ppValue :: Value -> Doc-ppValue val = case val of+valToDoc :: Value -> Doc+valToDoc val = case val of   Con c vs    -> ppCon c vs   Rec c fs    -> hang (text c) 2 $ block '{' '}' (map ppField fs)-    where ppField (x,v) = text x <+> char '=' <+> ppValue v+    where ppField (x,v) = text x <+> char '=' <+> valToDoc v -  List vs     -> block '[' ']' (map ppValue vs)-  Tuple vs    -> block '(' ')' (map ppValue vs)+  List vs     -> block '[' ']' (map valToDoc vs)+  Tuple vs    -> block '(' ')' (map valToDoc vs)   Neg v       -> char '-' <> ppAtom v   Ratio x y   -> ppCon "(%)" [x,y]   Integer x   -> text x@@ -81,19 +103,19 @@  ppAtom :: Value -> Doc ppAtom v-  | isAtom v  = ppValue v-  | otherwise = parens (ppValue v)+  | isAtom v  = valToDoc v+  | otherwise = parens (valToDoc v)  ppCon :: Name -> [Value] -> Doc ppCon c []        = text c ppCon c (v : vs)  = hang line1 2 (foldl addParam doc1 vs)   where (line1,doc1)-          | isAtom v   = (text c, ppValue v)-          | otherwise  = (text c <+> char '(', ppValue v <+> char ')')+          | isAtom v   = (text c, valToDoc v)+          | otherwise  = (text c <+> char '(', valToDoc v <+> char ')')          addParam d p-          | isAtom p  = d $$ ppValue p-          | otherwise = (d <+> char '(') $$ (ppValue p <+> char ')')+          | isAtom p  = d $$ valToDoc p+          | otherwise = (d <+> char '(') $$ (valToDoc p <+> char ')')  isAtom               :: Value -> Bool isAtom (Con _ (_:_))  = False

@@ -15,11 +15,11 @@               Just v  ->                 do dir <- getDataDir                    let opts = defaultHtmlOpts { dataDir = dir }-                   putStrLn (dumpHtml opts v)+                   putStrLn (valToHtmlPage opts v)               Nothing -> hPutStrLn stderr "Failed to parse value."         []         -> interactLn $ \s -> case parseValue s of-                                          Just v  -> show (ppValue v)+                                          Just v  -> show (valToDoc v)                                           Nothing -> s        _ -> hPutStrLn stderr $ unlines               [ "usage: ppsh < showed_value > pretty_value"@@ -32,7 +32,7 @@ interactLn f = interact f >> putStrLn ""  selftest :: Value -> Bool-selftest v = case parseValue $ show $ ppValue v of+selftest v = case parseValue $ show $ valToDoc v of                Just v1  -> v1 == v                Nothing  -> False 

@@ -1,14 +1,16 @@ name:           pretty-show-version:        1.4.1+version:        1.5 category:       Text -synopsis:       Tools for working with derived Show instances.+synopsis:       Tools for working with derived `Show` instances and generic+                inspection of values. description:   We provide a library and an executable for working with derived 'Show'   instances. By using the library, we can parse derived 'Show' instances into a   generic data structure. The @ppsh@ tool uses the library to produce   human-readable versions of 'Show' instances, which can be quite handy for-  debugging Haskell programs.+  debugging Haskell programs.  We can also render complex generic values into+  an interactive Html page, for easier examination.  license:        BSD3 license-file:   LICENSE

@@ -1,25 +1,32 @@-table.tallRecord { border: 1px solid #9c9; border-top-width: 5px }-+table.tallRecord             { border: 1px solid #9c9; border-top-width: 5px } table.tallRecord>tbody>tr>th { background-color: #cfc } -table.ratio>tbody>tr>td { text-align: center }-table.ratio>tbody>tr>td.numerator { border-bottom: solid black 1px }---table.wideTuple             { border: 1px solid #9c9 }-table.wideTuple>tbody>tr>td { padding-left: 5px; padding-right: 5px }+table.wideTuple              { border: 1px solid #9c9 }+table.wideTuple >tbody>tr>td { padding-left: 5px; padding-right: 5px } -table.tallList>tbody>tr>th,+table.tallList  >tbody>tr>th, table.recordList>tbody>tr>th,-table.wideList>tbody>tr>th   { background-color: #ffc; border: 1px solid #cc9 }+table.wideList  >tbody>tr>th  { background-color: #ffc; border: 1px solid #cc9 } +.con, .label, .ix { font-weight: normal }++/* Things that get clicked */ table.recordList>tbody>tr>th.ix, table.recordList>tbody>tr>th.con,-table.tallList>tbody>tr>th.ix,-table.tallList>tbody>tr>th.con,+table.tallList  >tbody>tr>th.ix,+table.tallList  >tbody>tr>th.con, table.tallRecord>tbody>tr>th.con, table.tallRecord>tbody>tr>th.label,-table.wideList>tbody>tr>th.con { cursor: hand }+table.wideList  >tbody>tr>th.con { cursor: hand } -.con, .label, .ix { font-family: monospace; font-weight: normal }+/* Things that get closed */+table.tallRecord>tbody>tr>th.closed,+table.tallList  >tbody>tr>th.closed,+table.recordList>tbody>tr>th.closed,+table.wideList  >tbody>tr>th.closed  { background-color: #ccf } +/* rational numbers */+table.ratio>tbody>tr>td           { text-align: center }+table.ratio>tbody>tr>td.numerator { border-bottom: solid black 1px }++.char, .integer { font-family: monospace }

@@ -1,11 +1,13 @@ function toggle_con(obj) {   var x = $(obj.currentTarget);+  x.toggleClass("closed");   x.parent().siblings().fadeToggle();   x.siblings().fadeToggle(); }  function toggle_lab(obj) {   var x = $(obj.currentTarget);+  x.toggleClass("closed");   x.siblings().fadeToggle();   }