1 module Pretty (prettyShow) where
3 import qualified Data.Map as Map
4 import qualified Data.Foldable as Foldable
8 import qualified CoreSyn
9 import qualified TypeRep
10 import qualified Module
11 import qualified HscTypes
12 import Text.PrettyPrint.HughesPJClass
13 import Outputable ( showSDoc, ppr, Outputable, OutputableBndr)
15 import qualified ForSyDe.Backend.Ppr
16 import qualified ForSyDe.Backend.VHDL.Ppr
17 import qualified ForSyDe.Backend.VHDL.AST as AST
21 import TranslatorTypes
24 -- | A version of the default pPrintList method, which uses a custom function
25 -- f instead of pPrint to print elements.
26 printList :: (a -> Doc) -> [a] -> Doc
27 printList f = brackets . fsep . punctuate comma . map f
29 instance Pretty HsFunction where
30 pPrint (HsFunction name args res) =
31 text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res'
33 args' = map pPrint args
36 instance Pretty x => Pretty (HsValueMap x) where
37 pPrint (Tuple maps) = parens (hsep $ punctuate comma (map pPrint maps))
38 pPrint (Single s) = pPrint s
40 instance Pretty HsValueUse where
41 pPrint Port = char 'P'
42 pPrint (State n) = char 'S' <> int n
43 pPrint (HighOrder _ _) = text "Higher Order"
45 instance Pretty FlatFunction where
46 pPrint (FlatFunction args res defs sigs) =
47 (text "Args: ") $$ nest 10 (pPrint args)
48 $+$ (text "Result: ") $$ nest 10 (pPrint res)
49 $+$ (text "Defs: ") $$ nest 10 (ppdefs defs)
50 $+$ text "Signals: " $$ nest 10 (printList ppsig sigs)
52 ppsig (id, info) = pPrint id <> pPrint info
53 ppdefs defs = vcat (map pPrint sorted)
55 -- Roughly sort the entries (inaccurate for Fapps)
56 sorted = List.sortBy (\a b -> compare (sigDefDst a) (sigDefDst b)) defs
57 sigDefDst (FApp _ _ dst) = head $ Foldable.toList dst
58 sigDefDst (CondDef _ _ _ dst) = dst
59 sigDefDst (UncondDef _ dst) = dst
62 instance Pretty SigDef where
63 pPrint (FApp func args res) =
64 pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
65 pPrint (CondDef cond true false res) =
66 pPrint cond <> text " ? " <> pPrint true <> text " : " <> pPrint false <> text " -> " <> pPrint res
67 pPrint (UncondDef src dst) =
68 ppsrc src <> text " -> " <> pPrint dst
70 ppsrc (Left id) = pPrint id
71 ppsrc (Right expr) = pPrint expr
73 instance Pretty SignalExpr where
74 pPrint (EqLit id lit) =
75 parens $ pPrint id <> text " = " <> text lit
76 pPrint (Literal lit) =
79 parens $ pPrint a <> text " = " <> pPrint b
81 instance Pretty SignalInfo where
82 pPrint (SignalInfo name use ty hints) =
83 text ":" <> (pPrint use) <> (ppname name)
85 ppname Nothing = empty
86 ppname (Just name) = text ":" <> text name
88 instance Pretty SigUse where
89 pPrint SigPortIn = text "PI"
90 pPrint SigPortOut = text "PO"
91 pPrint SigInternal = text "I"
92 pPrint (SigStateOld n) = text "SO:" <> int n
93 pPrint (SigStateNew n) = text "SN:" <> int n
94 pPrint SigSubState = text "s"
96 instance Pretty VHDLSession where
97 pPrint (VHDLSession mod nameCount funcs) =
98 text "Module: " $$ nest 15 (text modname)
99 $+$ text "NameCount: " $$ nest 15 (int nameCount)
100 $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
102 ppfunc (hsfunc, fdata) =
103 pPrint hsfunc $+$ nest 5 (pPrint fdata)
104 modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
106 instance Pretty FuncData where
107 pPrint (FuncData flatfunc entity arch) =
108 text "Flattened: " $$ nest 15 (ppffunc flatfunc)
109 $+$ text "Entity" $$ nest 15 (ppent entity)
112 ppffunc (Just f) = pPrint f
113 ppffunc Nothing = text "Nothing"
114 ppent (Just e) = pPrint e
115 ppent Nothing = text "Nothing"
116 pparch Nothing = text "VHDL architecture not present"
117 pparch (Just _) = text "VHDL architecture present"
119 instance Pretty Entity where
120 pPrint (Entity id args res decl) =
121 text "Entity: " $$ nest 10 (pPrint id)
122 $+$ text "Args: " $$ nest 10 (pPrint args)
123 $+$ text "Result: " $$ nest 10 (pPrint res)
126 ppdecl Nothing = text "VHDL entity not present"
127 ppdecl (Just _) = text "VHDL entity present"
129 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
130 pPrint (CoreSyn.NonRec b expr) =
131 text "NonRec: " $$ nest 10 (prettyBind (b, expr))
132 pPrint (CoreSyn.Rec binds) =
133 text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
135 instance Pretty AST.VHDLId where
136 pPrint id = ForSyDe.Backend.Ppr.ppr id
138 prettyBind :: (Show b, Show e) => (b, e) -> Doc
139 prettyBind (b, expr) =
140 text b' <> text " = " <> text expr'
145 -- Derive Show for core expressions and binders, so we can see the actual
147 deriving instance (Show b) => Show (CoreSyn.Expr b)
148 deriving instance (Show b) => Show (CoreSyn.Bind b)
150 -- Implement dummy shows for Note and Type, so we can at least use show on
152 instance Show CoreSyn.Note where
154 instance Show TypeRep.Type where
155 show t = "_type:(" ++ (showSDoc $ ppr t) ++ ")"