Pretty.hs

   1 module Pretty (prettyShow) where
   2
   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)
   9
  10 import qualified ForSyDe.Backend.Ppr
  11 import qualified ForSyDe.Backend.VHDL.AST as AST
  12
  13 import HsValueMap
  14 import FlattenTypes
  15 import TranslatorTypes
  16 import VHDLTypes
  17
  18 instance Pretty HsFunction where
  19   pPrint (HsFunction name args res) =
  20     text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res'
  21     where
  22       args' = map pPrint args
  23       res'  = pPrint res
  24
  25 instance Pretty x => Pretty (HsValueMap x) where
  26   pPrint (Tuple maps) = parens (hsep $ punctuate comma (map pPrint maps))
  27   pPrint (Single s)   = pPrint s
  28
  29 instance Pretty HsValueUse where
  30   pPrint Port            = char 'P'
  31   pPrint (State n)       = char 'C' <> int n
  32   pPrint (HighOrder _ _) = text "Higher Order"
  33
  34 instance Pretty id => Pretty (FlatFunction' id) where
  35   pPrint (FlatFunction args res apps conds sigs) =
  36     (text "Args: ") $$ nest 10 (pPrint args)
  37     $+$ (text "Result: ") $$ nest 10 (pPrint res)
  38     $+$ (text "Apps: ") $$ nest 10 (vcat (map pPrint apps))
  39     $+$ (text "Conds: ") $$ nest 10 (pPrint conds)
  40     $+$ text "Signals: " $$ nest 10 (pPrint sigs)
  41
  42 instance Pretty id => Pretty (FApp id) where
  43   pPrint (FApp func args res) =
  44     pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
  45
  46 instance Pretty id => Pretty (CondDef id) where
  47   pPrint _ = text "TODO"
  48
  49 instance Pretty SignalInfo where
  50   pPrint (SignalInfo Nothing ty) = empty
  51   pPrint (SignalInfo (Just name) ty) = text ":" <> text name
  52
  53 instance Pretty VHDLSession where
  54   pPrint (VHDLSession mod nameCount funcs) =
  55     text "Module: " $$ nest 15 (text modname)
  56     $+$ text "NameCount: " $$ nest 15 (int nameCount)
  57     $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
  58     where
  59       ppfunc (hsfunc, (FuncData flatfunc entity)) =
  60         pPrint hsfunc $+$ (text "Flattened: " $$ nest 15 (ppffunc flatfunc))
  61         $+$ (text "Entity") $$ nest 15 (ppent entity)
  62       ppffunc (Just f) = pPrint f
  63       ppffunc Nothing  = text "Nothing"
  64       ppent (Just e)   = pPrint e
  65       ppent Nothing    = text "Nothing"
  66       modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
  67
  68 instance Pretty Entity where
  69   pPrint (Entity args res decl) =
  70     text "Args: " $$ nest 10 (pPrint args)
  71     $+$ text "Result: " $$ nest 10 (pPrint res)
  72     $+$ ppdecl decl
  73     where
  74       ppdecl Nothing = text "VHDL entity not present"
  75       ppdecl (Just _) = text "VHDL entity present"
  76
  77 instance (OutputableBndr b) => Pretty (CoreSyn.Bind b) where
  78   pPrint (CoreSyn.NonRec b expr) =
  79     text "NonRec: " $$ nest 10 (prettyBind (b, expr))
  80   pPrint (CoreSyn.Rec binds) =
  81     text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
  82
  83 instance Pretty AST.VHDLId where
  84   pPrint id = ForSyDe.Backend.Ppr.ppr id
  85
  86 prettyBind :: (Outputable b, Outputable e) => (b, e) -> Doc
  87 prettyBind (b, expr) =
  88   text b' <> text " = " <> text expr'
  89   where
  90     b' = showSDoc $ ppr b
  91     expr' = showSDoc $ ppr expr