1 module Pretty (prettyShow) where
3 import qualified Data.Map as Map
4 import qualified CoreSyn
5 import qualified Module
6 import qualified HscTypes
7 import Text.PrettyPrint.HughesPJClass
8 import Outputable ( showSDoc, ppr, Outputable, OutputableBndr)
10 import qualified ForSyDe.Backend.Ppr
11 import qualified ForSyDe.Backend.VHDL.AST as AST
15 import TranslatorTypes
18 -- | A version of the default pPrintList method, which uses a custom function
19 -- f instead of pPrint to print elements.
20 printList :: (a -> Doc) -> [a] -> Doc
21 printList f = brackets . fsep . punctuate comma . map f
23 instance Pretty HsFunction where
24 pPrint (HsFunction name args res) =
25 text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res'
27 args' = map pPrint args
30 instance Pretty x => Pretty (HsValueMap x) where
31 pPrint (Tuple maps) = parens (hsep $ punctuate comma (map pPrint maps))
32 pPrint (Single s) = pPrint s
34 instance Pretty HsValueUse where
35 pPrint Port = char 'P'
36 pPrint (State n) = char 'C' <> int n
37 pPrint (HighOrder _ _) = text "Higher Order"
39 instance Pretty FlatFunction where
40 pPrint (FlatFunction args res defs sigs) =
41 (text "Args: ") $$ nest 10 (pPrint args)
42 $+$ (text "Result: ") $$ nest 10 (pPrint res)
43 $+$ (text "Defs: ") $$ nest 10 (pPrint defs)
44 $+$ text "Signals: " $$ nest 10 (printList ppsig sigs)
46 ppsig (id, info) = pPrint id <> pPrint info
48 instance Pretty SigDef where
49 pPrint (FApp func args res) =
50 pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
51 pPrint (CondDef _ _ _ _) = text "TODO"
52 pPrint (UncondDef src dst) = text "TODO"
54 instance Pretty SignalInfo where
55 pPrint (SignalInfo name use ty) =
56 text ":" <> (pPrint use) <> (ppname name)
58 ppname Nothing = empty
59 ppname (Just name) = text ":" <> text name
61 instance Pretty SigUse where
62 pPrint SigPortIn = text "PI"
63 pPrint SigPortOut = text "PO"
64 pPrint SigInternal = text "I"
65 pPrint (SigStateOld n) = text "SO:" <> int n
66 pPrint (SigStateNew n) = text "SN:" <> int n
67 pPrint SigSubState = text "s"
69 instance Pretty VHDLSession where
70 pPrint (VHDLSession mod nameCount funcs) =
71 text "Module: " $$ nest 15 (text modname)
72 $+$ text "NameCount: " $$ nest 15 (int nameCount)
73 $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
75 ppfunc (hsfunc, fdata) =
76 pPrint hsfunc $+$ nest 5 (pPrint fdata)
77 modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
79 instance Pretty FuncData where
80 pPrint (FuncData flatfunc entity arch) =
81 text "Flattened: " $$ nest 15 (ppffunc flatfunc)
82 $+$ text "Entity" $$ nest 15 (ppent entity)
85 ppffunc (Just f) = pPrint f
86 ppffunc Nothing = text "Nothing"
87 ppent (Just e) = pPrint e
88 ppent Nothing = text "Nothing"
89 pparch Nothing = text "VHDL architecture not present"
90 pparch (Just _) = text "VHDL architecture present"
92 instance Pretty Entity where
93 pPrint (Entity id args res decl) =
94 text "Entity: " $$ nest 10 (pPrint id)
95 $+$ text "Args: " $$ nest 10 (pPrint args)
96 $+$ text "Result: " $$ nest 10 (pPrint res)
99 ppdecl Nothing = text "VHDL entity not present"
100 ppdecl (Just _) = text "VHDL entity present"
102 instance (OutputableBndr b) => Pretty (CoreSyn.Bind b) where
103 pPrint (CoreSyn.NonRec b expr) =
104 text "NonRec: " $$ nest 10 (prettyBind (b, expr))
105 pPrint (CoreSyn.Rec binds) =
106 text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
108 instance Pretty AST.VHDLId where
109 pPrint id = ForSyDe.Backend.Ppr.ppr id
111 prettyBind :: (Outputable b, Outputable e) => (b, e) -> Doc
112 prettyBind (b, expr) =
113 text b' <> text " = " <> text expr'
115 b' = showSDoc $ ppr b
116 expr' = showSDoc $ ppr expr