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