Add Bluespec SystemVerilog pretty-printer

This adds a Bluespec SystemVerilog pretty-printer
(`Language.Bluespec.SystemVerilog.AST.Pretty`) in addition to the existing
Bluespec Haskell pretty-printer (`Language.Bluespec.Classic.AST.Pretty`).

language-bluespec.cabal

@@ -58,6 +58,8 @@ library
                         Language.Bluespec.Classic.AST.Builtin.Ids
                         Language.Bluespec.Classic.AST.Builtin.Types
 
+                        Language.Bluespec.SystemVerilog.AST.Pretty
+
                         Language.Bluespec.Lex
                         Language.Bluespec.Pretty
     other-modules:      Language.Bluespec.IntegerUtil

src/Language/Bluespec/Classic/AST/FString.hs

@@ -1,6 +1,7 @@
 -- This corresponds to src/comp/FStringCompat.hs in bsc.
 module Language.Bluespec.Classic.AST.FString
   ( FString
+  , concatFString
   , getFString
   , mkFString
   , tmpFString
@@ -27,6 +28,9 @@ instance Show FString where
 instance PPrint FString where
     pPrint _ _ x = text (show x)
 
+concatFString :: [FString] -> FString
+concatFString fs = FString $ T.concat [s | FString s <- fs]
+
 getFString :: FString -> String
 getFString = toString
 

src/Language/Bluespec/Classic/AST/Id.hs

@@ -5,20 +5,26 @@ module Language.Bluespec.Classic.AST.Id
   , addIdProps
   , createPositionString
   , enumId
+  , getBSVIdString
   , getIdBase
   , getIdBaseString
   , getIdPosition
   , getIdProps
   , getIdQual
   , getIdQualString
   , getIdString
+  , likeModule
   , mkId
+  , mkIdPost
   , mkQId
   , ppConId
   , ppId
   , ppVarId
+  , pvpId
+  , pvpPId
   , qualEq
   , setBadId
+  , setIdBase
   , setIdProps
 
   , IdProp(..)
@@ -35,6 +41,7 @@ import Language.Bluespec.Classic.AST.Position
 import Language.Bluespec.Classic.AST.Pretty
 import Language.Bluespec.Lex
 import Language.Bluespec.Prelude
+import Language.Bluespec.SystemVerilog.AST.Pretty
 import Language.Bluespec.Util
 
 data Id = Id { id_pos :: !Position,
@@ -72,6 +79,13 @@ instance PPrint Id where
                         (createPositionString (getIdPosition i)))
              else text (getIdString i)
 
+instance PVPrint Id where
+    pvPrint PDDebug _ i = text (show i)
+    pvPrint PDNoqual _ i = text (getIdBaseString i)
+    pvPrint _ _ i =
+      let s = getBSVIdString i
+      in text (if s=="not" then "!" else s)
+
 instance HasPosition Id where
     getPosition i = getIdPosition i
 
@@ -135,12 +149,22 @@ getIdString a | mfs == fsEmpty = getFString fs
     where mfs = getIdQual a
           fs = getIdBase a
 
+likeModule :: Id -> Bool
+likeModule i =
+  let s = getIdBaseString i
+      ln = length s
+      end = drop (ln-6) s
+  in if ln > 5 then end=="Module" else False
+
 mkId :: Position -> FString -> Id
 mkId pos fs =
     let value = Id pos fsEmpty fs []
     in -- trace("ID: " ++ (ppReadable value)) $
        value
 
+mkIdPost :: Id -> FString -> Id
+mkIdPost a fs = setIdBase a (concatFString [getIdBase a, fs])
+
 -- Qualified with a path.
 mkQId :: Position -> FString -> FString -> Id
 mkQId pos mfs fs
@@ -194,13 +218,56 @@ ppVarId d i
     '$':c:_ | isIdChar c -> text (getIdStringVar i) -- task names
     _ -> text (getIdStringVar i)
 
+pvpId :: PDetail -> Id -> Doc
+pvpId PDDebug i = pvPrint PDDebug 0 i
+pvpId PDNoqual i = pvPrint PDNoqual 0 i
+pvpId _d i =
+    case getIdBaseString i of
+    "->" -> text "(->)"
+    ":=" -> text "<="
+    "not" -> text "!"
+    s@(c:_) | isDigit c -> text s
+    c:_ | isIdChar c -> text (getBSVIdString i)
+    _ -> text ("("++getBSVIdString i++")")
+
+pvpPId :: PDetail -> Id -> Doc
+pvpPId d i =
+    case getIdBaseString i of
+    _   -> pvpId d i
+
+-- hack: suppress the package name for operators
+getBSVIdString :: Id -> String
+getBSVIdString a = (getBSVIdStringz a)
+getBSVIdStringz :: Id -> String
+getBSVIdStringz a
+    | getIdBase a == fsEmpty = error "CVPrint.getIdStr: empty identifier"
+    | getIdQual a == fsEmpty = getIdBaseStringz a
+    | not (isIdChar (head (getIdBaseStringz a))) = getIdBaseStringz a -- operators
+    | {-(not show_qual) &&-} (getIdQual a == fsPrelude) =
+          getIdBaseStringz a  -- suppress "Prelude::" unless flag is on
+    | {-(not show_qual) &&-} (getIdQual a == fsPreludeBSV) =
+          getIdBaseStringz a  -- suppress "Prelude::" unless flag is on
+    | otherwise = getIdQualString a ++ "::" ++ getIdBaseStringz a
+
+getIdBaseStringz :: Id -> String
+getIdBaseStringz a =
+    let s = getIdBaseString a
+    in {-if (not (isEse()) || length s < 7) then-} s
+       {-
+       else if (take 7 s == "ese_id_" || take 7 s == "Ese_id_") then drop 7 s
+       else s
+       -}
+
 qualEq :: Id -> Id -> Bool
 qualEq a b | getIdQual a == fsEmpty || getIdQual b == fsEmpty = getIdBase a == getIdBase b
 qualEq a b = a == b
 
 setBadId :: Id -> Id
 setBadId idx = addIdProp idx IdP_bad_name
 
+setIdBase :: Id -> FString -> Id
+setIdBase a fs = a { id_fs = fs }
+
 setIdProps :: Id -> [IdProp] -> Id
 setIdProps a l = a { id_props = l }
 

src/Language/Bluespec/Classic/AST/IntLit.hs

@@ -12,6 +12,7 @@ module Language.Bluespec.Classic.AST.IntLit
 import Language.Bluespec.Classic.AST.Pretty
 import Language.Bluespec.IntegerUtil
 import Language.Bluespec.Prelude
+import Language.Bluespec.SystemVerilog.AST.Pretty
 
 data IntLit = IntLit { ilWidth :: Maybe Integer,
                        ilBase  :: Integer,
@@ -36,6 +37,10 @@ instance Show IntLit where
 instance PPrint IntLit where
      pPrint _d _p i = text (show i)
 
+instance PVPrint IntLit where
+     pvPrint _d _p (IntLit { ilValue = i, ilWidth = w, ilBase = b }) =
+         text $ intFormat w b i
+
 ilDec :: Integer -> IntLit
 ilDec i = IntLit { ilWidth = Nothing, ilBase = 10, ilValue = i }
 
@@ -53,3 +58,20 @@ ilBin i = IntLit { ilWidth = Nothing, ilBase = 2,  ilValue = i }
 
 ilSizedBin :: Integer -> Integer -> IntLit
 ilSizedBin w i = IntLit { ilWidth = Just w, ilBase = 2, ilValue = i }
+
+intFormat :: Maybe Integer -> Integer -> Integer -> String
+intFormat mwidth base value | value < 0 = '-' : intFormat mwidth base (-value)
+intFormat mwidth  2 value = sizeFormat mwidth ++ "'b" ++ digitsFormat  2 value
+intFormat mwidth  8 value = sizeFormat mwidth ++ "'o" ++ digitsFormat  8 value
+intFormat mwidth 16 value = sizeFormat mwidth ++ "'h" ++ digitsFormat 16 value
+intFormat Nothing 10 value = digitsFormat 10 value
+intFormat mwidth 10 value = sizeFormat mwidth ++ "'d" ++ digitsFormat 10 value
+intFormat _mwidth base _value =
+    error ("bad radix to intFormat: " ++ show base)
+
+sizeFormat :: Maybe Integer -> String
+sizeFormat Nothing = ""
+sizeFormat (Just width) = integerToString 10 width
+
+digitsFormat :: Integer -> Integer -> String
+digitsFormat base value = integerToString (fromInteger base) value

src/Language/Bluespec/Classic/AST/Literal.hs

@@ -6,6 +6,7 @@ module Language.Bluespec.Classic.AST.Literal
 import Language.Bluespec.Classic.AST.IntLit
 import Language.Bluespec.Classic.AST.Pretty
 import Language.Bluespec.Prelude
+import Language.Bluespec.SystemVerilog.AST.Pretty
 
 data Literal
         = LString String
@@ -21,3 +22,10 @@ instance PPrint Literal where
     pPrint d p (LInt i) = pPrint d p i
     pPrint d p (LReal r) = pPrint d p r
     pPrint _ _ LPosition = text ("<Position>")
+
+instance PVPrint Literal where
+    pvPrint _ _ (LString s) = text (show s)
+    pvPrint _ _ (LChar c) = text (show [c])
+    pvPrint d p (LInt i) = pvPrint d p i
+    pvPrint d p (LReal r) = pvPrint d p r
+    pvPrint _ _ LPosition = text ("<Position>")

src/Language/Bluespec/Classic/AST/Position.hs

@@ -10,6 +10,7 @@ module Language.Bluespec.Classic.AST.Position
 
 import Language.Bluespec.Classic.AST.Pretty
 import Language.Bluespec.Prelude
+import Language.Bluespec.SystemVerilog.AST.Pretty
 
 -- For now, we don't track positions, although we may do so in the future.
 data Position = NoPos
@@ -18,6 +19,9 @@ data Position = NoPos
 instance PPrint Position where
     pPrint _ _ NoPos = text "<NoPos>"
 
+instance PVPrint Position where
+    pvPrint _ _ NoPos = text "<NoPos>"
+
 bestPosition :: Position -> Position -> Position
 bestPosition p1 p2 = if p1 == noPosition then p2 else p1
 

src/Language/Bluespec/Classic/AST/Pragma.hs

@@ -7,14 +7,18 @@ module Language.Bluespec.Classic.AST.Pragma
   , CSchedulePragma
   , IfcPragma(..)
 
+  , filterIArgNames
+  , filterPrintIfcArgs
   , ppPProp
+  , pvpPProp
   ) where
 
 import Language.Bluespec.Classic.AST.Id
 import Language.Bluespec.Classic.AST.Position
 import Language.Bluespec.Classic.AST.Pretty
 import Language.Bluespec.Classic.AST.SchedInfo
 import Language.Bluespec.Prelude
+import Language.Bluespec.SystemVerilog.AST.Pretty
 import Language.Bluespec.Util
 
 data Pragma
@@ -29,6 +33,12 @@ instance PPrint Pragma where
     pPrint d _p (Pnoinline is) =
         text "{-# noinline" <+> sep (map (ppId d) is) <+> text " #-}"
 
+instance PVPrint Pragma where
+    pvPrint d _p (Pproperties _i pps) =
+        foldr ($+$) empty (map (pvpPProp d) pps)
+    pvPrint d _p (Pnoinline is) =
+        text "(* noinline" <+> sep (map (pvpId d) is) <+> text " *)"
+
 instance HasPosition Pragma where
     getPosition (Pproperties i _) = getPosition i
     getPosition (Pnoinline (i:_)) = getPosition i
@@ -134,9 +144,77 @@ instance PPrint PProp where
     pPrint _d _ (PPinst_hide) = text "hide"
     pPrint _d _p v = text (drop 2 (show v))
 
+instance PVPrint PProp where
+    pvPrint  d _ (PPscanInsert i) = text "scan_insert =" <+> pvPrint d 0 i
+    pvPrint _d _ (PPCLK s) = text ("clock_prefix = " ++ s)
+    pvPrint _d _ (PPGATE s) = text ("gate_prefix = " ++ s)
+    pvPrint _d _ (PPRSTN s) = text ("reset_prefix = " ++ s)
+    pvPrint  d _ (PPclock_osc xs) =
+        text "clock_osc = {"
+        <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")"
+                   | (i,s) <- xs ]
+                   (text ",")
+        <> text "}"
+    pvPrint d _ (PPclock_gate xs) =
+        text "clock_gate = {"
+        <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")"
+                   | (i,s) <- xs ]
+                   (text ",")
+        <> text "}"
+    pvPrint d _ (PPgate_inhigh is) =
+        text "gate_inhigh = {" <> sepList (map (pvpId d) is) (text ",") <> text "}"
+    pvPrint d _ (PPgate_unused is) =
+        text "gate_unused = {" <> sepList (map (pvpId d) is) (text ",") <> text "}"
+
+    pvPrint d _ (PPreset_port xs) =
+        text "reset_port = {"
+        <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")"
+                   | (i,s) <- xs ]
+                   (text ",")
+        <> text "}"
+    pvPrint d _ (PParg_param xs) =
+        text "param_port = {"
+        <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")"
+                   | (i,s) <- xs ]
+                   (text ",")
+        <> text "}"
+    pvPrint d _ (PParg_port xs) =
+        text "arg_port = {"
+        <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")"
+                   | (i,s) <- xs ]
+                   (text ",")
+        <> text "}"
+    pvPrint d _ (PParg_clocked_by xs) =
+        text "clocked_by = {"
+        <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")"
+                   | (i,s) <- xs ]
+                   (text ",")
+        <> text "}"
+    pvPrint d _ (PParg_reset_by xs) =
+        text "reset_by = {"
+        <> sepList [ text "(" <> pvpId d i <> text "," <> (text s) <> text ")"
+                   | (i,s) <- xs ]
+                   (text ",")
+        <> text "}"
+    pvPrint _d _ (PPoptions os) = text "options = {" <> sepList (map (text . show) os) (text ",") <> text "}"
+    pvPrint _d _ (PPverilog) = text "synthesize"
+    pvPrint _d _ (PPalwaysReady _ms) = text "always_ready"
+    pvPrint _d _ (PPalwaysEnabled _ms) = text "always_enabled"
+    pvPrint _d _ (PPenabledWhenReady _ms) = text "enabled_when_ready"
+    pvPrint _d _ (PPbitBlast) = text "bit_blast"
+    pvPrint _d _ (PPdoc comment) = text ("doc = " ++ doubleQuote comment)
+    pvPrint _d _ (PPdeprecate comment) = text ("deprecate = " ++ doubleQuote comment)
+    pvPrint  d _ (PPparam ids) = text "param = \"" <> sepList (map (pvpId d) ids) (text ",") <> text "\""
+    pvPrint  d _ (PPinst_name i) = text "inst_name = \"" <> pvpId d i <> text "\""
+    pvPrint _d _ (PPinst_hide) = text "inst_hide"
+    pvPrint _d _p v = text (drop 2 (show v))
+
 ppPProp :: PDetail -> PProp -> Doc
 ppPProp d pprop = text "{-#" <+> pPrint d 0 pprop <+> text "#-};"
 
