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) =
  80     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 (VHDLSession mod nameCount funcs) =
 101     text "Module: " $$ nest 15 (text modname)
 102     $+$ text "NameCount: " $$ nest 15 (int nameCount)
 103     $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
 104     where
 105       ppfunc (hsfunc, fdata) =
 106         pPrint hsfunc $+$ nest 5 (pPrint fdata)
 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 instance Pretty Entity where
 123   pPrint (Entity id args res decl pkg) =
 124     text "Entity: " $$ nest 10 (pPrint id)
 125     $+$ text "Args: " $$ nest 10 (pPrint args)
 126     $+$ text "Result: " $$ nest 10 (pPrint res)
 127     $+$ ppdecl decl
 128     $+$ pppkg pkg
 129     where
 130       ppdecl Nothing = text "VHDL entity not present"
 131       ppdecl (Just _) = text "VHDL entity present"
 132       pppkg Nothing = text "VHDL package not present"
 133       pppkg (Just _) = text "VHDL package present"
 134
 135 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
 136   pPrint (CoreSyn.NonRec b expr) =
 137     text "NonRec: " $$ nest 10 (prettyBind (b, expr))
 138   pPrint (CoreSyn.Rec binds) =
 139     text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
 140
 141 instance Pretty AST.VHDLId where
 142   pPrint id = ForSyDe.Backend.Ppr.ppr id
 143
 144 prettyBind :: (Show b, Show e) => (b, e) -> Doc
 145 prettyBind (b, expr) =
 146   text b' <> text " = " <> text expr'
 147   where
 148     b' = show b
 149     expr' = show expr