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 'C' <> 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
66 instance Pretty SignalInfo where
67 pPrint (SignalInfo name use ty) =
68 text ":" <> (pPrint use) <> (ppname name)
70 ppname Nothing = empty
71 ppname (Just name) = text ":" <> text name
73 instance Pretty SigUse where
74 pPrint SigPortIn = text "PI"
75 pPrint SigPortOut = text "PO"
76 pPrint SigInternal = text "I"
77 pPrint (SigStateOld n) = text "SO:" <> int n
78 pPrint (SigStateNew n) = text "SN:" <> int n
79 pPrint SigSubState = text "s"
81 instance Pretty VHDLSession where
82 pPrint (VHDLSession mod nameCount funcs) =
83 text "Module: " $$ nest 15 (text modname)
84 $+$ text "NameCount: " $$ nest 15 (int nameCount)
85 $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
87 ppfunc (hsfunc, fdata) =
88 pPrint hsfunc $+$ nest 5 (pPrint fdata)
89 modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
91 instance Pretty FuncData where
92 pPrint (FuncData flatfunc entity arch) =
93 text "Flattened: " $$ nest 15 (ppffunc flatfunc)
94 $+$ text "Entity" $$ nest 15 (ppent entity)
97 ppffunc (Just f) = pPrint f
98 ppffunc Nothing = text "Nothing"
99 ppent (Just e) = pPrint e
100 ppent Nothing = text "Nothing"
101 pparch Nothing = text "VHDL architecture not present"
102 pparch (Just _) = text "VHDL architecture present"
104 instance Pretty Entity where
105 pPrint (Entity id args res decl) =
106 text "Entity: " $$ nest 10 (pPrint id)
107 $+$ text "Args: " $$ nest 10 (pPrint args)
108 $+$ text "Result: " $$ nest 10 (pPrint res)
111 ppdecl Nothing = text "VHDL entity not present"
112 ppdecl (Just _) = text "VHDL entity present"
114 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
115 pPrint (CoreSyn.NonRec b expr) =
116 text "NonRec: " $$ nest 10 (prettyBind (b, expr))
117 pPrint (CoreSyn.Rec binds) =
118 text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
120 instance Pretty AST.VHDLId where
121 pPrint id = ForSyDe.Backend.Ppr.ppr id
123 prettyBind :: (Show b, Show e) => (b, e) -> Doc
124 prettyBind (b, expr) =
125 text b' <> text " = " <> text expr'
130 -- Derive Show for core expressions and binders, so we can see the actual
132 deriving instance (Show b) => Show (CoreSyn.Expr b)
133 deriving instance (Show b) => Show (CoreSyn.Bind b)
135 -- Implement dummy shows for Note and Type, so we can at least use show on
137 instance Show CoreSyn.Note where
139 instance Show TypeRep.Type where
140 show t = "_type:(" ++ (showSDoc $ ppr t) ++ ")"