cλash/CLasH/Utils/Pretty.hs

   1 module Pretty (prettyShow, pprString, pprStringDebug) 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, showSDocDebug, ppr, Outputable, OutputableBndr)
  13
  14 import qualified Language.VHDL.Ppr as Ppr
  15 import qualified Language.VHDL.AST as AST
  16 import qualified Language.VHDL.AST.Ppr
  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 = Ppr.ppr id
 140
 141 instance Pretty AST.VHDLName where
 142   pPrint name = Ppr.ppr name
 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
 150
 151 instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
 152   pPrint =
 153     vcat . map ppentry . Map.toList
 154     where
 155       ppentry (k, v) =
 156         pPrint k <> text " : " $$ nest 15 (pPrint v)
 157
 158 -- Convenience method for turning an Outputable into a string
 159 pprString :: (Outputable x) => x -> String
 160 pprString = showSDoc . ppr
 161
 162 pprStringDebug :: (Outputable x) => x -> String
 163 pprStringDebug = showSDocDebug . ppr