module Language.VHDL.Pretty (Pretty (..)) where
import Language.VHDL.Syntax
import Text.PrettyPrint hiding (Mode)
class Pretty a
where
pp :: a -> Doc
instance Pretty a => Pretty [a]
where
pp = hsep . map pp
instance Pretty a => Pretty (Maybe a)
where
pp = maybe empty pp
instance Pretty AbstractLiteral where pp = error "missing: AbstractLiteral"
instance Pretty AccessTypeDefinition where
pp (AccessTypeDefinition s) = text "ACCESS" <+> pp s
instance Pretty ActualDesignator where
pp (ADExpression e) = pp e
pp (ADSignal n) = pp n
pp (ADVariable n) = pp n
pp (ADFile n) = pp n
pp (ADOpen) = text "OPEN"
instance Pretty ActualPart where
pp (APDesignator a) = pp a
pp (APFunction f a) = pp f <+> parens (pp a)
pp (APType t a) = pp t <+> parens (pp a)
instance Pretty AddingOperator where
pp (Plus) = char '+'
pp (Minus) = char '-'
pp (Concat) = char '&'
instance Pretty Aggregate where
pp (Aggregate es) = parens (commaSep $ map pp es)
instance Pretty AliasDeclaration where
pp (AliasDeclaration a sub n sig) =
text "ALIAS" <+> pp a
<+> cond (colon <+>) sub
<+> text "IS" <+> pp n
<+> cond id sig <+> semi
instance Pretty AliasDesignator where
pp (ADIdentifier i) = pp i
pp (ADCharacter c) = pp c
pp (ADOperator o) = pp o
instance Pretty Allocator where
pp (AllocSub s) = text "NEW" <+> pp s
pp (AllocQual q) = text "NEW" <+> pp q
instance Pretty ArchitectureBody where
pp (ArchitectureBody i n d s) =
vcat [ header
, indent (vpp d)
, text "BEGIN"
, indent (vpp s)
, footer
]
where
header = text "ARCHITECTURE" <+> pp i
<+> text "OF" <+> pp n
<+> text "IS"
footer = text "END ARCHITECTURE" <+> pp i <+> semi
instance Pretty ArrayTypeDefinition where
pp (ArrU u) = pp u
pp (ArrC c) = pp c
instance Pretty Assertion where
pp (Assertion c r s) = vcat [text "ASSERT" <+> pp c, report, severity]
where
report = indent $ cond (text "REPORT" <+>) r
severity = indent $ cond (text "SEVERITY" <+>) s
instance Pretty AssertionStatement where
pp (AssertionStatement l a) = label l <+> pp a <+> semi
instance Pretty AssociationElement where
pp (AssociationElement f a) = condR (text "=>") f <+> pp a
instance Pretty AssociationList where
pp (AssociationList as) = commaSep $ map pp as
instance Pretty AttributeDeclaration where
pp (AttributeDeclaration i t) = text "ATTRIBUTE" <+> pp i <+> colon <+> pp t <+> semi
instance Pretty AttributeName where
pp (AttributeName p s d e) = pp p <+> cond id s <+> char '\'' <+> pp d <+> cond parens e
instance Pretty AttributeSpecification where
pp (AttributeSpecification d s e) =
text "ATTRIBUTE" <+> pp d
<+> text "OF" <+> pp s
<+> text "IS" <+> pp e <+> semi
instance Pretty Base where pp = error "missing: Base"
instance Pretty BaseSpecifier where pp = error "missing: BaseSpecifier"
instance Pretty BaseUnitDeclaration where pp = error "missing: BaseUnitDeclaration"
instance Pretty BasedInteger where pp = error "missing: BasedInteger"
instance Pretty BasedLiteral where pp = error "missing: BasedLiteral"
instance Pretty BasicCharacter where pp = error "missing: BasicCharacter"
instance Pretty BasicGraphicCharacter where pp = error "missing: BasicGraphicCharacter"
instance Pretty BasicIdentifier where pp = error "missing: BasicIdentifier"
instance Pretty BindingIndication where
pp (BindingIndication e g p) =
vcat [condR (text "USE") e, cond id g, cond id p]
instance Pretty BitStringLiteral where pp = error "missing: BitStringLiteral"
instance Pretty BitValue where pp = error "missing: BitValue"
instance Pretty BlockConfiguration where
pp (BlockConfiguration s u c) =
vcat [ text "FOR" <+> pp s
, indent (pp u)
, indent (pp c)
, text "END FOR" <+> semi]
instance Pretty BlockDeclarativeItem where
pp (BDISubprogDecl d) = pp d
pp (BDISubprogBody b) = pp b
pp (BDIType t) = pp t
pp (BDISubtype s) = pp s
pp (BDIConstant c) = pp c
pp (BDISignal s) = pp s
pp (BDIShared v) = pp v
pp (BDIFile f) = pp f
pp (BDIAlias a) = pp a
pp (BDIComp c) = pp c
pp (BDIAttrDecl a) = pp a
pp (BDIAttrSepc a) = pp a
pp (BDIConfigSepc c) = pp c
pp (BDIDisconSpec d) = pp d
pp (BDIUseClause u) = pp u
pp (BDIGroupTemp g) = pp g
pp (BDIGroup g) = pp g
instance Pretty BlockHeader where
pp (BlockHeader p g) =
vcat [go p, go g]
where
go :: (Pretty a, Pretty b) => Maybe (a, Maybe b) -> Doc
go (Nothing) = empty
go (Just (a, mb)) = pp a $+$ cond indent mb
instance Pretty BlockSpecification where
pp (BSArch n) = pp n
pp (BSBlock l) = pp l
pp (BSGen l) = pp l
instance Pretty BlockStatement where
pp (BlockStatement l g h d s) =
pp l <+> colon `hangs` vcat [header, body, footer]
where
header = text "BLOCK" <+> cond parens g <+> text "IS" `hangs` (pp h $$ pp d)
body = text "BEGIN" `hangs` (pp s)
footer = text "END BLOCK" <+> pp l
instance Pretty CaseStatement where
pp (CaseStatement l e cs) =
labels l $ vcat [header, body, footer]
where
header = text "CASE" <+> pp e <+> text "IS"
body = indent $ vcat $ map pp cs
footer = text "END CASE" <+> cond id l
instance Pretty CaseStatementAlternative where
pp (CaseStatementAlternative c ss) =
text "WHEN" <+> pp c <+> text "=>" `hangs` pp ss
instance Pretty CharacterLiteral where
pp (CLit c) = char c
instance Pretty Choice where
pp (ChoiceSimple s) = pp s
pp (ChoiceRange r) = pp r
pp (ChoiceName n) = pp n
pp (ChoiceOthers) = text "OTHERS"
instance Pretty Choices where
pp (Choices cs) = pipeSep $ map pp cs
instance Pretty ComponentConfiguration where
pp (ComponentConfiguration s i c) =
vcat [ text "FOR" <+> pp s
, indent $ vcat
[ condR semi i
, cond id c
]
, text "END FOR" <+> semi
]
instance Pretty ComponentDeclaration where
pp (ComponentDeclaration i g p s) =
vcat [ text "COMPONENT" <+> pp i <+> text "IS"
, indent $ vcat
[ cond id g
, cond id p
]
, text "END COMPONENT" <+> cond id s <+> semi
]
instance Pretty ComponentInstantiationStatement where
pp (ComponentInstantiationStatement l u g p) =
pp l <+> colon `hangs` (pp u `hangs` vcat [cond id g, cond id p])
instance Pretty ComponentSpecification where
pp (ComponentSpecification ls n) = pp ls <+> colon <+> pp n
instance Pretty CompositeTypeDefinition where
pp (CTDArray at) = pp at
pp (CTDRecord rt) = pp rt
instance Pretty ConcurrentAssertionStatement where
pp (ConcurrentAssertionStatement l p a) = postponed l p a
instance Pretty ConcurrentProcedureCallStatement where
pp (ConcurrentProcedureCallStatement l p a) = postponed l p a
instance Pretty ConcurrentSignalAssignmentStatement where
pp (CSASCond l p a) = postponed l p a
pp (CSASSelect l p a) = postponed l p a
instance Pretty ConcurrentStatement where
pp (ConBlock b) = pp b
pp (ConProcess p) = pp p
pp (ConProcCall c) = pp c
pp (ConAssertion a) = pp a
pp (ConSignalAss s) = pp s
pp (ConComponent c) = pp c
pp (ConGenerate g) = pp g
instance Pretty ConditionClause where
pp (ConditionClause e) = text "UNTIL" <+> pp e
instance Pretty ConditionalSignalAssignment where
pp (ConditionalSignalAssignment t o w) = pp t <+> text "<=" <+> pp o <+> pp w <+> semi
instance Pretty ConditionalWaveforms where
pp (ConditionalWaveforms ws (w, c)) =
vcat ws' $$ pp w <+> condL (text "WHEN") c
where
ws' = map (\(w, c) -> pp w <+> text "WHEN" <+> pp c <+> text "ELSE") ws
instance Pretty ConfigurationDeclaration where
pp (ConfigurationDeclaration i n d b) =
vcat [ text "CONFIGURATION" <+> pp i <+> text "OF" <+> pp n <+> text "IS"
, indent $ vcat
[ pp d
, pp b
]
, text "END CONFIGURATION" <+> pp i
]
instance Pretty ConfigurationDeclarativeItem where
pp (CDIUse u) = pp u
pp (CDIAttrSpec a) = pp a
pp (CDIGroup g) = pp g
instance Pretty ConfigurationItem where
pp (CIBlock b) = pp b
pp (CIComp c) = pp c
instance Pretty ConfigurationSpecification where
pp (ConfigurationSpecification s i) = text "FOR" <+> pp s <+> pp i <+> semi
instance Pretty ConstantDeclaration where
pp (ConstantDeclaration is s e) =
text "CONSTANT" <+> commaSep (fmap pp is) <+> colon <+> pp s <+> condL (text ":=") e
instance Pretty ConstrainedArrayDefinition where
pp (ConstrainedArrayDefinition i s) = text "ARRAY" <+> pp i <+> text "OF" <+> pp s
instance Pretty Constraint where
pp (CRange r) = pp r
pp (CIndex i) = pp i
instance Pretty ContextItem where
pp (ContextLibrary l) = pp l
pp (ContextUse u) = pp u
instance Pretty DecimalLiteral where pp = error "missing: DecimalLiteral"
instance Pretty Declaration where
pp (DType t) = pp t
pp (DSubtype s) = pp s
pp (DObject o) = pp o
pp (DAlias a) = pp a
pp (DComponent c) = pp c
pp (DAttribute a) = pp a
pp (DGroupTemplate g) = pp g
pp (DGroup g) = pp g
pp (DEntity e) = pp e
pp (DConfiguration c) = pp c
pp (DSubprogram s) = pp s
pp (DPackage p) = pp p
instance Pretty DelayMechanism where
pp (DMechTransport) = text "TRANSPORT"
pp (DMechInertial e) = condL (text "REJECT") e <+> text "INERTIAL"
instance Pretty DesignUnit where
pp (DesignUnit primary secondary) = pp primary <+> pp secondary
instance Pretty Designator where
pp (DId i) = pp i
pp (DOp o) = pp o
instance Pretty Direction where
pp (To) = text "TO"
pp (DownTo) = text "DOWNTO"
instance Pretty DisconnectionSpecification where
pp (DisconnectionSpecification g e) =
text "DISCONNECT" <+> pp g <+> text "AFTER" <+> pp e <+> semi
instance Pretty DiscreteRange where
pp (DRSub s) = pp s
pp (DRRange r) = pp r
instance Pretty ElementAssociation where
pp (ElementAssociation c e) = condR (text "=>") c <+> pp e
instance Pretty ElementDeclaration where
pp (ElementDeclaration is s) = pp is <+> colon <+> pp s <+> semi
instance Pretty EntityAspect where
pp (EAEntity n i) = text "ENTITY" <+> pp n <+> cond parens i
pp (EAConfig n) = text "CONFIGURATION" <+> pp n
pp (EAOpen) = text "OPEN"
instance Pretty EntityClass where
pp ENTITY = text "ENTITY"
pp ARCHITECTURE = text "ARCHITECTURE"
pp CONFIGURATION = text "CONFIGURATION"
pp PROCEDURE = text "PROCEDURE"
pp FUNCTION = text "FUNCTION"
pp PACKAGE = text "PACKAGE"
pp TYPE = text "TYPE"
pp SUBTYPE = text "SUBTYPE"
pp CONSTANT = text "CONSTANT"
pp SIGNAL = text "SIGNAL"
pp VARIABLE = text "VARIABLE"
pp COMPONENT = text "COMPONENT"
pp LABEL = text "LABEL"
pp LITERAL = text "LITERAL"
pp UNITS = text "UNITS"
pp GROUP = text "GROUP"
pp FILE = text "FILE"
instance Pretty EntityClassEntry where
pp (EntityClassEntry c m) = pp c <+> when m (text "<>")
instance Pretty EntityDeclaration where
pp (EntityDeclaration i h d s) =
vcat [ text "ENTITY" <+> pp i <+> text "IS"
, indent $ vcat
[ pp h
, pp d
]
, flip cond s $ \ss ->
text "BEGIN" `hangs` ss
, text "END ENTITY" <+> pp i <+> semi
]
instance Pretty EntityDeclarativeItem where
pp (EDISubprogDecl s) = pp s
pp (EDISubprogBody b) = pp b
pp (EDIType t) = pp t
pp (EDISubtype s) = pp s
pp (EDIConstant c) = pp c
pp (EDISignal s) = pp s
pp (EDIShared s) = pp s
pp (EDIFile f) = pp f
pp (EDIAlias a) = pp a
pp (EDIAttrDecl a) = pp a
pp (EDIAttrSpec a) = pp a
pp (EDIDiscSpec d) = pp d
pp (EDIUseClause u) = pp u
pp (EDIGroupTemp g) = pp g
pp (EDIGroup g) = pp g
instance Pretty EntityDesignator where
pp (EntityDesignator t s) = pp t <+> cond id s
instance Pretty EntityHeader where
pp (EntityHeader g p) = vcat [cond indent g, cond indent p]
instance Pretty EntityNameList where
pp (ENLDesignators es) = commaSep $ fmap pp es
instance Pretty EntitySpecification where
pp (EntitySpecification ns c) = pp ns <+> colon <+> pp c
instance Pretty EntityStatement where
pp (ESConcAssert a) = pp a
pp (ESPassiveConc p) = pp p
pp (ESPassiveProc p) = pp p
instance Pretty EntityTag where
pp (ETName n) = pp n
pp (ETChar c) = pp c
pp (ETOp o) = pp o
instance Pretty EnumerationLiteral where
pp (EId i) = pp i
pp (EChar c) = pp c
instance Pretty EnumerationTypeDefinition where
pp (EnumerationTypeDefinition es) = commaSep $ fmap pp es
instance Pretty ExitStatement where
pp (ExitStatement l b c) =
label l <+> text "NEXT" <+> cond id b <+> condL (text "WHEN") c <+> semi
instance Pretty Exponent where pp = error "missing: Exponent"
instance Pretty Expression where
pp (EAnd rs) = textSep "AND" $ map pp rs
pp (EOr rs) = textSep "OR" $ map pp rs
pp (EXor rs) = textSep "XOR" $ map pp rs
pp (ENand r rs) = pp r <+> condL (text "NAND") rs
pp (ENor r rs) = pp r <+> condL (text "NOR") rs
pp (EXnor rs) = textSep "XNOR" $ map pp rs
instance Pretty ExtendedDigit where pp = error "missing: ExtendedDigit"
instance Pretty ExtendedIdentifier where pp = error "missing: ExtendedIdentifier"
instance Pretty Factor where
pp (FacPrim p mp) = pp p <+> condL (text "**") mp
pp (FacAbs p) = text "ABS" <+> pp p
pp (FacNot p) = text "NOT" <+> pp p
instance Pretty FileDeclaration where
pp (FileDeclaration is s o) =
text "FILE" <+> commaSep (fmap pp is)
<+> colon <+> pp s <+> cond id o <+> semi
instance Pretty FileOpenInformation where
pp (FileOpenInformation e n) = condL (text "OPEN") e <+> text "IS" <+> pp n
instance Pretty FileTypeDefinition where
pp (FileTypeDefinition t) = text "FILE OF" <+> pp t
instance Pretty FormalDesignator where
pp (FDGeneric n) = pp n
pp (FDPort n) = pp n
pp (FDParameter n) = pp n
instance Pretty FormalPart where
pp (FPDesignator d) = pp d
pp (FPFunction n d) = pp n <+> parens (pp d)
pp (FPType t d) = pp t <+> parens (pp d)
instance Pretty FullTypeDeclaration where
pp (FullTypeDeclaration i t) = text "TYPE" <+> pp i <+> text "IS" <+> pp t <+> semi
instance Pretty FunctionCall where
pp (FunctionCall n p) = pp n <+> cond parens p
instance Pretty GenerateStatement where
pp (GenerateStatement l g d s) =
pp l <+> colon `hangs` vcat
[ pp g <+> text "GENERATE"
, cond indent d
, cond (const $ text "BEGIN") d
, indent $ vcat $ fmap pp s
, text "END GENERATE" <+> pp l <+> semi
]
instance Pretty GenerationScheme where
pp (GSFor p) = pp p
pp (GSIf c) = pp c
instance Pretty GenericClause where
pp (GenericClause ls) = text "GENERIC" <+> parens (pp ls) <+> semi
instance Pretty GenericMapAspect where
pp (GenericMapAspect as) = text "GENERIC MAP" <+> parens (pp as) <+> semi
instance Pretty GraphicCharacter where pp = error "missing: GraphicCharacter"
instance Pretty GroupConstituent where
pp (GCName n) = pp n
pp (GCChar c) = pp c
instance Pretty GroupTemplateDeclaration where
pp (GroupTemplateDeclaration i cs) = text "GROUP" <+> pp i <+> text "IS" <+> parens (pp cs) <+> semi
instance Pretty GroupDeclaration where
pp (GroupDeclaration i n cs) = text "GROUP" <+> pp i <+> colon <+> pp n <+> parens (pp cs) <+> semi
instance Pretty GuardedSignalSpecification where
pp (GuardedSignalSpecification ss t) = pp ss <+> colon <+> pp t
instance Pretty Identifier where
pp (Ident i) = text i
instance Pretty IfStatement where
pp (IfStatement l (tc, ts) a e) =
labels l $ vcat
[ (text "IF" <+> pp tc <+> text "THEN") `hangs` vpp ts
, elseIf' a
, else' e
, text "END IF" <+> cond id l <+> semi
]
where
elseIf' :: [(Condition, SequenceOfStatements)] -> Doc
elseIf' = vcat . fmap (\(c, ss) -> (text "ELSEIF" <+> pp c <+> text "THEN") `hangs` (vpp ss))
else' :: Maybe SequenceOfStatements -> Doc
else' (Nothing) = empty
else' (Just ss) = text "ELSE" `hangs` (vpp ss)
instance Pretty IncompleteTypeDeclaration where
pp (IncompleteTypeDeclaration i) = text "TYPE" <+> pp i <+> semi
instance Pretty IndexConstraint where
pp (IndexConstraint rs) = parens (commaSep $ map pp rs)
instance Pretty IndexSpecification where
pp (ISRange r) = pp r
pp (ISExp e) = pp e
instance Pretty IndexSubtypeDefinition where
pp (IndexSubtypeDefinition t) = pp t <+> text "RANGE" <+> semi
instance Pretty IndexedName where
pp (IndexedName p es) = pp p <+> parens (commaSep $ map pp es)
instance Pretty InstantiatedUnit where
pp (IUComponent n) = text "COMPONENT" <+> pp n
pp (IUEntity n i) = text "ENTITY" <+> pp n <+> cond parens i
pp (IUConfig n) = text "CONFIGURATION" <+> pp n
instance Pretty InstantiationList where
pp (ILLabels ls) = commaSep $ map pp ls
pp (ILOthers) = text "OTHERS"
pp (ILAll) = text "ALL"
instance Pretty Integer where pp = integer
instance Pretty InterfaceDeclaration where
pp (InterfaceConstantDeclaration is s e) =
text "CONSTANT" <+> pp is <+> colon <+> text "IN" <+> pp s <+> condL (text ":=") e
pp (InterfaceSignalDeclaration is m s b e) =
pp is <+> colon <+> cond id m <+> pp s <+> when b (text "BUS") <+> condL (text ":=") e
pp (InterfaceVariableDeclaration is m s e) =
text "VARIABLE" <+> pp is <+> colon <+> cond id m <+> pp s <+> condL (text ":=") e
pp (InterfaceFileDeclaration is s) =
text "FILE" <+> pp is <+> colon <+> pp s
instance Pretty InterfaceList where
pp (InterfaceList es) = foldr ($+$) empty $ punctuate semi $ map pp es
instance Pretty IterationScheme where
pp (IterWhile c) = text "WHILE" <+> pp c
pp (IterFor p) = text "FOR" <+> pp p
instance Pretty Letter where pp = error "missing: Letter"
instance Pretty LetterOrDigit where pp = error "missing: LetterOrDigit"
instance Pretty LibraryClause where
pp (LibraryClause ns) = text "LIBRARY" <+> pp ns <+> semi
instance Pretty LibraryUnit where pp = error "missing: LibraryUnit"
instance Pretty Literal where
pp (LitNum n) = pp n
pp (LitEnum e) = pp e
pp (LitString s) = pp s
pp (LitBitString b) = pp b
pp (LitNull) = text "NULL"
instance Pretty LogicalNameList where
pp (LogicalNameList ns) = commaSep $ fmap pp ns
instance Pretty LogicalOperator where
pp (And) = text "AND"
pp (Or) = text "OR"
pp (Nand) = text "NAND"
pp (Nor) = text "NOR"
pp (Xor) = text "XOR"
pp (Xnor) = text "XNOR"
instance Pretty LoopStatement where
pp (LoopStatement l i ss) =
labels l $ vcat
[ cond id i <+> text "LOOP"
, indent $ pp ss
, text "END LOOP" <+> cond id l <+> semi
]
instance Pretty MiscellaneousOperator where
pp (Exp) = text "**"
pp (Abs) = text "ABS"
pp (Not) = text "NOT"
instance Pretty Mode where
pp (In) = text "IN"
pp (Out) = text "OUT"
pp (InOut) = text "INOUT"
pp (Buffer) = text "BUFFER"
pp (Linkage) = text "LINKAGE"
instance Pretty MultiplyingOperator where
pp (Times) = char '*'
pp (Div) = char '/'
pp (Mod) = text "MOD"
pp (Rem) = text "REM"
instance Pretty Name where
pp (NSimple n) = pp n
pp (NOp o) = pp o
pp (NSelect s) = pp s
pp (NIndex i) = pp i
pp (NSlice s) = pp s
pp (NAttr a) = pp a
instance Pretty NextStatement where
pp (NextStatement l b c) = label l <+> text "NEXT" <+> cond id b <+> condL (text "WHEN") c <+> semi
instance Pretty NullStatement where
pp (NullStatement l) = label l <+> text "NULL"
instance Pretty NumericLiteral where
pp (NLitAbstract a) = pp a
pp (NLitPhysical p) = pp p
instance Pretty ObjectDeclaration where
pp (ObjConst c) = pp c
pp (ObjSig s) = pp s
pp (ObjVar v) = pp v
pp (ObjFile f) = pp f
instance Pretty Options where
pp (Options g d) = when g (text "GUARDED") <+> cond id d
instance Pretty PackageBody where
pp (PackageBody n d) =
vcat [ text "PACKAGE BODY" <+> pp n <+> text "IS"
, indent $ pp d
, text "END PACKAGE BODY" <+> pp n <+> semi
]
instance Pretty PackageBodyDeclarativeItem where
pp (PBDISubprogDecl s) = pp s
pp (PBDISubprogBody b) = pp b
pp (PBDIType t) = pp t
pp (PBDISubtype s) = pp s
pp (PBDIConstant c) = pp c
pp (PBDIShared s) = pp s
pp (PBDIFile f) = pp f
pp (PBDIAlias a) = pp a
pp (PBDIUseClause u) = pp u
pp (PBDIGroupTemp g) = pp g
pp (PBDIGroup g) = pp g
instance Pretty PackageDeclaration where
pp (PackageDeclaration i d) =
vcat [ text "PACKAGE" <+> pp i <+> text "IS"
, indent $ pp d
, text "END PACKAGE" <+> pp i <+> semi
]
instance Pretty PackageDeclarativeItem where
pp (PHDISubprogDecl s) = pp s
pp (PHDISubprogBody b) = pp b
pp (PHDIType t) = pp t
pp (PHDISubtype s) = pp s
pp (PHDIConstant c) = pp c
pp (PHDISignal s) = pp s
pp (PHDIShared v) = pp v
pp (PHDIFile f) = pp f
pp (PHDIAlias a) = pp a
pp (PHDIComp c) = pp c
pp (PHDIAttrDecl a) = pp a
pp (PHDIAttrSpec a) = pp a
pp (PHDIDiscSpec d) = pp d
pp (PHDIUseClause u) = pp u
pp (PHDIGroupTemp g) = pp g
pp (PHDIGroup g) = pp g
instance Pretty ParameterSpecification where
pp (ParameterSpecification i r) = pp i <+> text "IN" <+> pp r
instance Pretty PhysicalLiteral where
pp (PhysicalLiteral a n) = cond id a <+> pp n
instance Pretty PhysicalTypeDefinition where
pp (PhysicalTypeDefinition c p s n) =
pp c `hangs` vcat
[ text "UNITS"
, indent $ vcat
[ pp p
, vcat $ map pp s
]
, text "END UNITS" <+> cond id n
]
instance Pretty PortClause where
pp (PortClause ls) = text "PORT" <+> parens (pp ls) <+> semi
instance Pretty PortMapAspect where
pp (PortMapAspect as) = text "PORT MAP" <+> parens (pp as) <+> semi
instance Pretty Prefix where
pp (PName n) = pp n
pp (PFun f) = pp f
instance Pretty Primary where
pp (PrimName n) = pp n
pp (PrimLit l) = pp l
pp (PrimAgg a) = pp a
pp (PrimFun f) = pp f
pp (PrimQual q) = pp q
pp (PrimTCon t) = pp t
pp (PrimAlloc a) = pp a
pp (PrimExp e) = parens (pp e)
instance Pretty PrimaryUnit where
pp (PrimaryEntity e) = pp e
pp (PrimaryConfig c) = pp c
pp (PrimaryPackage p) = pp p
instance Pretty ProcedureCall where
pp (ProcedureCall n ap) = pp n <+> cond parens ap
instance Pretty ProcedureCallStatement where
pp (ProcedureCallStatement l p) = label l <+> pp p <+> semi
instance Pretty ProcessDeclarativeItem where
pp (PDISubprogDecl s) = pp s
pp (PDISubprogBody b) = pp b
pp (PDIType t) = pp t
pp (PDISubtype s) = pp s
pp (PDIConstant c) = pp c
pp (PDIVariable v) = pp v
pp (PDIFile f) = pp f
pp (PDIAlias a) = pp a
pp (PDIAttrDecl a) = pp a
pp (PDIAttrSpec a) = pp a
pp (PDIUseClause u) = pp u
instance Pretty ProcessStatement where
pp (ProcessStatement l p ss d s) =
labels l $ vcat
[ (post <+> cond parens ss <+> text "IS")
`hangs` vpp d
, text "BEGIN"
`hangs` vpp s
, text "END" <+> post <+> cond id l <+> semi
]
where
post = when p (text "POSTPONED") <+> text "PROCESS"
instance Pretty QualifiedExpression where
pp (QualExp t e) = pp t <+> char '\'' <+> parens (pp e)
pp (QualAgg t a) = pp t <+> char '\'' <+> pp a
instance Pretty Range where
pp (RAttr a) = pp a
pp (RSimple l d u) = pp l <+> pp d <+> pp u
instance Pretty RangeConstraint where
pp (RangeConstraint r) = text "RANGE" <+> pp r
instance Pretty RecordTypeDefinition where
pp (RecordTypeDefinition es n) =
vcat [ text "RECORD"
, vcat $ map pp es
, text "END RECORD" <+> cond id n
]
instance Pretty Relation where
pp (Relation e (Nothing)) = pp e
pp (Relation e (Just (r, s))) = pp e <+> pp r <+> pp s
instance Pretty RelationalOperator where
pp (Eq) = equals
pp (Neq) = text "/="
pp (Lt) = char '<'
pp (Lte) = text "<="
pp (Gt) = char '>'
pp (Gte) = text ">="
instance Pretty ReportStatement where
pp (ReportStatement l e s) =
labels l $ (text "REPORT" <+> pp e `hangs` condL (text "SEVERITY") s)
instance Pretty ReturnStatement where
pp (ReturnStatement l e) = label l <+> text "RETURN" <+> condR semi e
instance Pretty ScalarTypeDefinition where
pp (ScalarEnum e) = pp e
pp (ScalarInt i) = pp i
pp (ScalarFloat f) = pp f
pp (ScalarPhys p) = pp p
instance Pretty SecondaryUnit where
pp (SecondaryArchitecture a) = pp a
pp (SecondaryPackage p) = pp p
instance Pretty SecondaryUnitDeclaration where
pp (SecondaryUnitDeclaration i p) = pp i <+> equals <+> pp p
instance Pretty SelectedName where
pp (SelectedName p s) = pp p <+> char '.' <+> pp s
instance Pretty SelectedSignalAssignment where
pp (SelectedSignalAssignment e t o w) =
text "WITH" <+> pp e <+> text "SELECT"
`hangs`
pp t <+> text "<=" <+> pp o <+> pp w <+> semi
instance Pretty SelectedWaveforms where
pp (SelectedWaveforms ws (w, c)) = vcat $ optional ++ [last]
where
optional = maybe [] (map f) ws
last = pp w <+> text "WHEN" <+> pp c
f (w, c) = pp w <+> text "WHEN" <+> pp c <+> comma
instance Pretty SensitivityClause where
pp (SensitivityClause ss) = text "ON" <+> pp ss
instance Pretty SensitivityList where
pp (SensitivityList ns) = commaSep $ map pp ns
instance Pretty SequentialStatement where
pp (SWait w) = pp w
pp (SAssert a) = pp a
pp (SReport r) = pp r
pp (SSignalAss s) = pp s
pp (SVarAss v) = pp v
pp (SProc p) = pp p
pp (SIf i) = pp i
pp (SCase c) = pp c
pp (SLoop l) = pp l
pp (SNext n) = pp n
pp (SExit e) = pp e
pp (SReturn r) = pp r
pp (SNull n) = pp n
instance Pretty ShiftExpression where
pp (ShiftExpression e (Nothing)) = pp e
pp (ShiftExpression e (Just (r, s))) = pp e <+> pp r <+> pp s
instance Pretty ShiftOperator where
pp Sll = text "SLL"
pp Srl = text "SRL"
pp Sla = text "SLA"
pp Sra = text "SRA"
pp Rol = text "ROL"
pp Ror = text "ROR"
instance Pretty Sign where
pp Identity = char '+'
pp Negation = char '-'
instance Pretty SignalAssignmentStatement where
pp (SignalAssignmentStatement l t d w) =
label l <+> pp t <+> text "<="
<+> cond id d <+> pp w <+> semi
instance Pretty SignalDeclaration where
pp (SignalDeclaration is s k e) =
text "SIGNAL"
<+> commaSep (fmap pp is)
<+> colon <+> pp s <+> cond id k
<+> condL (text ":=") e <+> semi
instance Pretty SignalKind where
pp Register = text "REGISTER"
pp Bus = text "BUS"
instance Pretty SignalList where
pp (SLName ns) = commaSep $ map pp ns
pp (SLOthers) = text "OTHERS"
pp (SLAll) = text "ALL"
instance Pretty Signature where
pp (Signature (Nothing)) = empty
pp (Signature (Just (ts, t))) = init <+> condL (text "RETURN") t
where
init = commaSep $ maybe [] (map pp) ts
instance Pretty SimpleExpression where
pp (SimpleExpression s t as) = cond id s <+> pp t <+> adds
where
adds = hsep $ map (\(a, t) -> pp a <+> pp t) as
instance Pretty SliceName where
pp (SliceName p r) = pp p <+> parens (pp r)
instance Pretty StringLiteral where
pp (SLit s) = char '\"' <> text s <> char '\"'
instance Pretty SubprogramBody where
pp (SubprogramBody s d st k de) =
vcat [ pp s <+> text "IS"
, indent $ pp d
, text "BEGIN"
, indent $ pp st
, text "END" <+> pp' k <+> pp' de <+> semi
]
instance Pretty SubprogramDeclarativeItem where
pp (SDISubprogDecl d) = pp d
pp (SDISubprogBody b) = pp b
pp (SDIType t) = pp t
pp (SDISubtype s) = pp s
pp (SDIConstant c) = pp c
pp (SDIVariable v) = pp v
pp (SDIFile f) = pp f
pp (SDIAlias a) = pp a
pp (SDIAttrDecl a) = pp a
pp (SDIAttrSepc a) = pp a
pp (SDIUseClause u) = pp u
pp (SDIGroupTemp g) = pp g
pp (SDIGroup g) = pp g
instance Pretty SubprogramKind where
pp Procedure = text "PROCEDURE"
pp Function = text "FUNCTION"
instance Pretty SubprogramSpecification where
pp (SubprogramProcedure d fs) = text "PROCEDURE" <+> pp d <+> cond parens fs
pp (SubprogramFunction p d fs t) =
purity <+> vcat
[ text "FUNCTION" <+> pp d <+> cond parens fs
, text "RETURN" <+> pp t
]
where
purity = case p of
Nothing -> empty
Just True -> text "PURE"
Just False -> text "IMPURE"
instance Pretty SubtypeDeclaration where
pp (SubtypeDeclaration i s) = text "SUBTYPE" <+> pp i <+> text "IS" <+> pp s <+> semi
instance Pretty SubtypeIndication where
pp (SubtypeIndication n t c) = pp' n <+> pp t <+> pp' c
instance Pretty Suffix where
pp (SSimple n) = pp n
pp (SChar c) = pp c
pp (SOp o) = pp o
pp (SAll) = text "ALL"
instance Pretty Target where
pp (TargetName n) = pp n
pp (TargetAgg a) = pp a
instance Pretty Term where
pp (Term f ms) = pp f <+> muls
where
muls = hsep $ map (\(m, t) -> pp m <+> pp t) ms
instance Pretty TimeoutClause where
pp (TimeoutClause e) = text "FOR" <+> pp e
instance Pretty TypeConversion where
pp (TypeConversion t e) = pp t <+> parens (pp e)
instance Pretty TypeDeclaration where
pp (TDFull ft) = pp ft
pp (TDPartial pt) = pp pt
instance Pretty TypeDefinition where
pp (TDScalar s) = pp s
pp (TDComposite c) = pp c
pp (TDAccess a) = pp a
pp (TDFile f) = pp f
instance Pretty TypeMark where
pp (TMType n) = pp n
pp (TMSubtype n) = pp n
instance Pretty UnconstrainedArrayDefinition where
pp (UnconstrainedArrayDefinition is s) =
text "ARRAY" <+> parens (commaSep $ map pp is) <+> text "OF" <+> pp s
instance Pretty UseClause where
pp (UseClause ns) = text "USE" <+> commaSep (map pp ns) <+> semi
instance Pretty VariableAssignmentStatement where
pp (VariableAssignmentStatement l t e) = label l <+> pp t <+> text ":=" <+> pp e <+> semi
instance Pretty VariableDeclaration where
pp (VariableDeclaration s is sub e) =
when s (text "SHARED") <+> text "VARIABLE"
<+> commaSep (fmap pp is)
<+> colon <+> pp sub <+> condL (text ":=") e <+> semi
instance Pretty WaitStatement where
pp (WaitStatement l sc cc tc) =
label l <+> text "WAIT" <+> pp' sc <+> pp' cc <+> pp' tc <+> semi
instance Pretty Waveform where
pp (WaveElem es) = commaSep $ map pp es
pp (WaveUnaffected) = text "UNAFFECTED"
instance Pretty WaveformElement where
pp (WaveEExp e te) = pp e <+> condL (text "AFTER") te
commaSep :: [Doc] -> Doc
commaSep = hsep . punctuate comma
semiSep :: [Doc] -> Doc
semiSep = hsep . punctuate semi
pipeSep :: [Doc] -> Doc
pipeSep = hsep . punctuate (char '|')
textSep :: String -> [Doc] -> Doc
textSep s = hsep . punctuate (space <> text s)
indent :: Doc -> Doc
indent = nest 4
hangs :: Doc -> Doc -> Doc
hangs d1 d2 = d1 $+$ indent d2
labels :: Pretty a => Maybe a -> Doc -> Doc
labels (Nothing) doc = doc
labels (Just a) doc = (pp a <+> colon) `hangs` doc
cond :: Pretty a => (Doc -> Doc) -> Maybe a -> Doc
cond f = maybe empty (f . pp)
condR :: Pretty a => Doc -> Maybe a -> Doc
condR s = cond (<+> s)
condL :: Pretty a => Doc -> Maybe a -> Doc
condL s = cond (s <+>)
label :: Pretty a => Maybe a -> Doc
label = cond (<+> colon)
pp' :: Pretty a => Maybe a -> Doc
pp' = cond id
parens' :: Pretty a => Maybe a -> Doc
parens' = cond parens
when :: Bool -> Doc -> Doc
when b a = if b then a else empty
vpp :: Pretty a => [a] -> Doc
vpp = foldr ($+$) empty . map pp
postponed :: Pretty a => Maybe Label -> Bool -> a -> Doc
postponed l b a = label l <+> when b (text "POSTPONED") <+> pp a