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 name use ty) =
  51     text ":" <> (pPrint use) <> (ppname name)
  52     where
  53       ppname Nothing = empty
  54       ppname (Just name) = text ":" <> text name
  55
  56 instance Pretty SigUse where
  57   pPrint SigPort     = text "P"
  58   pPrint SigInternal = text "I"
  59   pPrint SigState    = text "S"
  60   pPrint SigSubState = text "s"
  61
  62 instance Pretty VHDLSession where
  63   pPrint (VHDLSession mod nameCount funcs) =
  64     text "Module: " $$ nest 15 (text modname)
  65     $+$ text "NameCount: " $$ nest 15 (int nameCount)
  66     $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
  67     where
  68       ppfunc (hsfunc, fdata) =
  69         pPrint hsfunc $+$ nest 5 (pPrint fdata)
  70       modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
  71
  72 instance Pretty FuncData where
  73   pPrint (FuncData flatfunc entity arch) =
  74     text "Flattened: " $$ nest 15 (ppffunc flatfunc)
  75     $+$ text "Entity" $$ nest 15 (ppent entity)
  76     $+$ pparch arch
  77     where
  78       ppffunc (Just f) = pPrint f
  79       ppffunc Nothing  = text "Nothing"
  80       ppent (Just e)   = pPrint e
  81       ppent Nothing    = text "Nothing"
  82       pparch Nothing = text "VHDL architecture not present"
  83       pparch (Just _) = text "VHDL architecture present"
  84
  85 instance Pretty Entity where
  86   pPrint (Entity id args res decl) =
  87     text "Entity id: " $$ nest 10 (pPrint id)
  88     $+$ text "Args: " $$ nest 10 (pPrint args)
  89     $+$ text "Result: " $$ nest 10 (pPrint res)
  90     $+$ ppdecl decl
  91     where
  92       ppdecl Nothing = text "VHDL entity not present"
  93       ppdecl (Just _) = text "VHDL entity present"
  94
  95 instance (OutputableBndr b) => Pretty (CoreSyn.Bind b) where
  96   pPrint (CoreSyn.NonRec b expr) =
  97     text "NonRec: " $$ nest 10 (prettyBind (b, expr))
  98   pPrint (CoreSyn.Rec binds) =
  99     text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
 100
 101 instance Pretty AST.VHDLId where
 102   pPrint id = ForSyDe.Backend.Ppr.ppr id
 103
 104 prettyBind :: (Outputable b, Outputable e) => (b, e) -> Doc
 105 prettyBind (b, expr) =
 106   text b' <> text " = " <> text expr'
 107   where
 108     b' = showSDoc $ ppr b
 109     expr' = showSDoc $ ppr expr