Pretty.hs

   1 -- Needed for the Show deriving for Core types
   2 {-# LANGUAGE StandaloneDeriving #-}
   3
   4 module Pretty (prettyShow) where
   5
   6
   7 import qualified Data.Map as Map
   8 import qualified Data.Foldable as Foldable
   9 import qualified List
  10
  11 import qualified Var
  12 import qualified CoreSyn
  13 import qualified TypeRep
  14 import qualified Module
  15 import qualified HscTypes
  16 import Text.PrettyPrint.HughesPJClass
  17 import Outputable ( showSDoc, ppr, Outputable, OutputableBndr)
  18
  19 import qualified ForSyDe.Backend.Ppr
  20 import qualified ForSyDe.Backend.VHDL.Ppr
  21 import qualified ForSyDe.Backend.VHDL.AST as AST
  22
  23 import HsValueMap
  24 import FlattenTypes
  25 import TranslatorTypes
  26 import VHDLTypes
  27
  28 -- | A version of the default pPrintList method, which uses a custom function
  29 --   f instead of pPrint to print elements.
  30 printList :: (a -> Doc) -> [a] -> Doc
  31 printList f = brackets . fsep . punctuate comma . map f
  32
  33 instance Pretty HsFunction where
  34   pPrint (HsFunction name args res) =
  35     text name <> char ' ' <> parens (hsep $ punctuate comma args') <> text " -> " <> res'
  36     where
  37       args' = map pPrint args
  38       res'  = pPrint res
  39
  40 instance Pretty x => Pretty (HsValueMap x) where
  41   pPrint (Tuple maps) = parens (hsep $ punctuate comma (map pPrint maps))
  42   pPrint (Single s)   = pPrint s
  43
  44 instance Pretty HsValueUse where
  45   pPrint Port            = char 'P'
  46   pPrint (State n)       = char 'S' <> int n
  47   pPrint (HighOrder _ _) = text "Higher Order"
  48
  49 instance Pretty FlatFunction where
  50   pPrint (FlatFunction args res defs sigs) =
  51     (text "Args: ") $$ nest 10 (pPrint args)
  52     $+$ (text "Result: ") $$ nest 10 (pPrint res)
  53     $+$ (text "Defs: ") $$ nest 10 (ppdefs defs)
  54     $+$ text "Signals: " $$ nest 10 (ppsigs sigs)
  55     where
  56       ppsig (id, info) = pPrint id <> pPrint info
  57       ppdefs defs = vcat (map pPrint sorted)
  58         where
  59           -- Roughly sort the entries (inaccurate for Fapps)
  60           sorted = List.sortBy (\a b -> compare (sigDefDst a) (sigDefDst b)) defs
  61           sigDefDst (FApp _ _ dst) = head $ Foldable.toList dst
  62           sigDefDst (CondDef _ _ _ dst) = dst
  63           sigDefDst (UncondDef _ dst) = dst
  64       ppsigs sigs = vcat (map pPrint sorted)
  65         where
  66           sorted = List.sortBy (\a b -> compare (fst a) (fst b)) sigs
  67
  68
  69 instance Pretty SigDef where
  70   pPrint (FApp func args res) =
  71     pPrint func <> text " : " <> pPrint args <> text " -> " <> pPrint res
  72   pPrint (CondDef cond true false res) =
  73     pPrint cond <> text " ? " <> pPrint true <> text " : " <> pPrint false <> text " -> " <> pPrint res
  74   pPrint (UncondDef src dst) =
  75     ppsrc src <> text " -> " <> pPrint dst
  76     where
  77       ppsrc (Left id) = pPrint id
  78       ppsrc (Right expr) = pPrint expr
  79
  80 instance Pretty SignalExpr where
  81   pPrint (EqLit id lit) =
  82     parens $ pPrint id <> text " = " <> text lit
  83   pPrint (Literal lit) =
  84     text lit
  85   pPrint (Eq a b) =
  86     parens $ pPrint a <> text " = " <> pPrint b
  87
  88 instance Pretty SignalInfo where
  89   pPrint (SignalInfo name use ty hints) =
  90     text ":" <> (pPrint use) <> (ppname name)
  91     where
  92       ppname Nothing = empty
  93       ppname (Just name) = text ":" <> text name
  94
  95 instance Pretty SigUse where
  96   pPrint SigPortIn   = text "PI"
  97   pPrint SigPortOut  = text "PO"
  98   pPrint SigInternal = text "I"
  99   pPrint (SigStateOld n) = text "SO:" <> int n
 100   pPrint (SigStateNew n) = text "SN:" <> int n
 101   pPrint SigSubState = text "s"
 102
 103 instance Pretty VHDLSession where
 104   pPrint (VHDLSession mod nameCount funcs) =
 105     text "Module: " $$ nest 15 (text modname)
 106     $+$ text "NameCount: " $$ nest 15 (int nameCount)
 107     $+$ text "Functions: " $$ nest 15 (vcat (map ppfunc (Map.toList funcs)))
 108     where
 109       ppfunc (hsfunc, fdata) =
 110         pPrint hsfunc $+$ nest 5 (pPrint fdata)
 111       modname = showSDoc $ Module.pprModule (HscTypes.cm_module mod)
 112
 113 instance Pretty FuncData where
 114   pPrint (FuncData flatfunc entity arch) =
 115     text "Flattened: " $$ nest 15 (ppffunc flatfunc)
 116     $+$ text "Entity" $$ nest 15 (ppent entity)
 117     $+$ pparch arch
 118     where
 119       ppffunc (Just f) = pPrint f
 120       ppffunc Nothing  = text "Nothing"
 121       ppent (Just e)   = pPrint e
 122       ppent Nothing    = text "Nothing"
 123       pparch Nothing = text "VHDL architecture not present"
 124       pparch (Just _) = text "VHDL architecture present"
 125
 126 instance Pretty Entity where
 127   pPrint (Entity id args res decl) =
 128     text "Entity: " $$ nest 10 (pPrint id)
 129     $+$ text "Args: " $$ nest 10 (pPrint args)
 130     $+$ text "Result: " $$ nest 10 (pPrint res)
 131     $+$ ppdecl decl
 132     where
 133       ppdecl Nothing = text "VHDL entity not present"
 134       ppdecl (Just _) = text "VHDL entity present"
 135
 136 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
 137   pPrint (CoreSyn.NonRec b expr) =
 138     text "NonRec: " $$ nest 10 (prettyBind (b, expr))
 139   pPrint (CoreSyn.Rec binds) =
 140     text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
 141
 142 instance Pretty AST.VHDLId where
 143   pPrint id = ForSyDe.Backend.Ppr.ppr id
 144
 145 prettyBind :: (Show b, Show e) => (b, e) -> Doc
 146 prettyBind (b, expr) =
 147   text b' <> text " = " <> text expr'
 148   where
 149     b' = show b
 150     expr' = show expr
 151
 152 -- Derive Show for core expressions and binders, so we can see the actual
 153 -- structure.
 154 deriving instance (Show b) => Show (CoreSyn.Expr b)
 155 deriving instance (Show b) => Show (CoreSyn.Bind b)
 156
 157 -- Implement dummy shows for Note and Type, so we can at least use show on
 158 -- expressions.
 159 instance Show CoreSyn.Note where
 160   show n = "<note>"
 161 instance Show TypeRep.Type where
 162   show t = "_type:(" ++ (showSDoc $ ppr t) ++ ")"