clash/CLasH/Utils/Pretty.hs

   1 module CLasH.Utils.Pretty (prettyShow, pprString, pprStringDebug, zEncodeString) where
   2
   3 -- Standard imports
   4 import qualified Data.Map as Map
   5 import Text.PrettyPrint.HughesPJClass
   6 import Data.Char
   7 import Numeric
   8
   9 -- GHC API
  10 import qualified CoreSyn
  11 import Outputable ( showSDoc, showSDocDebug, ppr, Outputable, OutputableBndr)
  12
  13 -- VHDL Imports
  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 -- Local imports
  19 import CLasH.VHDL.VHDLTypes
  20 import CLasH.Utils.Core.CoreShow
  21
  22 -- | A version of the default pPrintList method, which uses a custom function
  23 --   f instead of pPrint to print elements.
  24 printList :: (a -> Doc) -> [a] -> Doc
  25 printList f = brackets . fsep . punctuate comma . map f
  26
  27 {-
  28 instance Pretty FuncData where
  29   pPrint (FuncData flatfunc entity arch) =
  30     text "Flattened: " $$ nest 15 (ppffunc flatfunc)
  31     $+$ text "Entity" $$ nest 15 (ppent entity)
  32     $+$ pparch arch
  33     where
  34       ppffunc (Just f) = pPrint f
  35       ppffunc Nothing  = text "Nothing"
  36       ppent (Just e)   = pPrint e
  37       ppent Nothing    = text "Nothing"
  38       pparch Nothing = text "VHDL architecture not present"
  39       pparch (Just _) = text "VHDL architecture present"
  40 -}
  41
  42 instance Pretty Entity where
  43   pPrint (Entity id args res decl) =
  44     text "Entity: " $$ nest 10 (pPrint id)
  45     $+$ text "Args: " $$ nest 10 (pPrint args)
  46     $+$ text "Result: " $$ nest 10 (pPrint res)
  47     $+$ text "Declaration not shown"
  48
  49 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Bind b) where
  50   pPrint (CoreSyn.NonRec b expr) =
  51     text "NonRec: " $$ nest 10 (prettyBind (b, expr))
  52   pPrint (CoreSyn.Rec binds) =
  53     text "Rec: " $$ nest 10 (vcat $ map (prettyBind) binds)
  54
  55 instance (OutputableBndr b, Show b) => Pretty (CoreSyn.Expr b) where
  56   pPrint = text . show
  57
  58 instance Pretty AST.VHDLId where
  59   pPrint id = Ppr.ppr id
  60
  61 instance Pretty AST.VHDLName where
  62   pPrint name = Ppr.ppr name
  63
  64 prettyBind :: (Show b, Show e) => (b, e) -> Doc
  65 prettyBind (b, expr) =
  66   text b' <> text " = " <> text expr'
  67   where
  68     b' = show b
  69     expr' = show expr
  70
  71 instance (Pretty k, Pretty v) => Pretty (Map.Map k v) where
  72   pPrint =
  73     vcat . map ppentry . Map.toList
  74     where
  75       ppentry (k, v) =
  76         pPrint k <> text " : " $$ nest 15 (pPrint v)
  77
  78 -- Convenience method for turning an Outputable into a string
  79 pprString :: (Outputable x) => x -> String
  80 pprString = showSDoc . ppr
  81
  82 pprStringDebug :: (Outputable x) => x -> String
  83 pprStringDebug = showSDocDebug . ppr
  84
  85
  86 type UserString = String        -- As the user typed it
  87 type EncodedString = String     -- Encoded form
  88
  89 zEncodeString :: UserString -> EncodedString
  90 zEncodeString cs = case maybe_tuple cs of
  91                 Just n  -> n ++ (go cs)            -- Tuples go to Z2T etc
  92                 Nothing -> go cs
  93           where
  94                 go []     = []
  95                 go (c:cs) = encode_digit_ch c ++ go' cs
  96                 go' []     = []
  97                 go' (c:cs) = encode_ch c ++ go' cs
  98
  99 maybe_tuple :: UserString -> Maybe EncodedString
 100
 101 maybe_tuple "(# #)" = Just("Z1H")
 102 maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of
 103                                  (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
 104                                  _                  -> Nothing
 105 maybe_tuple "()" = Just("Z0T")
 106 maybe_tuple ('(' : cs)       = case count_commas (0::Int) cs of
 107                                  (n, ')' : _) -> Just ('Z' : shows (n+1) "T")
 108                                  _            -> Nothing
 109 maybe_tuple _                = Nothing
 110
 111 count_commas :: Int -> String -> (Int, String)
 112 count_commas n (',' : cs) = count_commas (n+1) cs
 113 count_commas n cs         = (n,cs)
 114
 115 encode_digit_ch :: Char -> EncodedString
 116 encode_digit_ch c | c >= '0' && c <= '9' = encode_as_unicode_char c
 117 encode_digit_ch c | otherwise            = encode_ch c
 118
 119 encode_ch :: Char -> EncodedString
 120 encode_ch c | unencodedChar c = [c]     -- Common case first
 121
 122 -- Constructors
 123 encode_ch '('  = "ZL"   -- Needed for things like (,), and (->)
 124 encode_ch ')'  = "ZR"   -- For symmetry with (
 125 encode_ch '['  = "ZM"
 126 encode_ch ']'  = "ZN"
 127 encode_ch ':'  = "ZC"
 128 encode_ch 'Z'  = "ZZ"
 129
 130 -- Variables
 131 encode_ch 'z'  = "zz"
 132 encode_ch '&'  = "za"
 133 encode_ch '|'  = "zb"
 134 encode_ch '^'  = "zc"
 135 encode_ch '$'  = "zd"
 136 encode_ch '='  = "ze"
 137 encode_ch '>'  = "zg"
 138 encode_ch '#'  = "zh"
 139 encode_ch '.'  = "zi"
 140 encode_ch '<'  = "zl"
 141 encode_ch '-'  = "zm"
 142 encode_ch '!'  = "zn"
 143 encode_ch '+'  = "zp"
 144 encode_ch '\'' = "zq"
 145 encode_ch '\\' = "zr"
 146 encode_ch '/'  = "zs"
 147 encode_ch '*'  = "zt"
 148 encode_ch '%'  = "zv"
 149 encode_ch c    = encode_as_unicode_char c
 150
 151 encode_as_unicode_char :: Char -> EncodedString
 152 encode_as_unicode_char c = 'z' : if isDigit (head hex_str) then hex_str
 153                                                            else '0':hex_str
 154   where hex_str = showHex (ord c) "U"
 155
 156 unencodedChar :: Char -> Bool   -- True for chars that don't need encoding
 157 unencodedChar 'Z' = False
 158 unencodedChar 'z' = False
 159 unencodedChar c   =  c >= 'a' && c <= 'z'
 160                   || c >= 'A' && c <= 'Z'
 161                   || c >= '0' && c <= '9'
 162                   || c == '_'