+pvpPProp :: PDetail -> PProp -> Doc
+pvpPProp d pprop = text "(*" <+> pvPrint d 0 pprop <+> text "*)"
+
 data RulePragma
     = RPfireWhenEnabled
     | RPnoImplicitConditions
@@ -226,3 +304,25 @@ instance PPrint IfcPragma where
     pPrint _d _ (PIResultName flds)    = text "result ="       <+> doubleQuotes (text flds)
     pPrint _d _ (PIAlwaysRdy )         = text "always_ready "
     pPrint _d _ (PIAlwaysEnabled )     = text "always_enabled "
+
+instance PVPrint  IfcPragma where
+    pvPrint  d _ (PIArgNames ids)       = text "ports ="   <+>
+                                          brackets ( (sepList (map (doubleQuotes . (ppVarId d)) ids) comma) )
+    pvPrint _d _ (PIPrefixStr flds)     = text "prefix ="       <+> doubleQuotes (text flds)
+    pvPrint _d _ (PIRdySignalName flds) = text "ready ="        <+> doubleQuotes (text flds)
+    pvPrint _d _ (PIEnSignalName flds)  = text "enable ="       <+> doubleQuotes (text flds)
+    pvPrint _d _ (PIResultName flds)    = text "result ="       <+> doubleQuotes (text flds)
+    pvPrint _d _ (PIAlwaysRdy )         = text "always_ready "
+    pvPrint _d _ (PIAlwaysEnabled )     = text "always_enabled "
+
+-- convenience function -- extract out PIArgNames ids.
+filterIArgNames :: [IfcPragma] -> [Id]
+filterIArgNames prags = concatMap getArgNames prags
+    where getArgNames :: IfcPragma -> [Id]
+          getArgNames (PIArgNames names) = names
+          getArgNames _                  = []
+
+filterPrintIfcArgs :: [IfcPragma] -> [IfcPragma]
+filterPrintIfcArgs prags = filter isPrintArg prags
+    where isPrintArg (PIArgNames _names) = False
+          isPrintArg _x                  = True

src/Language/Bluespec/Classic/AST/Pretty.hs

@@ -38,22 +38,6 @@ ppr d = pretty lineWidth linePref . pPrint d 0
 pprIndent :: PPrint a => Int -> PDetail -> a -> String
 pprIndent i d = pretty lineWidth linePref . nest i . pPrint d 0
 
-lineWidth, linePref :: Int
-lineWidth = 120
-linePref = 100
-
--- Produces a string from a text "x" in Normal mode with "w" line
--- length, "w/m" ribbons per line.
-pretty :: Int -> Int -> Doc -> String
-pretty w m x = fullRender PageMode w (toEnum w / toEnum m) string_txt "\n" x
-
--- The function which tells fullRender how to compose Doc elements
--- into a String.
-string_txt :: TextDetails -> String -> String
-string_txt (Chr c)   s  = c:s
-string_txt (Str s1)  s2 = s1 ++ s2
-string_txt (PStr s1) s2 = s1 ++ s2
-
 instance PPrint Int where
     pPrint _ _ x = text (itos x)