Permalink
Browse files

Initial import.

  • Loading branch information...
0 parents commit ea3bc3448e6d2c3ce18ec36f4e5f16c2dc05dd71 @yav committed Jun 13, 2009
Showing with 309 additions and 0 deletions.
  1. +1 −0 .gitignore
  2. +19 −0 LICENSE
  3. +8 −0 Setup.lhs
  4. +93 −0 Text/Show/Parser.y
  5. +80 −0 Text/Show/Pretty.hs
  6. +28 −0 Text/Show/Value.hs
  7. +27 −0 ppsh.hs
  8. +53 −0 pretty-show.cabal
@@ -0,0 +1 @@
+dist
@@ -0,0 +1,19 @@
+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.
@@ -0,0 +1,8 @@
+#! /usr/bin/env runhaskell
+
+> module Main (main) where
+>
+> import Distribution.Simple (defaultMain)
+>
+> main :: IO ()
+> main = defaultMain
@@ -0,0 +1,93 @@
+{
+-- We use these options because Happy generates code with a lot of warnings.
+{-# OPTIONS_GHC -w #-}
+module Text.Show.Parser (parseValue) where
+
+import Text.Show.Value
+import Language.Haskell.Lexer
+}
+
+%token
+
+ '=' { (Reservedop, (_,"=")) }
+ '(' { (Special, (_,"(")) }
+ ')' { (Special, (_,")")) }
+ '{' { (Special, (_,"{")) }
+ '}' { (Special, (_,"}")) }
+ '[' { (Special, (_,"[")) }
+ ']' { (Special, (_,"]")) }
+ ',' { (Special, (_,",")) }
+
+ INT { (IntLit, (_,$$)) }
+ FLOAT { (FloatLit, (_,$$)) }
+ STRING { (StringLit, (_,$$)) }
+ CHAR { (CharLit, (_,$$)) }
+
+ VARID { (Varid, (_,$$)) }
+ QVARID { (Qvarid, (_,$$)) }
+ CONID { (Conid, (_,$$)) }
+ QCONID { (Qconid, (_,$$)) }
+ CONSYM { (Consym, (_,$$)) }
+ QCONSYM { (Qconsym, (_,$$)) }
+
+
+%monad { Maybe } { (>>=) } { return }
+%name parseValue value
+%tokentype { PosToken }
+
+
+%%
+
+value :: { Value }
+ : con list1(avalue) { Con $1 $2 }
+ | avalue { $1 }
+
+avalue :: { Value }
+ : '(' value ')' { $2 }
+ | '[' sep(value,',') ']' { List $2 }
+ | '(' tuple ')' { Tuple $2 }
+ | con '{' sep(field,',') '}' { Rec $1 $3 }
+ | con { Con $1 [] }
+ | INT { Other $1 }
+ | FLOAT { Other $1 }
+ | STRING { Other $1 }
+ | CHAR { Other $1 }
+
+con :: { String }
+ : CONID { $1 }
+ | QCONID { $1 }
+ -- to support things like "fromList x"
+ | VARID { $1 }
+ | QVARID { $1 }
+
+field :: { (Name,Value) }
+ : VARID '=' value { ($1,$3) }
+
+tuple :: { [Value] }
+ : { [] }
+ | value ',' sep1(value,',') { $1 : $3 }
+
+
+-- Common Rule Patterns --------------------------------------------------------
+
+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 }
+
+
+
+
+{
+happyError :: [PosToken] -> Maybe a
+happyError ((_,(p,_)) : _) = Nothing -- error ("Parser error at: " ++ show p)
+happyError [] = Nothing -- error ("Parser error at EOF")
+}
@@ -0,0 +1,80 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module : Text.Show.Pretty
+-- Copyright : (c) Iavor S. Diatchki 2009
+-- License : BSD3
+--
+-- Maintainer : iavor.diatchki@gmail.com
+-- Stability : provisional
+-- Portability : Haskell 98
+--
+-- Functions for human-readable derived show instances.
+--------------------------------------------------------------------------------
+
+
+module Text.Show.Pretty
+ ( Name, Value(..)
+ , parseValue, ppValue, ppDoc, ppShow
+ ) where
+
+import Text.PrettyPrint
+import qualified Text.Show.Parser as P
+import Text.Show.Value
+import Language.Haskell.Lexer(rmSpace,lexerPass0)
+
+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
+
+-- | Try to show a value, prettily.
+-- If we do not undertant the value, then we just use its
+-- standard show instance.
+ppDoc :: Show a => a -> Doc
+ppDoc a = case parseValue txt of
+ Just v -> ppValue v
+ Nothing -> text txt
+ where txt = show a
+
+
+-- | Pretty print a generic value.
+-- Our intention is that the result is equivalent to the show
+-- insrnace for the origianl value, except possivly easier to
+-- unserstand by a human.
+ppValue :: Value -> Doc
+ppValue 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
+
+ List vs -> block '[' ']' (map ppValue vs)
+ Tuple vs -> block '(' ')' (map ppValue vs)
+ Other cs -> text cs
+
+
+-- Private ---------------------------------------------------------------------
+
+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 ')')
+
+ addParam d p
+ | isAtom p = d $$ ppValue p
+ | otherwise = (d <+> char '(') $$ (ppValue p <+> char ')')
+
+isAtom :: Value -> Bool
+isAtom (Con _ (_:_)) = False
+isAtom _ = True
+
+block :: Char -> Char -> [Doc] -> Doc
+block a b [] = char a <> char b
+block a b (d:ds) = char a <+> d
+ $$ vcat [ char ',' <+> x | x <- ds ]
+ $$ char b
+
+
@@ -0,0 +1,28 @@
+--------------------------------------------------------------------------------
+-- |
+-- Module : Text.Show.Value
+-- Copyright : (c) Iavor S. Diatchki 2009
+-- License : BSD3
+--
+-- Maintainer : iavor.diatchki@gmail.com
+-- Stability : provisional
+-- Portability : Haskell 98
+--
+-- Generic representation of Showable values.
+--------------------------------------------------------------------------------
+
+
+module Text.Show.Value ( Name, Value(..) ) where
+
+-- | A name.
+type Name = String
+
+-- | Generic Haskell values
+data Value = Con Name [Value] -- ^ Data constructor
+ | Rec Name [ (Name,Value) ] -- ^ Record value
+ | Tuple [Value] -- ^ Tuple
+ | List [Value] -- ^ List
+ | Other String -- ^ Something else (e.g. number)
+ deriving (Eq,Show)
+
+
@@ -0,0 +1,27 @@
+import Text.Show.Pretty
+import System.Environment
+import System.IO(hPutStrLn,stderr)
+
+main :: IO ()
+main =
+ do as <- getArgs
+ case as of
+ ["--test"] -> interact (show . selftest1)
+ [] -> interact $ \s -> case parseValue s of
+ Just v -> show (ppValue v)
+ Nothing -> s
+ _ -> hPutStrLn stderr $ unlines
+ [ "usage: ppsh < showed_value > pretty_value"
+ , " --test Self test: True means we passed."
+ ]
+
+selftest :: Value -> Bool
+selftest v = case parseValue $ show $ ppValue v of
+ Just v1 -> v1 == v
+ Nothing -> False
+
+selftest1 :: String -> Bool
+selftest1 txt = case parseValue txt of
+ Just v -> selftest v
+ Nothing -> True
+
@@ -0,0 +1,53 @@
+name: pretty-show
+version: 1
+synopsis: Tools for working with derived Show instances.
+
+license: BSD3
+license-file: LICENSE
+author: Iavor S. Diatchki
+maintainer: iavor.diatchki@gmail.com
+
+category: Text
+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 tool uses
+ the library to produce human-readable versions
+ of Show instances, which can be quite handy
+ for debugging Haskell programs.
+
+cabal-version: >= 1.2
+build-type: Simple
+
+library
+ exposed-modules:
+ Text.Show.Pretty
+ other-modules:
+ Text.Show.Parser
+ Text.Show.Value
+ build-depends:
+ base >= 3 && < 5,
+ array >= 0.2 && < 2,
+ haskell-lexer >= 1 && < 2,
+ pretty >= 1 && < 2
+ ghc-options: -Wall
+
+executable ppsh
+ main-is: ppsh.hs
+
+ -- Silly. Our real dependency is on 'pretty-show'.
+ other-modules:
+ Text.Show.Pretty
+ Text.Show.Parser
+ Text.Show.Value
+ build-depends:
+ base >= 3 && < 5,
+ array >= 0.2 && < 2,
+ haskell-lexer >= 1 && < 2,
+ pretty >= 1 && < 2
+ ghc-options: -Wall
+
+
+
+

0 comments on commit ea3bc34

Please sign in to comment.