diff --git a/Text/Show/DateTime.hs b/Text/Show/DateTime.hs new file mode 100644 --- /dev/null +++ b/Text/Show/DateTime.hs @@ -0,0 +1,57 @@ +-- | This module provides some support for recognizing various date +-- formats used by the 'time' package. Clearly, this is a bit of a hack +-- but we try to be helpful. +module Text.Show.DateTime (parseDateTime) where + +import Language.Haskell.Lexer(Token(..), PosToken, lexerPass0) + +parseDateTime :: [PosToken] -> [PosToken] +parseDateTime inp = + case date inp of + Just (x@(tok,(p,d)), (y@(Whitespace,(_," ")) : rest)) -> + case time rest of + Just ((_,(_,t)), rest1) -> (tok, (p, d ++ t)) : parseDateTime rest1 + Nothing -> x : y : parseDateTime rest + + Just (x, rest) -> x : parseDateTime rest + Nothing -> + case time inp of + Just (x, rest) -> x : parseDateTime rest + Nothing -> + case timeDiff inp of + Just (x, rest) -> x : parseDateTime rest + Nothing -> + case inp of + x : xs -> x : parseDateTime xs + [] -> [] + where + date ( (IntLit,(p,y)) : + (Varsym,(_,"-")) : + (IntLit,(_,m)) : + (Varsym,(_,"-")) : + (IntLit,(_,d)) : rest + ) = Just ((StringLit, (p, y ++ "-" ++ m ++ "-" ++ d)), rest) + + date _ = Nothing + + time ( (IntLit,(p,h)) : + (Reservedop,(_,":")) : + (IntLit,(_,m)) : + (Reservedop,(_,":")) : + (mbSecs,(_,s)) : + rest + ) | mbSecs == IntLit || mbSecs == FloatLit = + Just ((StringLit, (p,h ++ ":" ++ m ++ ":" ++ s ++ tz)), rest1) + where (tz,rest1) = timezone rest + time _ = Nothing + + timezone ((Whitespace,(_," ")) : (Conid,(_,c)) : rest) = (" " ++ c, rest) + timezone xs = ("", xs) + + timeDiff ((mbLen,(p,h)) : (Varid,(_,"s")) : rest) + | mbLen == IntLit || mbLen == FloatLit = + Just ((StringLit, (p, h ++ "s")), rest) + timeDiff _ = Nothing + + +test x = mapM_ print $ parseDateTime $ lexerPass0 x diff --git a/Text/Show/Pretty.hs b/Text/Show/Pretty.hs --- a/Text/Show/Pretty.hs +++ b/Text/Show/Pretty.hs @@ -20,13 +20,14 @@ import Text.PrettyPrint import qualified Text.Show.Parser as P import Text.Show.Value +import Text.Show.DateTime import Language.Haskell.Lexer(rmSpace,lexerPass0) reify :: Show a => a -> Maybe Value reify = parseValue . show parseValue :: String -> Maybe Value -parseValue = P.parseValue . rmSpace . lexerPass0 +parseValue = P.parseValue . rmSpace . parseDateTime . lexerPass0 -- | Convert a generic value into a pretty 'String', if possible. ppShow :: Show a => a -> String 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 @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} -- We use these options because Happy generates code with a lot of warnings. {-# OPTIONS_GHC -w #-} @@ -6,18 +6,10 @@ import Text.Show.Value import Language.Haskell.Lexer -#if __GLASGOW_HASKELL__ >= 503 import qualified Data.Array as Happy_Data_Array -#else -import qualified Array as Happy_Data_Array -#endif -#if __GLASGOW_HASKELL__ >= 503 import qualified GHC.Exts as Happy_GHC_Exts -#else -import qualified GlaExts as Happy_GHC_Exts -#endif --- parser produced by Happy Version 1.18.4 +-- parser produced by Happy Version 1.18.6 newtype HappyAbsSyn t10 t11 t12 t13 t14 t15 t16 t17 t18 t19 t20 t21 t22 t23 t24 t25 t26 t27 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -690,7 +682,7 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp -{-# LINE 28 "templates/GenericTemplate.hs" #-} +{-# LINE 30 "templates/GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -699,11 +691,11 @@ -{-# LINE 49 "templates/GenericTemplate.hs" #-} +{-# LINE 51 "templates/GenericTemplate.hs" #-} -{-# LINE 59 "templates/GenericTemplate.hs" #-} +{-# LINE 61 "templates/GenericTemplate.hs" #-} -{-# LINE 68 "templates/GenericTemplate.hs" #-} +{-# LINE 70 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -746,35 +738,26 @@ happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) + where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where (off) = indexShortOffAddr happyActOffsets st + (off_i) = (off Happy_GHC_Exts.+# i) check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st + (action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st -{-# LINE 127 "templates/GenericTemplate.hs" #-} +{-# LINE 130 "templates/GenericTemplate.hs" #-} indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 Happy_GHC_Exts.narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - Happy_GHC_Exts.intToInt16# i -#else - Happy_GHC_Exts.iShiftRA# (Happy_GHC_Exts.iShiftL# i 16#) 16# -#endif where -#if __GLASGOW_HASKELL__ >= 503 - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) -#else - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.shiftL# high 8#) low) -#endif - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# @@ -788,13 +771,13 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 170 "templates/GenericTemplate.hs" #-} +{-# LINE 163 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) @@ -838,19 +821,19 @@ = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i + (off) = indexShortOffAddr happyGotoOffsets st1 + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i @@ -868,9 +851,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i + where (off) = indexShortOffAddr happyGotoOffsets st + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i @@ -902,6 +885,7 @@ -- Internal happy errors: +notHappyAtAll :: a notHappyAtAll = error "Internal Happy error\n" ----------------------------------------------------------------------------- diff --git a/dist/build/ppsh/ppsh-tmp/Text/Show/Parser.hs b/dist/build/ppsh/ppsh-tmp/Text/Show/Parser.hs --- a/dist/build/ppsh/ppsh-tmp/Text/Show/Parser.hs +++ b/dist/build/ppsh/ppsh-tmp/Text/Show/Parser.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} +{-# OPTIONS_GHC -w #-} {-# OPTIONS -fglasgow-exts -cpp #-} -- We use these options because Happy generates code with a lot of warnings. {-# OPTIONS_GHC -w #-} @@ -6,18 +6,10 @@ import Text.Show.Value import Language.Haskell.Lexer -#if __GLASGOW_HASKELL__ >= 503 import qualified Data.Array as Happy_Data_Array -#else -import qualified Array as Happy_Data_Array -#endif -#if __GLASGOW_HASKELL__ >= 503 import qualified GHC.Exts as Happy_GHC_Exts -#else -import qualified GlaExts as Happy_GHC_Exts -#endif --- parser produced by Happy Version 1.18.4 +-- parser produced by Happy Version 1.18.6 newtype HappyAbsSyn t10 t11 t12 t13 t14 t15 t16 t17 t18 t19 t20 t21 t22 t23 t24 t25 t26 t27 = HappyAbsSyn HappyAny #if __GLASGOW_HASKELL__ >= 607 @@ -690,7 +682,7 @@ {-# LINE 1 "templates/GenericTemplate.hs" #-} -- Id: GenericTemplate.hs,v 1.26 2005/01/14 14:47:22 simonmar Exp -{-# LINE 28 "templates/GenericTemplate.hs" #-} +{-# LINE 30 "templates/GenericTemplate.hs" #-} data Happy_IntList = HappyCons Happy_GHC_Exts.Int# Happy_IntList @@ -699,11 +691,11 @@ -{-# LINE 49 "templates/GenericTemplate.hs" #-} +{-# LINE 51 "templates/GenericTemplate.hs" #-} -{-# LINE 59 "templates/GenericTemplate.hs" #-} +{-# LINE 61 "templates/GenericTemplate.hs" #-} -{-# LINE 68 "templates/GenericTemplate.hs" #-} +{-# LINE 70 "templates/GenericTemplate.hs" #-} infixr 9 `HappyStk` data HappyStk a = HappyStk a (HappyStk a) @@ -746,35 +738,26 @@ happyShift new_state i tk st - where new_state = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) - where off = indexShortOffAddr happyActOffsets st - off_i = (off Happy_GHC_Exts.+# i) + where (new_state) = (n Happy_GHC_Exts.-# (1# :: Happy_GHC_Exts.Int#)) + where (off) = indexShortOffAddr happyActOffsets st + (off_i) = (off Happy_GHC_Exts.+# i) check = if (off_i Happy_GHC_Exts.>=# (0# :: Happy_GHC_Exts.Int#)) then (indexShortOffAddr happyCheck off_i Happy_GHC_Exts.==# i) else False - action | check = indexShortOffAddr happyTable off_i - | otherwise = indexShortOffAddr happyDefActions st + (action) + | check = indexShortOffAddr happyTable off_i + | otherwise = indexShortOffAddr happyDefActions st -{-# LINE 127 "templates/GenericTemplate.hs" #-} +{-# LINE 130 "templates/GenericTemplate.hs" #-} indexShortOffAddr (HappyA# arr) off = -#if __GLASGOW_HASKELL__ > 500 Happy_GHC_Exts.narrow16Int# i -#elif __GLASGOW_HASKELL__ == 500 - Happy_GHC_Exts.intToInt16# i -#else - Happy_GHC_Exts.iShiftRA# (Happy_GHC_Exts.iShiftL# i 16#) 16# -#endif where -#if __GLASGOW_HASKELL__ >= 503 - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) -#else - i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.shiftL# high 8#) low) -#endif - high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) - low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) - off' = off Happy_GHC_Exts.*# 2# + i = Happy_GHC_Exts.word2Int# (Happy_GHC_Exts.or# (Happy_GHC_Exts.uncheckedShiftL# high 8#) low) + high = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr (off' Happy_GHC_Exts.+# 1#))) + low = Happy_GHC_Exts.int2Word# (Happy_GHC_Exts.ord# (Happy_GHC_Exts.indexCharOffAddr# arr off')) + off' = off Happy_GHC_Exts.*# 2# @@ -788,13 +771,13 @@ ----------------------------------------------------------------------------- -- HappyState data type (not arrays) -{-# LINE 170 "templates/GenericTemplate.hs" #-} +{-# LINE 163 "templates/GenericTemplate.hs" #-} ----------------------------------------------------------------------------- -- Shifting a token happyShift new_state 0# tk st sts stk@(x `HappyStk` _) = - let i = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in + let (i) = (case Happy_GHC_Exts.unsafeCoerce# x of { (Happy_GHC_Exts.I# (i)) -> i }) in -- trace "shifting the error token" $ happyDoAction i tk new_state (HappyCons (st) (sts)) (stk) @@ -838,19 +821,19 @@ = happyFail 0# tk st sts stk happyMonadReduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk happyMonad2Reduce k nt fn 0# tk st sts stk = happyFail 0# tk st sts stk happyMonad2Reduce k nt fn j tk st sts stk = happyThen1 (fn stk tk) (\r -> happyNewToken new_state sts1 (r `HappyStk` drop_stk)) - where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts)) + where (sts1@((HappyCons (st1@(action)) (_)))) = happyDrop k (HappyCons (st) (sts)) drop_stk = happyDropStk k stk - off = indexShortOffAddr happyGotoOffsets st1 - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i + (off) = indexShortOffAddr happyGotoOffsets st1 + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i @@ -868,9 +851,9 @@ happyGoto nt j tk st = {- nothing -} happyDoAction j tk new_state - where off = indexShortOffAddr happyGotoOffsets st - off_i = (off Happy_GHC_Exts.+# nt) - new_state = indexShortOffAddr happyTable off_i + where (off) = indexShortOffAddr happyGotoOffsets st + (off_i) = (off Happy_GHC_Exts.+# nt) + (new_state) = indexShortOffAddr happyTable off_i @@ -902,6 +885,7 @@ -- Internal happy errors: +notHappyAtAll :: a notHappyAtAll = error "Internal Happy error\n" ----------------------------------------------------------------------------- diff --git a/ppsh.hs b/ppsh.hs --- a/ppsh.hs +++ b/ppsh.hs @@ -7,14 +7,23 @@ do as <- getArgs case as of ["--test"] -> interactLn (show . selftest1) + + ["--html"] -> + do txt <- getContents + case parseValue txt of + Just v -> putStrLn (html v) + Nothing -> hPutStrLn stderr "Failed to parse value." + [] -> interactLn $ \s -> case parseValue s of Just v -> show (ppValue v) Nothing -> s _ -> hPutStrLn stderr $ unlines [ "usage: ppsh < showed_value > pretty_value" + , " --html Generate HTML." , " --test Self test: True means we passed." ] + interactLn :: (String -> String) -> IO () interactLn f = interact f >> putStrLn "" @@ -27,3 +36,33 @@ selftest1 txt = case parseValue txt of Just v -> selftest v Nothing -> True + +html :: Value -> String +html val = + case val of + Con n xs -> node "con" (name n : map html xs) + Rec n xs -> node "rec" (name n : map field xs) + Tuple xs -> node "tuple" (map html xs) + List xs -> node "list" (map html xs) + Neg x -> node "neg" [ html x ] + Ratio x y -> node "ratio" [ html x, html y ] + Integer x -> leaf "integer" x + Float x -> leaf "float" x + Char x -> leaf "char" x + String x -> leaf "string" x + + where + name = leaf "name" + field (x,v) = node "field" [ name x, html v ] + + leaf c txt = "
" ++ concatMap esc txt ++ "
" + node c els = "
" ++ concat els ++ "
" + esc c = + case c of + '<' -> "<" + '>' -> ">" + '&' -> "&" + '\''-> "'" + '"' -> """ + _ -> [c] + 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.1.1 +version: 1.2 category: Text synopsis: Tools for working with derived Show instances. @@ -26,6 +26,7 @@ other-modules: Text.Show.Parser Text.Show.Value + Text.Show.DateTime build-depends: array >= 0.2 && < 2, base >= 3 && < 5, @@ -46,6 +47,7 @@ Text.Show.Parser Text.Show.Pretty Text.Show.Value + Text.Show.DateTime build-depends: array >= 0.2 && < 2, base >= 3 && < 5,