1 module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug, zEncodeString) where
4 import qualified Data.Map as Map
5 import Text.PrettyPrint.HughesPJClass
10 import qualified CoreSyn
11 import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
14 import qualified Language.VHDL.Ppr as Ppr
15 import qualified Language.VHDL.AST as AST
16 import qualified Language.VHDL.AST.Ppr
19 import CLasH.VHDL.VHDLTypes
20 import CLasH.Utils.Core.CoreShow
22 -- | A version of the default pPrintList method, which uses a custom function
23 -- f instead of pPrint to print elements.
24 printList :: (a -> Doc) -> [a] -> Doc
25 printList f = brackets . fsep . punctuate comma . map f
28 instance Pretty FuncData where
29 pPrint (FuncData flatfunc entity arch) =
30 text "Flattened: " $$ nest 15 (ppffunc flatfunc)
31 $+$ text "Entity" $$ nest 15 (ppent entity)
34 ppffunc (Just f) = pPrint f
35 ppffunc Nothing = text "Nothing"
36 ppent (Just e) = pPrint e
37 ppent Nothing = text "Nothing"
38 pparch Nothing = text "VHDL architecture not present"
39 pparch (Just _) = text "VHDL architecture present"
42 instance Pretty Entity where
43 pPrint (Entity id args res decl) =
44 text "Entity: " $$ nest 10 (pPrint id)
45 $+$ text "Args: " $$ nest 10 (pPrint args)
46 $+$ text "Result: " $$ nest 10 (pPrint res)
47 $+$ text "Declaration not shown"
49 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
50 pPrint (CoreSyn.NonRec b expr) =
51 text "NonRec: " $$ nest 10 (prettyBind (b, expr))
52 pPrint (CoreSyn.Rec binds) =
53 text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
55 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
58 instance Pretty AST.VHDLId where
59 pPrint id = Ppr.ppr id
61 instance Pretty AST.VHDLName where
62 pPrint name = Ppr.ppr name
64 prettyBind :: (Show b, Show e) => (b, e) -> Doc
65 prettyBind (b, expr) =
66 text b' <> text " = " <> text expr'
71 instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
73 vcat . map ppentry . Map.toList
76 pPrint k <> text " : " $$ nest 15 (pPrint v)
78 -- Convenience method for turning an Outputable into a string
79 pprString :: (Outputable x) => x -> String
80 pprString = showSDoc . ppr
82 pprStringDebug :: (Outputable x) => x -> String
83 pprStringDebug = showSDocDebug . ppr
86 type UserString = String -- As the user typed it
87 type EncodedString = String -- Encoded form
89 zEncodeString :: UserString -> EncodedString
90 zEncodeString cs = case maybe_tuple cs of
91 Just n -> n ++ (go cs) -- Tuples go to Z2T etc
95 go (c:cs) = encode_digit_ch c ++ go' cs
97 go' (c:cs) = encode_ch c ++ go' cs
99 maybe_tuple :: UserString -> Maybe EncodedString
101 maybe_tuple "(# #)" = Just("Z1H")
102 maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
103 (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
105 maybe_tuple "()" = Just("Z0T")
106 maybe_tuple ('(' : cs) = case count_commas (0::Int) cs of
107 (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
109 maybe_tuple _ = Nothing
111 count_commas :: Int -> String -> (Int, String)
112 count_commas n (',' : cs) = count_commas (n+1) cs
113 count_commas n cs = (n,cs)
115 encode_digit_ch :: Char -> EncodedString
116 encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c
117 encode_digit_ch c | otherwise = encode_ch c
119 encode_ch :: Char -> EncodedString
120 encode_ch c | unencodedChar c = [c] -- Common case first
123 encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
124 encode_ch ')' = "ZR" -- For symmetry with (
144 encode_ch '\'' = "zq"
145 encode_ch '\\' = "zr"
149 encode_ch c = encode_as_unicode_char c
151 encode_as_unicode_char :: Char -> EncodedString
152 encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str
154 where hex_str = showHex (ord c) "U"
156 unencodedChar :: Char -> Bool -- True for chars that don't need encoding
157 unencodedChar 'Z' = False
158 unencodedChar 'z' = False
159 unencodedChar c = c >= 'a' && c <= 'z'
160 || c >= 'A' && c <= 'Z'
161 || c >= '0' && c <= '9'