1 module Pretty (prettyShow) where
3 import qualified Data.Map as Map
5 import qualified CoreSyn
6 import qualified TypeRep
7 import qualified Module
8 import qualified HscTypes
9 import Text.PrettyPrint.HughesPJClass
10 import Outputable ( showSDoc, ppr, Outputable, OutputableBndr)
12 import qualified ForSyDe.Backend.Ppr
13 import qualified ForSyDe.Backend.VHDL.Ppr
14 import qualified ForSyDe.Backend.VHDL.AST as AST
18 import TranslatorTypes
21 -- | A version of the default pPrintList method, which uses a custom function
22 -- f instead of pPrint to print elements.
23 printList :: (a -> Doc) -> [a] -> Doc
24 printList f = brackets . fsep . punctuate comma . map f
26 instance Pretty HsFunction where
27 pPrint (HsFunction name args res) =
28 text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res'
30 args' = map pPrint args
33 instance Pretty x => Pretty (HsValueMap x) where
34 pPrint (Tuple maps) = parens (hsep $ punctuate comma (map pPrint maps))
35 pPrint (Single s) = pPrint s
37 instance Pretty HsValueUse where
38 pPrint Port = char 'P'
39 pPrint (State n) = char 'S' <> int n
40 pPrint (HighOrder _ _) = text "Higher Order"
42 instance Pretty FlatFunction where
43 pPrint (FlatFunction args res defs sigs) =
44 (text "Args: ") $$ nest 10 (pPrint args)
45 $+$ (text "Result: ") $$ nest 10 (pPrint res)
46 $+$ (text "Defs: ") $$ nest 10 (pPrint defs)
47 $+$ text "Signals: " $$ nest 10 (printList ppsig sigs)
49 ppsig (id, info) = pPrint id <> pPrint info
51 instance Pretty SigDef where
52 pPrint (FApp func args res) =
53 pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
54 pPrint (CondDef cond true false res) =
55 pPrint cond <> text " ? " <> pPrint true <> text " : " <> pPrint false <> text " -> " <> pPrint res
56 pPrint (UncondDef src dst) =
57 ppsrc src <> text " -> " <> pPrint dst
59 ppsrc (Left id) = pPrint id
60 ppsrc (Right expr) = pPrint expr
62 instance Pretty SignalExpr where
63 pPrint (EqLit id lit) =
64 parens $ pPrint id <> text " = " <> text lit
65 pPrint (Literal lit) =
68 parens $ pPrint a <> text " = " <> pPrint b
70 instance Pretty SignalInfo where
71 pPrint (SignalInfo name use ty) =
72 text ":" <> (pPrint use) <> (ppname name)
74 ppname Nothing = empty
75 ppname (Just name) = text ":" <> text name
77 instance Pretty SigUse where
78 pPrint SigPortIn = text "PI"
79 pPrint SigPortOut = text "PO"
80 pPrint SigInternal = text "I"
81 pPrint (SigStateOld n) = text "SO:" <> int n
82 pPrint (SigStateNew n) = text "SN:" <> int n
83 pPrint SigSubState = text "s"
85 instance Pretty VHDLSession where
86 pPrint (VHDLSession mod nameCount funcs) =
87 text "Module: " $$ nest 15 (text modname)
88 $+$ text "NameCount: " $$ nest 15 (int nameCount)
89 $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
91 ppfunc (hsfunc, fdata) =
92 pPrint hsfunc $+$ nest 5 (pPrint fdata)
93 modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
95 instance Pretty FuncData where
96 pPrint (FuncData flatfunc entity arch) =
97 text "Flattened: " $$ nest 15 (ppffunc flatfunc)
98 $+$ text "Entity" $$ nest 15 (ppent entity)
101 ppffunc (Just f) = pPrint f
102 ppffunc Nothing = text "Nothing"
103 ppent (Just e) = pPrint e
104 ppent Nothing = text "Nothing"
105 pparch Nothing = text "VHDL architecture not present"
106 pparch (Just _) = text "VHDL architecture present"
108 instance Pretty Entity where
109 pPrint (Entity id args res decl) =
110 text "Entity: " $$ nest 10 (pPrint id)
111 $+$ text "Args: " $$ nest 10 (pPrint args)
112 $+$ text "Result: " $$ nest 10 (pPrint res)
115 ppdecl Nothing = text "VHDL entity not present"
116 ppdecl (Just _) = text "VHDL entity present"
118 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
119 pPrint (CoreSyn.NonRec b expr) =
120 text "NonRec: " $$ nest 10 (prettyBind (b, expr))
121 pPrint (CoreSyn.Rec binds) =
122 text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
124 instance Pretty AST.VHDLId where
125 pPrint id = ForSyDe.Backend.Ppr.ppr id
127 prettyBind :: (Show b, Show e) => (b, e) -> Doc
128 prettyBind (b, expr) =
129 text b' <> text " = " <> text expr'
134 -- Derive Show for core expressions and binders, so we can see the actual
136 deriving instance (Show b) => Show (CoreSyn.Expr b)
137 deriving instance (Show b) => Show (CoreSyn.Bind b)
139 -- Implement dummy shows for Note and Type, so we can at least use show on
141 instance Show CoreSyn.Note where
143 instance Show TypeRep.Type where
144 show t = "_type:(" ++ (showSDoc $ ppr t) ++ ")"