module Language.VHDL.AST.Ppr () where
import Language.VHDL.Ppr
import Language.VHDL.AST
import Text.PrettyPrint.HughesPJ hiding (Mode)
nestVal :: Int
nestVal = 5
instance Ppr a => Ppr (Maybe a) where
ppr (Just a) = ppr a
ppr Nothing = empty
instance (Ppr a, Ppr b) => Ppr (a,b) where
ppr (a,b) = ppr a <+> ppr b
instance Ppr VHDLId where
ppr = text.fromVHDLId
instance Ppr DesignFile where
ppr (DesignFile cx lx) = vNSpaces spaces (ppr_list ($+$) cx)
(ppr_list (vNSpaces spaces) lx) $+$
vSpace
where spaces = 2
instance Ppr ContextItem where
ppr (Library id) = text "library" <+> ppr id <> semi
ppr (Use name) = text "use" <+> ppr name <> semi
instance Ppr LibraryUnit where
ppr (LUEntity entityDec) = ppr entityDec
ppr (LUArch archBody) = ppr archBody
ppr (LUPackageDec packageDec) = ppr packageDec
ppr (LUPackageBody packageBody) = ppr packageBody
instance Ppr EntityDec where
ppr (EntityDec id ifaceSigDecs) =
text "entity" <+> idDoc <+> text "is" $+$
nest nestVal (ppr ifaceSigDecs) $+$
text "end entity" <+> idDoc <> semi
where idDoc = ppr id
instance Ppr [IfaceSigDec] where
ppr [] = empty
ppr decs = text "port" <+> (parens (ppr_list vSemi decs) <> semi)
instance Ppr IfaceSigDec where
ppr (IfaceSigDec id mode typemark) =
ppr id <+> colon <+> ppr mode <+> ppr typemark
instance Ppr Mode where
ppr In = text "in"
ppr Out = text "out"
instance Ppr ArchBody where
ppr (ArchBody id enName decs conSms) =
text "architecture" <+> idDoc <+> text "of" <+> ppr enName <+> text "is" $+$
nest nestVal (ppr decs) $+$
text "begin" $+$
nest nestVal (ppr_list (vNSpaces 1) conSms) $+$
text "end architecture" <+> idDoc <> semi
where idDoc = ppr id
instance Ppr PackageDec where
ppr (PackageDec id decs) =
text "package" <+> idDoc <+> text "is" $+$
vSpace $++$
nest nestVal (ppr_list (vNSpaces 1) decs) $++$
vSpace $+$
text "end package" <+> idDoc <> semi
where idDoc = ppr id
instance Ppr PackageDecItem where
ppr (PDITD typeDec) = ppr typeDec
ppr (PDISD subtypeDec) = ppr subtypeDec
ppr (PDISS subProgSpec) = ppr subProgSpec <> semi
instance Ppr PackageBody where
ppr (PackageBody id decs) =
text "package body" <+> idDoc <+> text "is" $+$
vSpace $++$
nest nestVal (ppr_list (vNSpaces 1) decs) $++$
vSpace $+$
text "end package body" <+> idDoc <> semi
where idDoc = ppr id
instance Ppr SubtypeDec where
ppr (SubtypeDec id si) = text "subtype" <+> ppr id <+> text "is" <+> ppr si <> semi
instance Ppr SubtypeIn where
ppr (SubtypeIn tm mCons) = ppr tm <+> (ppr mCons)
instance Ppr SubtypeConstraint where
ppr (ConstraintIndex dr) = ppr dr
ppr (ConstraintRange dr) = ppr dr
instance Ppr Range where
ppr (AttribRange an) = ppr an
ppr (SubTypeRange exp1 exp2) = text "range" <+> ppr exp1 <+> text "to" <+> ppr exp2
ppr (ToRange exp1 exp2) = ppr exp1 <+> text "to" <+> ppr exp2
ppr (DownRange exp1 exp2) = ppr exp1 <+> text "downto" <+> ppr exp2
instance Ppr IndexConstraint where
ppr (IndexConstraint dr) = parens (ppr_list hComma dr)
instance Ppr TypeDec where
ppr (TypeDec id typeDef) =
hang (text "type" <+> ppr id <+> text "is") nestVal (ppr typeDef <> semi)
instance Ppr TypeDef where
ppr (TDA arrayTD) = ppr arrayTD
ppr (TDR recordTD) = ppr recordTD
ppr (TDE enumTD) = ppr enumTD
instance Ppr ArrayTypeDef where
ppr (UnconsArrayDef unconsIxs elemsTM) =
text "array" <+> parens (ppr_list hComma $ map pprUnconsRange unconsIxs) <+>
text "of" <+> ppr elemsTM
where pprUnconsRange tm = ppr tm <+> text "range <>"
ppr (ConsArrayDef consIxs elemsTM) =
text "array" <+> ppr consIxs <+> text "of" <+> ppr elemsTM
instance Ppr RecordTypeDef where
ppr (RecordTypeDef elementDecs) =
text "record" <+> (ppr_list ($+$) elementDecs) $+$
text "end record"
instance Ppr ElementDec where
ppr (ElementDec id tm) = ppr id <+> colon <+> ppr tm <> semi
instance Ppr EnumTypeDef where
ppr (EnumTypeDef ids) = lparen <> ppr_list hComma ids <> rparen
instance Ppr VHDLName where
ppr (NSimple simple) = ppr simple
ppr (NSelected selected) = ppr selected
ppr (NIndexed indexed) = ppr indexed
ppr (NSlice slice) = ppr slice
ppr (NAttribute attrib) = ppr attrib
instance Ppr SelectedName where
ppr (prefix :.: suffix) = ppr prefix <> dot <> ppr suffix
instance Ppr Suffix where
ppr (SSimple simpleName) = ppr simpleName
ppr All = text "all"
instance Ppr IndexedName where
ppr (IndexedName prefix indexList) =
ppr prefix <> parens ( ppr_list hComma indexList )
instance Ppr SliceName where
ppr (SliceName prefix discreteRange) = ppr prefix <> parens (ppr discreteRange)
instance Ppr AttribName where
ppr (AttribName prefix simpleName mExpr) =
ppr prefix <> char '\'' <> ppr simpleName <> parensNonEmpty (ppr mExpr)
instance Ppr [BlockDecItem] where
ppr = ppr_list ($+$)
instance Ppr BlockDecItem where
ppr (BDISPB subProgBody) = ppr subProgBody
ppr (BDISD sigDec) = ppr sigDec
instance Ppr SubProgBody where
ppr (SubProgBody subProgSpec decItems statements) =
ppr subProgSpec <+> text "is" $+$
nest nestVal (ppr_list ($+$) decItems) $+$
text "begin" $+$
nest nestVal (ppr_list ($+$) statements) $+$
text "end" <> semi
instance Ppr SubProgDecItem where
ppr (SPVD vd) = ppr vd
ppr (SPCD cd) = ppr cd
ppr (SPSB sb) = ppr sb
instance Ppr VarDec where
ppr (VarDec id st mExpr) =
text "variable" <+> ppr id <+> colon <+> ppr st <+>
(text ":=" <++> ppr mExpr) <> semi
instance Ppr ConstDec where
ppr (ConstDec id st mExpr) =
text "constant" <+> ppr id <+> colon <+> ppr st <+>
(text ":=" <++> ppr mExpr) <> semi
instance Ppr SubProgSpec where
ppr (Function name decList returnType) =
text "function" <+> ppr name <+> (parensNonEmpty (ppr_decs decList) $+$
text "return" <+> ppr returnType)
where ppr_decs ds = ppr_list vSemi ds
instance Ppr IfaceVarDec where
ppr (IfaceVarDec id typemark) = ppr id <+> colon <+> ppr typemark
instance Ppr SeqSm where
ppr (IfSm cond sms elseIfs maybeElse) =
text "if" <+> ppr cond <+> text "then" $+$
nest nestVal (ppr sms) $+$
ppr elseIfs $+$
ppr maybeElse $+$
text "end if" <> semi
ppr (CaseSm patern alts) = text "case" <+> ppr patern <+> text "is" $+$
nest nestVal (ppr alts) $+$
text "end case" <> semi
ppr (ReturnSm maybeExpr) = text "return" <+> ppr maybeExpr <> semi
ppr (ForSM id dr sms) =
text "for" <+> ppr id <+> text "in" <+> ppr dr <+> text "loop" $+$
nest nestVal (ppr sms) $+$
text "end loop" <> semi
ppr (target := orig) = ppr target <+> text ":=" <+> ppr orig <> semi
ppr (WaitFor expr) = text "wait for" <+> ppr expr <> semi
ppr (targ `SigAssign` orig) = ppr targ <+> text "<=" <+> ppr orig <> semi
ppr (ProcCall name assocs) =
ppr name <> parensNonEmpty (commaSep assocs) <> semi
instance Ppr [SeqSm] where
ppr = ppr_list ($+$)
instance Ppr [ElseIf] where
ppr = ppr_list ($+$)
instance Ppr ElseIf where
ppr (ElseIf cond sms) = text "elsif" <+> ppr cond <+> text "then" $+$
nest nestVal (ppr sms)
instance Ppr Else where
ppr (Else sms) = text "else" $+$
nest nestVal (ppr sms)
instance Ppr [CaseSmAlt] where
ppr = ppr_list ($+$)
instance Ppr Choice where
ppr (ChoiceE expr) = ppr expr
ppr Others = text "others"
instance Ppr CaseSmAlt where
ppr (CaseSmAlt alts sms) =
text "when" <+> ppr_list joinAlts alts <+> text "=>" $+$
nest nestVal (ppr sms)
where joinAlts a1 a2 = a1 <+> char '|' <+> a2
instance Ppr SigDec where
ppr (SigDec id typemark mInit) =
text "signal" <+> ppr id <+> colon <+> ppr typemark <+>
(text ":=" <++> ppr mInit) <> semi
instance Ppr [ConcSm] where
ppr = ppr_list ($$)
instance Ppr ConcSm where
ppr (CSBSm blockSm) = ppr blockSm
ppr (CSSASm conSigAssignSm) = ppr conSigAssignSm
ppr (CSISm compInsSm) = ppr compInsSm
ppr (CSPSm procSm) = ppr procSm
ppr (CSGSm generateSm) = ppr generateSm
instance Ppr BlockSm where
ppr (BlockSm label ifaceSigDecs pMapAspect blockDecItems concSms) =
labelDoc <+> colon <+> text "block" $+$
nest nestVal (ppr ifaceSigDecs) $+$
nest nestVal (ppr pMapAspect) <++> semi $+$
nest nestVal (ppr blockDecItems) $+$
text "begin" $+$
nest nestVal (ppr concSms) $+$
text "end block" <+> labelDoc <> semi
where labelDoc = ppr label
instance Ppr GenerateSm where
ppr (GenerateSm label generation_scheme blockDecItems concSms) =
labelDoc <+> colon <+> (ppr generation_scheme) <+> text "generate" $+$
nest nestVal (ppr blockDecItems) $+$
text "begin" $+$
nest nestVal (ppr concSms) $+$
text "end generate" <+> labelDoc <> semi
where labelDoc = ppr label
instance Ppr GenSm where
ppr (ForGn id dr) = text "for" <+> ppr id <+> text "in" <+> ppr dr
ppr (IfGn cond) = text "if" <+> ppr cond
instance Ppr PMapAspect where
ppr (PMapAspect []) = empty
ppr (PMapAspect assocs) = text "port map" $$
(nest identL $ parens (ppr_list vComma assocs))
where identL = length "port map "
instance Ppr AssocElem where
ppr (formalPart :=>: actualPart) = formalPartDoc <+> ppr actualPart
where formalPartDoc = maybe empty (\fp -> ppr fp <+> text "=>") formalPart
instance Ppr ActualDesig where
ppr (ADName name) = ppr name
ppr (ADExpr expr) = ppr expr
ppr Open = text "open"
instance Ppr ConSigAssignSm where
ppr (target :<==: cWforms) = ppr target <+> text "<=" <+> (ppr cWforms <> semi)
instance Ppr ConWforms where
ppr (ConWforms whenElses wform lastElse) = ppr_list ($+$) whenElses $+$
ppr wform <+> ppr lastElse
instance Ppr WhenElse where
ppr (WhenElse wform expr) = ppr wform <+> text "when" <+>
ppr expr <+> text "else"
instance Ppr When where
ppr (When cond) = text "when" <+> ppr cond
instance Ppr Wform where
ppr (Wform elems) = ppr_list vComma elems
ppr Unaffected = text "unaffected"
instance Ppr WformElem where
ppr (WformElem exp mAfter) = ppr exp <+> (text "after" <++> ppr mAfter)
instance Ppr CompInsSm where
ppr (CompInsSm label insUnit assocElems) =
ppr label <+> colon <+> (ppr insUnit $+$
nest nestVal (ppr assocElems) <> semi)
instance Ppr ProcSm where
ppr (ProcSm label sensl seqSms) =
ppr label <+> colon <+> text "process" <+>
parensNonEmpty (ppr_list hComma sensl) $+$
text "begin" $+$
nest nestVal (ppr seqSms) $+$
text "end process" <+> labelDoc <> semi
where labelDoc = ppr label
instance Ppr InsUnit where
ppr (IUEntity name) = text "entity" <+> ppr name
instance Ppr Expr where
ppr = pprExprPrec 0 ""
pprExprPrecInfix :: Int
-> String
-> Int
-> Expr
-> String
-> Expr
-> Doc
pprExprPrecInfix ac encop curr lhs op rhs =
parensIf (ac>curr || (ac == curr && not skipParenSameLevel)) $
sep [pprExprPrec curr op lhs <+> text op, pprExprPrec (curr+1) op rhs]
where skipParenSameLevel = curr == plusPrec || curr == multPrec ||
(encop == op && op `elem` ["and","or","xor","xnor"])
pprExprPrecPrefix :: Int
-> Int
-> String
-> Expr
-> Doc
pprExprPrecPrefix ac curr op arg = parensIf (ac>curr) $
text op <+> pprExprPrec (curr+1) op arg
pprExprPrec :: Int
-> String
-> Expr
-> Doc
pprExprPrec p e (And e1 e2) = pprExprPrecInfix p e logicalPrec e1 "and" e2
pprExprPrec p e (Or e1 e2) = pprExprPrecInfix p e logicalPrec e1 "or" e2
pprExprPrec p e (Xor e1 e2) = pprExprPrecInfix p e logicalPrec e1 "xor" e2
pprExprPrec p e (Nand e1 e2) = pprExprPrecInfix p e logicalPrec e1 "nand" e2
pprExprPrec p e (Nor e1 e2) = pprExprPrecInfix p e logicalPrec e1 "nor" e2
pprExprPrec p e (Xnor e1 e2) = pprExprPrecInfix p e logicalPrec e1 "xnor" e2
pprExprPrec p e (e1 :=: e2) = pprExprPrecInfix p e relationalPrec e1 "=" e2
pprExprPrec p e (e1 :/=: e2) = pprExprPrecInfix p e relationalPrec e1 "/=" e2
pprExprPrec p e (e1 :<: e2) = pprExprPrecInfix p e relationalPrec e1 "<" e2
pprExprPrec p e (e1 :<=: e2) = pprExprPrecInfix p e relationalPrec e1 "<=" e2
pprExprPrec p e (e1 :>: e2) = pprExprPrecInfix p e relationalPrec e1 ">" e2
pprExprPrec p e (e1 :>=: e2) = pprExprPrecInfix p e relationalPrec e1 ">=" e2
pprExprPrec p e (Sll e1 e2) = pprExprPrecInfix p e shiftPrec e1 "sll" e2
pprExprPrec p e (Srl e1 e2) = pprExprPrecInfix p e shiftPrec e1 "srl" e2
pprExprPrec p e (Sla e1 e2) = pprExprPrecInfix p e shiftPrec e1 "sla" e2
pprExprPrec p e (Sra e1 e2) = pprExprPrecInfix p e shiftPrec e1 "sra" e2
pprExprPrec p e (Rol e1 e2) = pprExprPrecInfix p e shiftPrec e1 "rol" e2
pprExprPrec p e (Ror e1 e2) = pprExprPrecInfix p e shiftPrec e1 "ror" e2
pprExprPrec p e (e1 :+: e2) = pprExprPrecInfix p e plusPrec e1 "+" e2
pprExprPrec p e (e1 :-: e2) = pprExprPrecInfix p e plusPrec e1 "-" e2
pprExprPrec p e (e1 :&: e2) = pprExprPrecInfix p e plusPrec e1 "&" e2
pprExprPrec p _ (Neg e) = pprExprPrecPrefix p signPrec "-" e
pprExprPrec p _ (Pos e) = pprExprPrecPrefix p signPrec "+" e
pprExprPrec p e (e1 :*: e2) = pprExprPrecInfix p e multPrec e1 "*" e2
pprExprPrec p e (e1 :/: e2) = pprExprPrecInfix p e multPrec e1 "/" e2
pprExprPrec p e (Mod e1 e2) = pprExprPrecInfix p e multPrec e1 "mod" e2
pprExprPrec p e (Rem e1 e2) = pprExprPrecInfix p e multPrec e1 "rem" e2
pprExprPrec p e (e1 :**: e2) = pprExprPrecInfix p e miscPrec e1 "**" e2
pprExprPrec p _ (Abs e) = pprExprPrecPrefix p signPrec "abs" e
pprExprPrec p _ (Not e) = pprExprPrecPrefix p signPrec "not" e
pprExprPrec _ _ (PrimName name) = ppr name
pprExprPrec _ _ (PrimLit lit) = text lit
pprExprPrec _ _ (PrimFCall fCall) = ppr fCall
pprExprPrec _ _ (Aggregate assocs) = parens (ppr_list hComma assocs)
instance Ppr ElemAssoc where
ppr (ElemAssoc mChoice expr) = (ppr mChoice <++> text "=>") <+> ppr expr
instance Ppr FCall where
ppr (FCall name assocs) =
ppr name <> parensNonEmpty (commaSep assocs)