Make listBind support recursive bindings.
[matthijs/master-project/cλash.git] / Pretty.hs
1 module Pretty (prettyShow) where
2
3
4 import qualified Data.Map as Map
5 import qualified Data.Foldable as Foldable
6 import qualified List
7
8 import qualified CoreSyn
9 import qualified Module
10 import qualified HscTypes
11 import Text.PrettyPrint.HughesPJClass
12 import Outputable ( showSDoc, ppr, Outputable, OutputableBndr)
13
14 import qualified ForSyDe.Backend.Ppr
15 import qualified ForSyDe.Backend.VHDL.Ppr
16 import qualified ForSyDe.Backend.VHDL.AST as AST
17
18 import HsValueMap
19 import FlattenTypes
20 import TranslatorTypes
21 import VHDLTypes
22 import CoreShow
23
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
28
29 instance Pretty HsFunction where
30   pPrint (HsFunction name args res) =
31     text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res'
32     where
33       args' = map pPrint args
34       res'  = pPrint res
35
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
39
40 instance Pretty HsValueUse where
41   pPrint Port            = char 'P'
42   pPrint (State n)       = char 'S' <> int n
43   pPrint (HighOrder _ _) = text "Higher Order"
44
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 (ppsigs sigs)
51     where
52       ppsig (id, info) = pPrint id <> pPrint info
53       ppdefs defs = vcat (map pPrint sorted)
54         where 
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
60       ppsigs sigs = vcat (map pPrint sorted)
61         where
62           sorted = List.sortBy (\a b -> compare (fst a) (fst b)) sigs
63
64
65 instance Pretty SigDef where
66   pPrint (FApp func args res) =
67     pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
68   pPrint (CondDef cond true false res) = 
69     pPrint cond <> text " ? " <> pPrint true <> text " : " <> pPrint false <> text " -> " <> pPrint res
70   pPrint (UncondDef src dst) =
71     ppsrc src <> text " -> " <> pPrint dst
72     where
73       ppsrc (Left id) = pPrint id
74       ppsrc (Right expr) = pPrint expr
75
76 instance Pretty SignalExpr where
77   pPrint (EqLit id lit) =
78     parens $ pPrint id <> text " = " <> text lit
79   pPrint (Literal lit ty) =
80     text "(" <> text (show ty) <> text ") " <> text lit
81   pPrint (Eq a b) =
82     parens $ pPrint a <> text " = " <> pPrint b
83
84 instance Pretty SignalInfo where
85   pPrint (SignalInfo name use ty hints) =
86     text ":" <> (pPrint use) <> (ppname name)
87     where
88       ppname Nothing = empty
89       ppname (Just name) = text ":" <> text name
90
91 instance Pretty SigUse where
92   pPrint SigPortIn   = text "PI"
93   pPrint SigPortOut  = text "PO"
94   pPrint SigInternal = text "I"
95   pPrint (SigStateOld n) = text "SO:" <> int n
96   pPrint (SigStateNew n) = text "SN:" <> int n
97   pPrint SigSubState = text "s"
98
99 instance Pretty TranslatorSession where
100   pPrint (TranslatorSession mod nameCount flatfuncs) =
101     text "Module: " $$ nest 15 (text modname)
102     $+$ text "NameCount: " $$ nest 15 (int nameCount)
103     $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList flatfuncs)))
104     where
105       ppfunc (hsfunc, flatfunc) =
106         pPrint hsfunc $+$ nest 5 (pPrint flatfunc)
107       modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
108 {-
109 instance Pretty FuncData where
110   pPrint (FuncData flatfunc entity arch) =
111     text "Flattened: " $$ nest 15 (ppffunc flatfunc)
112     $+$ text "Entity" $$ nest 15 (ppent entity)
113     $+$ pparch arch
114     where
115       ppffunc (Just f) = pPrint f
116       ppffunc Nothing  = text "Nothing"
117       ppent (Just e)   = pPrint e
118       ppent Nothing    = text "Nothing"
119       pparch Nothing = text "VHDL architecture not present"
120       pparch (Just _) = text "VHDL architecture present"
121 -}
122
123 instance Pretty Entity where
124   pPrint (Entity id args res) =
125     text "Entity: " $$ nest 10 (pPrint id)
126     $+$ text "Args: " $$ nest 10 (pPrint args)
127     $+$ text "Result: " $$ nest 10 (pPrint res)
128
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)
134
135 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
136   pPrint = text . show
137
138 instance Pretty AST.VHDLId where
139   pPrint id = ForSyDe.Backend.Ppr.ppr id
140
141 prettyBind :: (Show b, Show e) => (b, e) -> Doc
142 prettyBind (b, expr) =
143   text b' <> text " = " <> text expr'
144   where
145     b' = show b
146     expr' = show expr
147
148 instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
149   pPrint = 
150     vcat . map ppentry . Map.toList
151     where
152       ppentry (k, v) =
153         pPrint k <> text " : " $$ nest 15 (pPrint v)