language-bluespec-0.1: src/Language/Bluespec/Classic/AST/Syntax.hs
module Language.Bluespec.Classic.AST.Syntax
( CPackage(..)
, CExport(..)
, CImport(..)
, CSignature(..)
, CFixity(..)
, CDefn(..)
, IdK(..)
, CFunDeps
, CExpr(..)
, CLiteral(..)
, COp(..)
, CSummands
, CInternalSummand(..)
, COSummands
, COriginalSummand(..)
, CField(..)
, CFields
, CCaseArm(..)
, CCaseArms
, CStmt(..)
, CStmts
, CMStmt(..)
, CRule(..)
, CDefl(..)
, CDef(..)
, CClause(..)
, CQual(..)
, CPat(..)
, CPOp(..)
, CInclude(..)
, cApply
, cVApply
, getName
, iKName
) where
import Data.Char (isAlpha)
import qualified Data.List as L
import Text.PrettyPrint.HughesPJClass
import Language.Bluespec.Classic.AST.Builtin.Ids
import Language.Bluespec.Classic.AST.Builtin.FStrings
import Language.Bluespec.Classic.AST.FString
import Language.Bluespec.Classic.AST.Id
import Language.Bluespec.Classic.AST.Literal
import Language.Bluespec.Classic.AST.Position
import Language.Bluespec.Classic.AST.Pragma
import Language.Bluespec.Classic.AST.Type
import Language.Bluespec.Classic.AST.Undefined
import Language.Bluespec.Classic.AST.VModInfo
import Language.Bluespec.IntegerUtil
import Language.Bluespec.Lex
import Language.Bluespec.Log2
import Language.Bluespec.Prelude
import Language.Bluespec.Pretty
import Language.Bluespec.Util
-- Complete package
data CPackage = CPackage
Id -- package name
(Either [CExport]
[CExport]) -- export identifiers
-- Left exps = export only exps
-- Right exps = export everything but exps
[CImport] -- imported identifiers
[CFixity] -- fixity declarations for infix operators
[CDefn] -- top level definitions
[CInclude] -- any `include files
deriving (Eq, Ord, Show)
instance Pretty CPackage where
pPrintPrec d _ (CPackage i exps imps fixs def includes) =
(t"package" <+> ppConId d i <> ppExports d exps <+> t "where {") $+$
pBlock d 0 True (map (pp d) imps ++ map (pp d) fixs ++ map (pp d) def ++ map (pp d) includes)
data CExport
= CExpVar Id -- export a variable identifier
| CExpCon Id -- export a constructor
| CExpConAll Id -- export an identifier and constructors
-- (datatypes, interfaces, etc.)
| CExpPkg Id -- export an entire package
deriving (Eq, Ord, Show)
instance Pretty CExport where
pPrintPrec d _p (CExpVar i) = ppVarId d i
pPrintPrec d _p (CExpCon i) = ppConId d i
pPrintPrec d _p (CExpConAll i) = ppConId d i <> t"(..)"
pPrintPrec d _p (CExpPkg i) = t"package" <+> ppId d i
ppExports :: PDetail -> Either [CExport] [CExport] -> Doc
ppExports _d (Right []) = empty
ppExports d (Right noexps) = t " hiding (" <> sepList (map (pp d) noexps) (t",") <> t")"
ppExports d (Left exports) = t "(" <> sepList (map (pp d) exports) (t",") <> t")"
data CImport
= CImpId Bool Id -- Bool indicates qualified
| CImpSign String Bool CSignature
deriving (Eq, Ord, Show)
instance Pretty CImport where
pPrintPrec d _p (CImpId q i) = t"import" <+> ppQualified q <+> ppConId d i
pPrintPrec d _p (CImpSign _ q (CSignature i _ _ _)) = t"import" <+> ppQualified q <+> ppConId d i <+> t "..."
ppQualified :: Bool -> Doc
ppQualified True = text "qualified"
ppQualified False = empty
-- Package signature from import
data CSignature
= CSignature Id [Id] [CFixity] [CDefn] -- package name, imported packages, definitions
deriving (Eq, Ord, Show)
instance Pretty CSignature where
pPrintPrec d _ (CSignature i imps fixs def) =
(t"signature" <+> ppConId d i <+> t "where" <+> t "{") $+$
pBlock d 0 True (map pi' imps ++ map (pp d) fixs ++ map (pp d) def)
where pi' i' = t"import" <+> ppConId d i'
data CFixity
= CInfix Integer Id
| CInfixl Integer Id
| CInfixr Integer Id
deriving (Eq, Ord, Show)
instance Pretty CFixity where
pPrintPrec d _ (CInfix p i) = text "infix" <+> text (show p) <+> ppInfix d i
pPrintPrec d _ (CInfixl p i) = text "infixl" <+> text (show p) <+> ppInfix d i
pPrintPrec d _ (CInfixr p i) = text "infixr" <+> text (show p) <+> ppInfix d i
-- Top level definition
data CDefn
= Ctype IdK [Id] CType
| Cdata { cd_visible :: Bool,
cd_name :: IdK,
cd_type_vars :: [Id],
cd_original_summands :: COSummands,
cd_internal_summands :: CSummands,
cd_derivings :: [CTypeclass] }
| Cstruct Bool StructSubType IdK [Id] CFields
[CTypeclass]
-- Bool indicates the constrs are visible
-- first [Id] are the names of this definition's argument type variables
-- last [CTypeclass] are derived classes
-- incoherent_matches superclasses name_with_kind variables fundeps default_methods
| Cclass (Maybe Bool) [CPred] IdK [Id] CFunDeps CFields
| Cinstance CQType [CDefl]
| CValue Id [CClause]
| CValueSign CDef
| Cforeign { cforg_name :: Id,
cforg_type :: CQType,
cforg_foreign_name :: Maybe String,
cforg_ports :: Maybe ([String], [String]) }
| Cprimitive Id CQType
| CprimType IdK
| CPragma Pragma
-- only in package signatures
| CIinstance Id CQType
-- CItype is imported abstractly
| CItype IdK [Id] [Position] -- positions of use that caused export
| CIclass (Maybe Bool) [CPred] IdK [Id] CFunDeps [Position] -- positions of use that caused export
| CIValueSign Id CQType
deriving (Eq, Ord, Show)
instance Pretty CDefn where
pPrintPrec d _p (Ctype i as ty) =
sep [sep ((t"type" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <+> t "=",
nest 2 (pp d ty)]
pPrintPrec d _p (Cdata { cd_visible = vis,
cd_name = i,
cd_type_vars = as,
cd_original_summands = cs@(_:_),
cd_internal_summands = [],
cd_derivings = _ds }) = -- a hack to print original constructors
sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="),
nest 2 (ppOSummands d cs)]
pPrintPrec d _p (Cdata { cd_visible = vis,
cd_name = i,
cd_type_vars = as,
cd_internal_summands = cs,
cd_derivings = ds }) =
sep [sep ((t"data" <+> ppConIdK d i) : map (nest 2 . ppVarId d) as) <> t(if vis then " =" else " =="),
nest 2 (ppSummands d cs)]
<> ppDer d ds
pPrintPrec d _p (Cstruct vis (SInterface prags) i as fs ds) =
(t("interface ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> ppIfcPragma d prags <+> t(if vis then "= {" else "== {")) $+$
pBlock d 4 False (map (ppField d) fs) <> ppDer d ds
pPrintPrec d _p (Cstruct vis _ss i as fs ds) =
(t("struct ") <> sep (ppConIdK d i : map (nest 2 . ppVarId d) as) <+> t(if vis then "= {" else "== {")) $+$
pBlock d 4 False (map (ppField d) fs) <> ppDer d ds
pPrintPrec d _p (Cclass incoh ps ik is fd ss) =
(t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (ppVarId d) is)) <> ppFDs d fd <+> t "where {") $+$
pBlock d 4 False (map (ppField d) ss)
where t_cls = case incoh of
Just False -> t"class coherent"
Just True -> t"class incoherent"
Nothing -> t"class"
pPrintPrec d _p (Cinstance qt ds) =
(t"instance" <+> pPrintPrec d 0 qt <+> t "where {") $+$
pBlock d 4 False (map (pPrintPrec d 0) ds)
pPrintPrec d p (CValueSign def) = pPrintPrec d p def
pPrintPrec d p (CValue i cs) =
vcat (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs)
pPrintPrec d _p (Cprimitive i ty) =
text "primitive" <+> ppVarId d i <+> t "::" <+> pp d ty
pPrintPrec d p (CPragma pr) = pPrintPrec d p pr
pPrintPrec d _p (CprimType ik) =
t"primitive type" <+>
-- don't use ppConIdK because this syntax has no parentheses
case (ik) of
(IdK i) -> ppConId d i
(IdKind i k) -> ppConId d i <+> t "::" <+> pp d k
(IdPKind i pk) -> ppConId d i <+> t "::" <+> pp d pk
pPrintPrec d _p (Cforeign i ty oname opnames) =
text "foreign" <+> ppVarId d i <+> t "::" <+> pp d ty <> (case oname of Nothing -> text ""; Just s -> text (" = " ++ show s)) <> (case opnames of Nothing -> text ""; Just (is, os) -> t"," <> pparen True (sep (map (text . show) is ++ po os)))
where po [o] = [text ",", text (show o)]
po os = [t"(" <> sepList (map (text . show) os) (t",") <> t ")"]
pPrintPrec d _p (CIinstance i qt) =
t"instance" <+> ppConId d i <+> pPrintPrec d 0 qt
pPrintPrec d _p (CItype i as _positions) =
sep (t"type" <+> ppConIdK d i : map (nest 2 . ppVarId d) as)
pPrintPrec d _p (CIclass incoh ps ik is fd _positions) =
t_cls <+> ppPreds d ps (sep (ppConIdK d ik : map (nest 2 . ppVarId d) is)) <> ppFDs d fd
where t_cls = case incoh of
Just False -> t"class coherent"
Just True -> t"class incoherent"
Nothing -> t"class"
pPrintPrec d _p (CIValueSign i ty) = ppVarId d i <+> t "::" <+> pp d ty
instance HasPosition CDefn where
getPosition d = getPosition (getName d)
-- Since IdPKind is only expected in some disjuncts of CDefn, we could
-- create a separate IdPK for those cases, but that seems like overkill.
-- IdPKind in other locations will just be treated like IdK (no kind info).
data IdK
= IdK Id
| IdKind Id Kind
-- this should not exist after typecheck
| IdPKind Id PartialKind
deriving (Eq, Ord, Show)
instance Pretty IdK where
pPrintPrec d p (IdK i) = pPrintPrec d p i
pPrintPrec d _p (IdKind i k) = pparen True $ pp d i <+> t "::" <+> pp d k
pPrintPrec d _p (IdPKind i pk) = pparen True $ pp d i <+> t "::" <+> pp d pk
instance HasPosition IdK where
getPosition (IdK i) = getPosition i
getPosition (IdKind i _) = getPosition i
getPosition (IdPKind i _) = getPosition i
pBlock :: PDetail -> Int -> Bool -> [Doc] -> Doc
pBlock _ _n _ [] = t"}"
pBlock _ n nl xs =
(t (replicate n ' ') <>
foldr1 ($+$) (map (\ x -> x <> if nl then t";" $+$ t"" else t";") (init xs) ++ [last xs])) $+$
t"}"
ppDer :: PDetail -> [CTypeclass] -> Doc
ppDer _d [] = text ""
ppDer d is = text " deriving (" <> sepList (map (pPrintPrec d 0) is) (text ",") <> text ")"
type CFunDeps = [([Id],[Id])]
-- Expressions
data CExpr
= CLam (Either Position Id) CExpr
| CLamT (Either Position Id) CQType CExpr
| Cletseq [CDefl] CExpr -- rhs of "let x = x" refers to previous def
-- before current let or in earlier arm
| Cletrec [CDefl] CExpr -- rhs of "let x = x" refers to self
| CSelect CExpr Id -- expr, field id
| CCon Id [CExpr] -- constructor id, arguments
| Ccase Position CExpr CCaseArms
-- Either a struct type or a constructor with named fields.
-- The 'Maybe Bool' argument can indicate if it is specifically
-- one or the other (True for struct), otherwise the typechecker
-- will attempt to determine which is intended.
| CStruct (Maybe Bool) Id [(Id, CExpr)]
| CStructUpd CExpr [(Id, CExpr)]
-- for hardware writes
-- lhs <= rhs
| Cwrite Position CExpr CExpr
| CAny Position UndefKind
| CVar Id
| CApply CExpr [CExpr]
| CTaskApply CExpr [CExpr] -- system task calls
| CTaskApplyT CExpr CType [CExpr] -- type-checked $task (only $display) calls (the type is the inferred function type for the varargs task)
| CLit CLiteral
| CBinOp CExpr Id CExpr
| CHasType CExpr CQType
| Cif Position CExpr CExpr CExpr
-- x[a]
| CSub Position CExpr CExpr
-- x[a:b]
| CSub2 CExpr CExpr CExpr
-- x[a:b] = y
| CSubUpdate Position CExpr (CExpr, CExpr) CExpr
| Cmodule Position [CMStmt]
| Cinterface Position (Maybe Id) [CDefl]
| CmoduleVerilog
CExpr -- expr for the module name (type String)
Bool -- whether it is a user-imported module
VClockInfo -- clocks
VResetInfo -- resets
[(VArgInfo,CExpr)] -- input arguments
[VFieldInfo] -- output interface fields
VSchedInfo -- scheduling annotations
VPathInfo -- path annotations
| CForeignFuncC Id CQType -- link name, wrapped type
| Cdo Bool CStmts -- Bool indicates recursive binding
| Caction Position CStmts
| Crules [CSchedulePragma] [CRule]
-- used before operator parsing
| COper [COp]
-- from deriving
| CCon1 Id Id CExpr -- type id, con id, expr
| CSelectTT Id CExpr Id -- type id, expr, field id
-- INTERNAL in type checker
| CCon0 (Maybe Id) Id -- type id, constructor id
-- Not part of the surface syntax, used after type checking
| CConT Id Id [CExpr] -- type id, constructor id, arguments
| CStructT CType [(Id, CExpr)]
| CSelectT Id Id -- type id, field id
| CLitT CType CLiteral
| CAnyT Position UndefKind CType
| CmoduleVerilogT CType
CExpr -- expr for the module name (type String)
Bool -- whether it is a user-imported module
VClockInfo -- clocks
VResetInfo -- resets
[(VArgInfo,CExpr)] -- input arguments
[VFieldInfo] -- output interface fields
VSchedInfo -- scheduling annotations
VPathInfo -- path annotations
| CForeignFuncCT Id CType -- link name, primitive type
| CTApply CExpr [CType]
-- for passing pprops as values
| Cattributes [(Position,PProp)]
deriving (Eq, Ord, Show)
instance Pretty CExpr where
pPrintPrec d p (CLam ei e) = ppQuant "\\ " d p ei e
pPrintPrec d p (CLamT ei _ty e) = ppQuant "\\ " d p ei e
pPrintPrec d p (Cletseq [] e) = pparen (p > 0) $
(t"letseq in" <+> pp d e)
pPrintPrec d p (Cletseq ds e) = pparen (p > 0) $
(t"letseq" <+> text "{" <+> foldr1 ($+$) (map (pp d) ds)) <+> text "}" $+$
(t"in " <> pp d e)
pPrintPrec d p (Cletrec [] e) = pparen (p > 0) $
(t"let in" <+> pp d e)
pPrintPrec d p (Cletrec ds e) = pparen (p > 0) $
(t"let" <+> t "{" <+> foldr1 ($+$) (map (pp d) ds)) <+> t "}" $+$
(t"in " <> pp d e)
pPrintPrec d p (CSelect e i) = pparen (p > (fromIntegral maxPrec+2)) $ pPrintPrec d (fromIntegral maxPrec+2) e <> t"." <> ppVarId d i
pPrintPrec d _p (CCon i []) = ppConId d i
pPrintPrec d p (CCon i es) = pPrintPrec d p (CApply (CCon i []) es)
pPrintPrec d p (Ccase _pos e arms) = pparen (p > 0) $ ppCase d e arms
pPrintPrec _d _p (CAny {}) = text "_"
pPrintPrec d _p (CVar i) = ppVarId d i
pPrintPrec _d _p (CStruct _ tyc []) | tyc == idPrimUnit = text "()"
pPrintPrec d p (CStruct _ tyc ies) = pparen (p > 0) $ pPrintPrec d (fromIntegral maxPrec+1) tyc <+> t "{" <+> sepList (map f ies ++ [t"}"]) (t";")
where f (i, e) = ppVarId d i <+> t "=" <+> pp d e
pPrintPrec d p (CStructUpd e ies) = pparen (p > 0) $ pPrintPrec d (fromIntegral maxPrec+1) e <+> t "{" <+> sepList (map f ies ++ [t"}"]) (t";")
where f (i, e') = ppVarId d i <+> t "=" <+> pp d e'
pPrintPrec d p (Cwrite _ e v) = pparen (p > 0) $ pPrintPrec d (fromIntegral maxPrec+1) e <+> t ":=" <+> pPrintPrec d p v
pPrintPrec d p (CApply e [])
| d == pdReadable
= pPrintPrec pdReadable p e
pPrintPrec d p (CApply e es) = pparen (p>(fromIntegral maxPrec-1)) $
sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) es)
where ppApArg e' = pPrintPrec d (fromIntegral maxPrec) e'
pPrintPrec d p (CTaskApply e es) = pparen (p>(fromIntegral maxPrec-1)) $
sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) es)
where ppApArg e' = pPrintPrec d (fromIntegral maxPrec) e'
-- XXX: should include t?
pPrintPrec d p (CTaskApplyT e _t es) = pparen (p>(fromIntegral maxPrec-1)) $
sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) es)
where ppApArg e' = pPrintPrec d (fromIntegral maxPrec) e'
pPrintPrec d p (CLit l) = pPrintPrec d p l
pPrintPrec d p (CBinOp e1 i e2) = ppOp d p i e1 e2
pPrintPrec d p (CHasType e t') = pparen (p>0) $ pPrintPrec d (fromIntegral maxPrec) e <> text "::" <> pPrintPrec d (fromIntegral maxPrec) t'
pPrintPrec d p (Cif _pos c tr e) = pparen (p>0) (sep [t"if" <+> pp d c <+> t "then", nest 4 (pp d tr), t"else", nest 4 (pp d e)])
pPrintPrec d _p (CSub _pos e s) = pPrintPrec d (fromIntegral maxPrec) e <> t"[" <> pp d s <> t"]"
pPrintPrec d _p (CSub2 e h l) = pPrintPrec d (fromIntegral maxPrec) e <> t"[" <> pp d h <> t":" <> pp d l <> t"]"
pPrintPrec d p (CSubUpdate _pos e (h, l) rhs) = pPrintPrec d p (CSub2 e h l) <> t"=" <> pPrintPrec d (fromIntegral maxPrec) rhs
pPrintPrec d _p (Cmodule _ is) = t"module {" $+$ pBlock d 2 False (map (pp d) is)
pPrintPrec d p (Cinterface _pos Nothing ds) =
pparen (p>0) (t"interface {" $+$ pBlock d 2 False (map (pp d) ds))
pPrintPrec d p (Cinterface _pos (Just i) ds) =
pparen (p>0) (t"interface" <+> pp d i <+> t "{" $+$ pBlock d 2 False (map (pp d) ds))
pPrintPrec d _p (CmoduleVerilog m _ui c r ses fs sch _ps) =
sep [
t"module verilog" <+> pp d m <+>
pp d c <> t"" <+> pp d r <+> t"",
nest 4 (if null ses then t"" else pparen True (sepList (map ppA ses) (t","))),
nest 4 (t"{" $+$ pBlock d 2 False (map f fs)),
nest 4 (pp d sch) ]
where mfi _s Nothing = empty
mfi s (Just i) = t s <+> ppVarId d i
mfp _s Nothing = empty
mfp s (Just (VName s', _)) = t s <+> t s'
f (Clock i) = t "clock_field " <> ppVarId d i
f (Reset i) = t "reset_field " <> ppVarId d i
f (Inout i (VName p') mc mr) =
t "inout_field " <> ppVarId d i <+> t p' <+>
mfi "clocked_by" mc <+> mfi "reset_by" mr
f (Method i mc mr n ps mo me) =
ppVarId d i <> g n <+> t "=" <+> t (unwords (map h ps)) <+>
mfi "clocked_by" mc <+> mfi "reset_by" mr <+> mfp "output" mo <+> mfp "enable" me
g 1 = t""
g n = t("[" ++ itos n ++ "]")
h (s,[]) = show s
h (s,ps) = show s ++ "{" ++ L.intercalate "," (map (drop 2 . show) ps) ++ "}"
ppA (ai, e) = text "(" <> text (ppReadable ai) <> text "," <+> pp d e <> text ")"
pPrintPrec d _p (CForeignFuncC i _wrap_ty) =
-- There's no real Classic syntax for this:
t"ForeignFuncC" <+> pp d i
pPrintPrec d p (Cdo _ ss) = pparen (p>0) $ t "do" <+> t "{" <+> sepList (map (pPrintPrec d 0) ss ++ [t"}"]) (t";")
pPrintPrec d p (Caction _ ss) = pparen (p>0) $ t "action" <+> t "{" <+> sepList (map (pPrintPrec d 0) ss ++ [t"}"]) (t";")
pPrintPrec d p (Crules [] rs) = pparen (p>0) $ t"rules {" $+$ pBlock d 2 False (map (pp d) rs)
pPrintPrec d p (Crules ps rs) = pPrintPrec d p ps $+$
(pparen (p>0) $ t"rules {" $+$ pBlock d 2 False (map (pp d) rs))
pPrintPrec d p (COper ops) = pparen (p > fromIntegral maxPrec-1) (sep (map (pPrintPrec d (fromIntegral maxPrec-1)) ops))
----
pPrintPrec d p (CCon1 _ i e) = pPrintPrec d p (CCon i [e])
pPrintPrec d p (CSelectTT _ e i) = pparen (p > (fromIntegral maxPrec+2)) $ pPrintPrec d (fromIntegral maxPrec+2) e <> t"." <> ppVarId d i
----
pPrintPrec d _p (CCon0 _ i) = ppConId d i
----
pPrintPrec d p (CConT _ i es) = pPrintPrec d p (CCon i es)
pPrintPrec d p (CStructT ty ies) = pPrintPrec d p (CStruct (Just True) tyc ies)
-- where (Just tyc) = leftCon ty
where tyc = case leftCon ty of
Just tyc' -> tyc'
Nothing -> error "Syntax.Pretty(CExpr): CStructT (leftCon ty failed)"
pPrintPrec d _p (CSelectT _ i) = text "." <> ppVarId d i
pPrintPrec d p (CLitT _ l) = pPrintPrec d p l
pPrintPrec _d _p (CAnyT _pos _uk _t) = text "_"
pPrintPrec d p (CmoduleVerilogT _ m ui c mr ses fs sch ps) = pPrintPrec d p (CmoduleVerilog m ui c mr ses fs sch ps)
pPrintPrec d _p (CForeignFuncCT i _prim_ty) = t"ForeignFuncC" <+> pp d i
pPrintPrec d p (CTApply e ts) = pparen (p>(fromIntegral maxPrec-1)) $
sep (pPrintPrec d (fromIntegral maxPrec-1) e : map (nest 2 . ppApArg) ts)
where ppApArg ty = t"\183" <> pPrintPrec d (fromIntegral maxPrec) ty
pPrintPrec d _p (Cattributes pps) = pparen True $ text "Attributes" <+> pPrintPrec d 0 (map snd pps)
instance HasPosition CExpr where
getPosition (CLam ei _) = getPosition ei
getPosition (CLamT ei _ _) = getPosition ei
getPosition (Cletseq ds e) = getPosition (ds, e)
getPosition (Cletrec ds e) = getPosition (ds, e)
getPosition (CSelect e _) = getPosition e
getPosition (CSelectTT _ e _) = getPosition e
getPosition (CCon c _) = getPosition c
getPosition (Ccase pos _ _) = pos
getPosition (CStruct _ i _) = getPosition i
getPosition (CStructUpd e _) = getPosition e
getPosition (Cwrite pos _ _) = pos
getPosition (CAny pos _) = pos
getPosition (CVar i) = getPosition i
getPosition (CApply e _) = getPosition e
getPosition (CTaskApply e _) = getPosition e
getPosition (CTaskApplyT e _ _) = getPosition e
getPosition (CLit l) = getPosition l
getPosition (CBinOp e _ _) = getPosition e
getPosition (CHasType e _) = getPosition e
getPosition (Cif pos _ _ _) = pos
getPosition (CSub pos _ _) = pos
getPosition (CSub2 e _ _) = getPosition e
getPosition (CSubUpdate pos _ _ _) = pos
getPosition (CCon1 _ c _) = getPosition c
getPosition (Cmodule pos _) = pos
getPosition (Cinterface pos _i _ds) = pos
getPosition (CmoduleVerilog e _ _ _ ses fs _ _) =
getPosition (e, map snd ses, fs)
getPosition (CmoduleVerilogT _ e _ _ _ ses fs _ _) =
getPosition (e, map snd ses, fs)
getPosition (CForeignFuncC i _) = getPosition i
getPosition (CForeignFuncCT i _) = getPosition i
getPosition (Cdo _ ss) = getPosition ss
getPosition (Caction pos _ss) = pos
getPosition (Crules _ rs) = getPosition rs
getPosition (COper es) = getPosition es
getPosition (Cattributes pps) =
-- take the position of the first pprop with a good position
getPosition (map fst pps)
--
getPosition (CTApply e ts) = getPosition (e, ts)
getPosition (CConT _ c _) = getPosition c
getPosition (CCon0 _ c) = getPosition c
getPosition (CSelectT _ i) = getPosition i
getPosition (CLitT _ l) = getPosition l
getPosition (CAnyT pos _ _) = pos
getPosition e = error ("no match in getPosition: " ++ ppReadable e)
data CLiteral = CLiteral Position Literal deriving (Show)
instance Eq CLiteral where
CLiteral _ l == CLiteral _ l' = l == l'
instance Ord CLiteral where
CLiteral _ l `compare` CLiteral _ l' = l `compare` l'
instance Pretty CLiteral where
pPrintPrec d p (CLiteral _ l) = pPrintPrec d p l
instance HasPosition CLiteral where
getPosition (CLiteral p _) = p
ppQuant :: String -> PDetail -> Rational -> Either Position Id -> CExpr -> Doc
ppQuant s d p ei e =
let ppI (Left _) = text "_"
ppI (Right i) = pPrintPrec d 0 i
in pparen (p>0) (sep [t s <> ppI ei <+> t "->", pp d e])
data COp
= CRand CExpr -- operand
| CRator Int Id -- infix operator Id, Int is the number of arguments?
deriving (Eq, Ord, Show)
instance Pretty COp where
pPrintPrec d _ (CRand p) = pp d p
pPrintPrec d _ (CRator _ i) = ppInfix d i
instance HasPosition COp where
getPosition (CRand e) = getPosition e
getPosition (CRator _ i) = getPosition i
ppCase :: PDetail -> CExpr -> [CCaseArm] -> Doc
ppCase detail scrutinee arms =
(t"case" <+> pp detail scrutinee <+> t "of {") $+$
pBlock detail 0 False (map ppArm arms)
where ppArm arm =
sep [pPrintPrec detail 0 (cca_pattern arm) <>
ppQuals detail (cca_filters arm) <+> t "-> ",
nest 2 (pp detail (cca_consequent arm))]
ppOp :: PDetail -> Rational -> Id -> CExpr -> CExpr -> Doc
ppOp d pd i p1 p2 =
pparen (pd > 0) (sep [pPrintPrec d 1 p1 <> t"" <+> ppInfix d i, pPrintPrec d 1 p2])
{-
let (p, lp, rp) =
case getFixity i of
FInfixl p -> (p, p, p+1)
FInfixr p -> (p, p+1, p)
FInfix p -> (p, p+1, p+1)
in pparen (d > PDReadable || pd>p)
(sep [pPrint d lp p1 <> t"" <+> ppInfix d i, pPrint d rp p2])
-}
type CSummands = [CInternalSummand]
-- summand in internal form (each summand only takes a single argument
-- whose type is CType)
-- Data constructors can have multiple names for a constructor (for backwards
-- compatibility with old names), but the first name is the primary name
-- (used in compiler output etc).
data CInternalSummand =
CInternalSummand { cis_names :: [Id],
cis_arg_type :: CType,
cis_tag_encoding :: Integer }
deriving (Eq, Ord, Show)
instance HasPosition CInternalSummand where
getPosition summand = getPosition (cis_names summand)
-- original summands (taking a list of arguments, each of whose types
-- is given by CQType); the Int is a hack to support Enums with
-- noncontiguous Bits encodings
-- Data constructors can have multiple names for a constructor (for backwards
-- compatibility with old names), but the first name is the primary name
-- (used in compiler output etc).
type COSummands = [COriginalSummand]
data COriginalSummand =
COriginalSummand { cos_names :: [Id],
cos_arg_types :: [CQType],
cos_field_names :: Maybe [Id],
cos_tag_encoding :: Maybe Integer }
deriving (Eq, Ord, Show)
-- if CQType is a function, [IfcPragmas] (if present) lists argument names
-- (used by the backend to generate pretty names for module ports)
data CField = CField { cf_name :: Id,
cf_pragmas :: Maybe [IfcPragma],
cf_type :: CQType,
cf_default :: [CClause],
cf_orig_type :: Maybe CType
}
deriving (Eq, Ord, Show)
instance Pretty CField where
pPrintPrec d _p f = ppField d f
ppField :: PDetail -> CField -> Doc
ppField detail field =
let fid = cf_name field
dfl = cf_default field
in
(ppVarId detail fid <+> t "::" <+> pp detail (cf_type field)
<+> maybe empty (ppIfcPragma detail) (cf_pragmas field) <>
if (null dfl) then empty else text ";") $$
-- display the default, if it exists
if (null dfl)
then empty
else let ppC cl = ppClause detail 0 [ppVarId detail fid] cl
in foldr1 (\ x y -> x <> text ";" $$ y) (map ppC dfl)
-- XXX not including orig_type
ppIfcPragma :: PDetail -> [IfcPragma] -> Doc
ppIfcPragma _detail [] = empty
ppIfcPragma detail ps =
text "{-#" <+>
sep (punctuate comma (map (pPrintPrec detail 0) ps ) )
<+> text "#-}"
ppFDs :: PDetail -> CFunDeps -> Doc
ppFDs _d [] = empty
ppFDs d fd = text " |" <+> sepList (map (ppFD d) fd) (t",")
ppFD :: PDetail -> ([Id], [Id]) -> Doc
ppFD d (as,rs) = sep (ppVarId d <$> as) <+> t "->" <+> sep (ppVarId d <$> rs)
ppPreds :: PDetail -> [CPred] -> Doc -> Doc
ppPreds _d [] x = x
ppPreds d preds x = t "(" <> sepList (map (pPrintPrec d 0) preds) (t ",") <> t ") =>" <+> x
ppConIdK :: PDetail -> IdK -> Doc
ppConIdK d (IdK i) = ppConId d i
ppConIdK d (IdKind i k) = pparen True $ ppConId d i <+> t "::" <+> pp d k
ppConIdK d (IdPKind i pk) = pparen True $ ppConId d i <+> t "::" <+> pp d pk
type CFields = [CField] -- just a list of CField
-- redundant
--type Ids = [Id]
data CCaseArm = CCaseArm { cca_pattern :: CPat,
cca_filters :: [CQual],
cca_consequent :: CExpr }
deriving (Eq, Ord, Show)
instance HasPosition CCaseArm where
getPosition arm =
getPosition (cca_pattern arm) `bestPosition`
getPosition (cca_filters arm) `bestPosition`
getPosition (cca_consequent arm)
type CCaseArms = [CCaseArm] -- [(CPat, [CQual], CExpr)]
data CStmt
-- bind cexpr of type cqtype to cpat; id, if present, is instance name
= CSBindT CPat (Maybe CExpr) [(Position,PProp)] CQType CExpr
-- bind cexpr to cpat; id, if present, is instance name
| CSBind CPat (Maybe CExpr) [(Position,PProp)] CExpr
| CSletseq [CDefl] -- rhs of "let x = x" refers to previous def
-- before current let or in earlier arm
| CSletrec [CDefl] -- rhs of "let x = x" refers to self
| CSExpr (Maybe CExpr) CExpr
deriving (Eq, Ord, Show)
instance Pretty CStmt where
pPrintPrec d _p (CSBindT pat _inst pprops ty e) =
foldr ($+$) empty $
(map (ppPProp d . snd) pprops) ++
[pp d pat <+> t "::" <+> pp d ty <+> t "<-" <+> pp d e]
pPrintPrec d _p (CSBind pat _inst pprops e) =
foldr ($+$) empty $
(map (ppPProp d . snd) pprops) ++
[pp d pat <+> t "<-" <+> pp d e]
pPrintPrec _d _p (CSletseq []) = error "Syntax.Pretty(CStmt): CSletseq []"
pPrintPrec d _p (CSletseq ds) = text "letseq" <+> text "{" <+> foldr1 ($+$) (map (pp d) ds) <+> text "}"
pPrintPrec _d _p (CSletrec []) = error "Syntax.Pretty(CStmt): CSletrec []"
pPrintPrec d _p (CSletrec ds) = text "let" <+> text "{" <+> foldr1 ($+$) (map (pp d) ds) <+> text "}"
pPrintPrec d p (CSExpr _ e) = pPrintPrec d p e
instance HasPosition CStmt where
getPosition (CSBindT p _i _pps _t _e) = getPosition p
getPosition (CSBind p _i _pps _e) = getPosition p
getPosition (CSletseq ds) = getPosition ds
getPosition (CSletrec ds) = getPosition ds
getPosition (CSExpr _ e) = getPosition e
type CStmts = [CStmt]
data CMStmt
= CMStmt CStmt
| CMrules CExpr
| CMinterface CExpr
| CMTupleInterface Position [CExpr]
deriving (Eq, Ord, Show)
instance Pretty CMStmt where
pPrintPrec d p (CMStmt s) = pPrintPrec d p s
pPrintPrec d p (CMrules e) = pPrintPrec d p e
pPrintPrec d p (CMinterface e) = pPrintPrec d p (cVApply (idReturn (getPosition e)) [e])
pPrintPrec d p (CMTupleInterface _ es) = text"(" <> sepList (map (pPrintPrec d p) es) (text ",") <> text ")"
instance HasPosition CMStmt where
getPosition (CMStmt s) = getPosition s
getPosition (CMrules e) = getPosition e
getPosition (CMinterface e) = getPosition e
getPosition (CMTupleInterface pos _e) = pos
data CRule
= CRule [RulePragma] (Maybe CExpr) [CQual] CExpr
| CRuleNest [RulePragma] (Maybe CExpr) [CQual] [CRule]
deriving (Eq, Ord, Show)
instance HasPosition CRule where
getPosition (CRule _ i qs e) = getPosition (i, qs, e)
getPosition (CRuleNest _ i qs rs) = getPosition (i, qs, rs)
instance Pretty CRule where
pPrintPrec d _p (CRule rps mlbl mqs e) =
ppRPS d rps $+$
(case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <> sep [ppQuals d mqs, t " ==>",
nest 4 (pp d e)]
pPrintPrec d _p (CRuleNest rps mlbl mqs rs) =
ppRPS d rps $+$
(case mlbl of Nothing -> t""; Just i -> pp d i <> t": ") <>
(ppQuals d mqs $+$ pBlock d 2 False (map (pp d) rs))
ppRPS :: PDetail -> [RulePragma] -> Doc
ppRPS _d [] = text ""
ppRPS d rps = vcat (map (pPrintPrec d 0) rps)
-- | A definition with a binding. Can occur as a let expression, let statement
-- in a do block, a typeclass instance defn, or bindings in an interface.
data CDefl -- [CQual] part is the when clause used in an interface
-- binding, ie the explicit condition attached to each method
= CLValueSign CDef [CQual] -- let x :: T = e2 -- explicit type sig
| CLValue Id [CClause] [CQual] -- let y = e2 -- no explicit type sig
| CLMatch CPat CExpr -- let [z] = e3
deriving (Eq, Ord, Show)
instance Pretty CDefl where
pPrintPrec d p (CLValueSign def me) = optWhen d me $ pPrintPrec d p def
pPrintPrec d p (CLValue i cs me) = optWhen d me $
foldr1 ($+$) (map (\ cl -> ppClause d p [ppVarId d i] cl <> t";") cs)
pPrintPrec d p (CLMatch pat e) = ppClause d p [] (CClause [pat] [] e)
instance HasPosition CDefl where
getPosition (CLValueSign d _) = getPosition d
getPosition (CLValue i _ _) = getPosition i
getPosition (CLMatch p e) = getPosition (p, e)
optWhen :: PDetail -> [CQual] -> Doc -> Doc
optWhen _d [] s = s
optWhen d qs s = s $+$ (t" " <> ppQuals d qs)
ppValueSign :: PDetail -> Id -> [TyVar] -> CQType -> [CClause] -> Doc
ppValueSign d i [] ty cs =
(ppVarId d i <+> t "::" <+> pp d ty <> t";") $+$
foldr1 ($+$) (map (\ cl -> ppClause d 0 [ppVarId d i] cl <> t";") cs)
ppValueSign d i vs ty cs =
(ppVarId d i <+> t ":: /\\" <> sep (map (pPrintPrec d (fromIntegral maxPrec)) vs) <> t"." <> pp d ty <> t";") $+$
foldr1 ($+$) (map (\ cl -> ppClause d 0 [ppVarId d i] cl <> t";") cs)
ppClause :: PDetail -> Rational -> [Doc] -> CClause -> Doc
ppClause d _p xs (CClause ps mqs e) =
sep [sep (xs ++ map (pPrintPrec d (fromIntegral maxPrec)) ps) <> ppQuals d mqs <+> t "= ",
nest 4 (pp d e)]
-- Definition, local or global
data CDef
= CDef Id CQType [CClause] -- before type checking
| CDefT Id [TyVar] CQType [CClause] -- after type checking, with type variables from the CQType
deriving (Eq, Ord, Show)
instance Pretty CDef where
pPrintPrec d _p (CDef i ty cs) = ppValueSign d i [] ty cs
pPrintPrec d _p (CDefT i vs ty cs) = ppValueSign d i vs ty cs
instance HasPosition CDef where
getPosition (CDef i _ _) = getPosition i
getPosition (CDefT i _ _ _) = getPosition i
-- Definition clause
-- each interface's definitions (within the module) correspond to one of these
data CClause
= CClause [CPat] -- arguments (including patterns)
[CQual] -- qualifier on the args
CExpr -- the body
deriving (Eq, Ord, Show)
instance Pretty CClause where
pPrintPrec d p cl = ppClause d p [] cl
instance HasPosition CClause where
getPosition (CClause ps qs e) = getPosition (ps, qs, e)
-- Pattern matching
data CQual
= CQGen CType CPat CExpr
| CQFilter CExpr
deriving (Eq, Ord, Show)
instance Pretty CQual where
pPrintPrec d _p (CQGen _ pa e) = pp d pa <+> t "<-" <+> pp d e
pPrintPrec d _p (CQFilter e) = pp d e
instance HasPosition CQual where
getPosition (CQGen _ p _) = getPosition p
getPosition (CQFilter e) = getPosition e
ppQuals :: PDetail -> [CQual] -> Doc
ppQuals _d [] = t""
ppQuals d qs = t" when" <+> sepList (map (pp d) qs) (t",")
ppOSummands :: PDetail -> [COriginalSummand] -> Doc
ppOSummands d cs = sepList (map (nest 2 . ppOCon) cs) (t" |")
where ppOCon summand =
let pp_name = case (cos_names summand) of
[cn] -> ppConId d cn
cns -> text "(" <>
sepList (map (ppConId d) cns) (text ",") <>
text ")"
pp_args = map (pPrintPrec d (fromIntegral maxPrec)) (cos_arg_types summand)
pp_encoding =
case cos_tag_encoding summand of
Nothing -> empty
Just num ->
text "{-# tag " <+> pPrintPrec d 0 num <+> text "#-}"
in sep (pp_name : pp_encoding : pp_args)
ppSummands :: PDetail -> [CInternalSummand] -> Doc
ppSummands d cs = sepList (map (nest 2 . ppCon) cs) (t" |")
where ppCon summand =
let pp_name = case (cis_names summand) of
[cn] -> ppConId d cn
cns -> text "(" <>
sepList (map (ppConId d) cns) (text ",") <>
text ")"
pp_arg = pPrintPrec d (fromIntegral maxPrec) (cis_arg_type summand)
in sep [pp_name, pp_arg]
data CPat
= CPCon Id [CPat]
-- Either a struct type or a constructor with named fields.
-- The 'Maybe Bool' argument can indicate if it is specifically
-- one or the other (True for struct), otherwise the typechecker
-- will attempt to determine which is intended.
| CPstruct (Maybe Bool) Id [(Id, CPat)]
| CPVar Id
| CPAs Id CPat
| CPAny Position
| CPLit CLiteral
-- position, base, [(length, value or don't-care)] starting from MSB
-- note that length is length in digits, not bits!
| CPMixedLit Position Integer [(Integer, Maybe Integer)]
-- used before operator parsing
| CPOper [CPOp]
-- generated by deriving code
| CPCon1 Id Id CPat -- first Id is type of constructor
-- After type checking
| CPConTs Id Id [CType] [CPat]
deriving (Eq, Ord, Show)
instance Pretty CPat where
pPrintPrec d p (CPVar a) = pPrintPrec d p a
pPrintPrec d p (CPCon i as) = pparen (p>(fromIntegral maxPrec-1)) $ sep (ppConId d i : map (pPrintPrec d (fromIntegral maxPrec)) as)
pPrintPrec _d _p (CPstruct _ tyc []) | tyc == idPrimUnit = text "()"
pPrintPrec d _p (CPstruct _ tyc [(_, fst'), (_, snd')]) | tyc == idPrimPair =
pparen True (pPrintPrec d 0 fst' <> t"," <+> pPrintPrec d 0 snd')
pPrintPrec d p (CPstruct _ i fs) = pparen (p>(fromIntegral maxPrec-1)) $ ppConId d i <+> t "{" <+> sep (map ppField' fs ++ [t"}"])
where ppField' (i', CPVar i'') | i' == i'' = ppVarId d i' <> t";"
ppField' (i', p') = ppVarId d i' <+> t "=" <+> pp d p' <> t";"
pPrintPrec d _p (CPAs a pp') = pPrintPrec d (fromIntegral maxPrec) a <> t"@" <> pPrintPrec d (fromIntegral maxPrec) pp'
pPrintPrec _d _p (CPAny _) = text "_"
pPrintPrec d p (CPLit l) = pPrintPrec d p l
pPrintPrec _d _p (CPMixedLit _ base ps) =
let digitBits = log2 base
f (len, Just val) = integerFormat (len `div` digitBits) base val
f (len, Nothing) = L.genericReplicate (len `div` digitBits) '?'
pref 2 = "0b"
pref 8 = "0o"
pref 10 = ""
pref 16 = "0x"
pref x = error ("bad radix to CPMixedLit: " ++ show x)
in text (pref base ++ concatMap f ps)
pPrintPrec d p (CPOper ops) = pparen (p > fromIntegral maxPrec-1) (sep (map (pPrintPrec d (fromIntegral maxPrec-1)) ops))
pPrintPrec d p (CPCon1 _ i a) = pPrintPrec d p (CPCon i [a])
----
pPrintPrec d p (CPConTs _ i ts as) = pparen (p>(fromIntegral maxPrec-1)) $ sep (ppConId d i : map ppApArg ts ++ map (pPrintPrec d (fromIntegral maxPrec)) as)
where ppApArg ty = t"\183" <> pPrintPrec d (fromIntegral maxPrec) ty
instance HasPosition CPat where
getPosition (CPCon c _) = getPosition c
getPosition (CPstruct _ c _) = getPosition c
getPosition (CPVar i) = getPosition i
getPosition (CPAs i _) = getPosition i
getPosition (CPAny p) = p
getPosition (CPLit l) = getPosition l
getPosition (CPMixedLit p _ _) = p
getPosition (CPOper ps) = getPosition ps
getPosition (CPCon1 _ c _) = getPosition c
getPosition (CPConTs _ c _ _) = getPosition c
data CPOp
= CPRand CPat
| CPRator Int Id
deriving (Eq, Ord, Show)
instance Pretty CPOp where
pPrintPrec d _ (CPRand p) = pp d p
pPrintPrec d _ (CPRator _ i) = ppInfix d i
instance HasPosition CPOp where
getPosition (CPRand p) = getPosition p
getPosition (CPRator _ i) = getPosition i
ppInfix :: PDetail -> Id -> Doc
ppInfix _d i =
--case getIdString i of
--s@(c:_) | isIdChar c -> t"`" <> t s <> t"`"
--s -> t s
let p = getIdQual i
b = getIdBase i
in if (p==fsEmpty) then
(case getFString b of
s@(c:_) | isIdChar c -> t"`" <> t s <> t"`"
s -> t s)
else (t"`" <> t (getFString p) <> t "." <>
(case getFString b of
s@(c:_) | isIdChar c -> t s
s -> t "(" <> t s <> t")") <> t"`")
pp :: (Pretty a) => PDetail -> a -> Doc
pp d x = pPrintPrec d 0 x
t :: String -> Doc
t s = text s
newtype CInclude
= CInclude String
deriving (Eq, Ord, Show)
instance Pretty CInclude where
pPrintPrec d p (CInclude s) = pPrintPrec d p s
--------
-- Utilities
cApply :: Int -> CExpr -> [CExpr] -> CExpr
cApply _n e [] = e
cApply _n (CCon i es) es' = CCon i (es ++ es')
cApply _n (CConT t' i es) es' = CConT t' i (es ++ es')
cApply _n (CApply e es) es' = CApply e (es ++ es')
cApply _n (CTaskApply e es) es' = CTaskApply e (es ++ es')
cApply _n e as = CApply e as
cVApply :: Id -> [CExpr] -> CExpr
cVApply i _es | isTaskName (getIdBaseString i) =
error $ "cVApply to " ++ (show i) ++ "\n"
cVApply i es = cApply 2 (CVar i) es
-- tasks start with $ followed by a letter
isTaskName :: String -> Bool
isTaskName ('$':c:_) = isAlpha c
isTaskName _ = False
getName :: CDefn -> Either Position Id
getName (CValue i _) = Right i
getName (CValueSign (CDef i _ _)) = Right i
getName (CValueSign (CDefT i _ _ _)) = Right i
getName (Cprimitive i _) = Right i
getName (CprimType i) = Right $ iKName i
getName (CPragma pr) = Left $ getPosition pr
getName (Cforeign { cforg_name = i }) = Right i
getName (Ctype i _ _) = Right $ iKName i
getName (Cdata { cd_name = name }) = Right $ iKName name
getName (Cstruct _ _ i _ _ _) = Right $ iKName i
getName (Cclass _ _ i _ _ _) = Right $ iKName i
getName (Cinstance qt _) = Left $ getPosition qt
getName (CItype i _ _) = Right $ iKName i
getName (CIclass _ _ i _ _ _) = Right $ iKName i
getName (CIinstance _ qt) = Left $ getPosition qt
getName (CIValueSign i _) = Right i
iKName :: IdK -> Id
iKName (IdK i) = i
iKName (IdKind i _) = i
iKName (IdPKind i _) = i