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)