vhdl (empty) → 0.1.1
raw patch · 8 files changed
+1483/−0 lines, 8 filesdep +basedep +mtldep +prettysetup-changed
Dependencies added: base, mtl, pretty, regex-posix
Files
- LICENSE +25/−0
- Language/VHDL/AST.hs +729/−0
- Language/VHDL/AST/Ppr.hs +504/−0
- Language/VHDL/Error.hs +64/−0
- Language/VHDL/FileIO.hs +30/−0
- Language/VHDL/Ppr.hs +106/−0
- Setup.hs +2/−0
- vhdl.cabal +23/−0
+ LICENSE view
@@ -0,0 +1,25 @@+Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+ * Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+ * Neither the name of the copyright holder nor the+ names of its contributors may be used to endorse or promote products+ derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDER ``AS IS'' AND ANY+EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER BE+LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR+BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,+WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN+IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Language/VHDL/AST.hs view
@@ -0,0 +1,729 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.VHDL.AST+-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : christiaan.baaij@gmail.com+-- Stability : experimental+-- Portability : non-portable (Template Haskell)+--+-- A VHDL 93 subset AST (Abstract Syntax Tree), coded so that it can be easy +-- to extend, please see doc/VHDL/vhdl93-syntax.html as reference +-- in order to extend it (this AST is based on that grammar)+-----------------------------------------------------------------------------++-- This AST is aimed at code generation not parsing, and thus, +-- it was simplified+-- The incompatibilities or simplifications from the standard+-- are properly commented++-- FIXME: shouldn't be records used instead of bare algebraic types?+-- FIXME: shouldn't the unused type redefinitions be removed?+-- FIXME: It would maybe be a good idea to create a sequence ADT which+-- guaranteed to hold at least one element (i.e. the grammar+-- has some cases such as "choices ::= choice | {choice}"+-- which are not well represented as "[Choice]", +-- "Choices Choice (Maybe [Choice])" is not easy to handle either+-- and thus, it was discarded.++module Language.VHDL.AST where++import Data.Char (toLower)+import Text.Regex.Posix++import Language.VHDL.Error+++--------------------+-- VHDL identifiers+--------------------++-- VHDL identifier, use mkVHDLId to create it from a String, +-- making sure a string is a proper VHDL identifier+data VHDLId = Basic String | Extended String+ deriving Eq++-- | Obtain the String of a VHDL identifier+fromVHDLId :: VHDLId -> String+fromVHDLId (Basic str) = str+fromVHDLId (Extended str) = '\\' : (escapeBackslashes str) ++ "\\"+ where escapeBackslashes [] = []+ escapeBackslashes (x : xs) + | x == '\\' = "\\\\" ++ escapeBackslashes xs+ | otherwise = x : escapeBackslashes xs+instance Show VHDLId where+ show = show.fromVHDLId+++-- | unsafely create a basic VHDLId (without cheking if the string is correct)+unsafeVHDLBasicId :: String -> VHDLId+unsafeVHDLBasicId str = Basic str+++-- | unsafely create an exteded VHDLId (without cheking if the string is +-- correct)+unsafeVHDLExtId :: String -> VHDLId+unsafeVHDLExtId str = Extended str+++-- | Create a VHDL basic identifier from a String, previously checking if the +-- String is correct+mkVHDLBasicId ::String -> EProne VHDLId+-- FIXME: we relax the fact that two consecutive underlines +-- are not allowed+mkVHDLBasicId [] = throwError EmptyVHDLId+mkVHDLBasicId id+ | id =~ basiIdPat && (not $ elem lowId reservedWords) = return $ Basic id+ | otherwise = throwError $ IncVHDLBasId id+ where lowId = map toLower id+ basiIdPat = "^[A-Za-z](_?[A-Za-z0-9])*$"++-- | Create a VHDL extended identifier from a String, previously checking +-- if the String is correct. The input string must not include the initial+-- and ending backslashes nad the intermediate backslashes shouldn't be escaped.+mkVHDLExtId :: String -> EProne VHDLId+mkVHDLExtId [] = throwError EmptyVHDLId+mkVHDLExtId id+ | id =~ extIdPat = return $ Extended id+ | otherwise = throwError $ IncVHDLExtId id+ where -- Regular expression pattern for extended identifiers.+ -- According to the VHDL93 standard, an extended identifier must:+ -- * Start and end with a backslash '\'+ -- * Its middle characters can be+ -- * two contiguous backslashes \\+ -- * an alphanumeric (A-Za-z0-9)+ -- * a Special Character + -- * an Other Special Character + -- (backslashes can only appear in pairs as indicated above)+ -- + -- However, backslashes will be handled when printing the identifier,+ -- (an initial and ending backslash are added and the intermediate backslashes+ -- are escaped)+ --+ -- Note that we cannot use specialChars and otherSpecialChars+ -- to build the pattern because of the double-backslash rule+ -- and also, the right bracket (according to the posix+ -- standard) needs to go in the first place of a bracket+ -- expression to lose its special meaning. Furthermore,+ -- (according to the POSIX standard as well) we also need to put+ -- '-' in the last place of the bracket expression.+ extIdPat = + "^[]A-Za-z0-9 \"#&\\'()*+,./:;<=>_|!$%@?[^`{}~-]+$"+++-- | Unsafely append a string to a VHDL identifier (i.e. without checking if+-- the resulting identifier is valid)+unsafeIdAppend :: VHDLId -> String -> VHDLId+unsafeIdAppend (Basic id) suffix = Basic $ id ++ suffix+unsafeIdAppend (Extended id) suffix = Extended $ id ++ suffix++-- | special characters as defined in the VHDL93 standard+specialChars :: [Char]+specialChars = ['"' , '#' , '&' , '\'' , '(' , ')' , '*' , '+' , ',',+ '-' , '.' , '/' , ':' , ';' , '<' , '=' , '>' , '_' , '|']++-- | other special characters as defined in the VHDL93 standard+otherSpecialChars :: [Char]+otherSpecialChars =['!' , '$' , '%' , '@' , '?' , '[' , '\\' , ']',+ '^' , '`' , '{' , '}' , '~']++-- | Reserved identifiers+reservedWords :: [String]+reservedWords = ["abs", "access", "after", "alias", "all", "and",+ "architecture", "array", "assert", "attribute", "begin", "block",+ "body", "buffer", "bus", "case", "component", "configuration",+ "constant", "disconnect", "downto", "else", "elsif", "end", "entity",+ "exit", "file", "for", "function", "generate", "generic", "group",+ "guarded", "if", "impure", "in", "inertial", "inout", "is", "label",+ "library", "linkage", "literal", "loop", "map", "mod", "nand", "new",+ "next", "nor", "not", "null", "of", "on", "open", "or", "others",+ "out", "package", "port", "postponed", "procedure", "process", "pure",+ "range", "record", "register", "reject", "rem", "report", "return",+ "rol", "ror", "select", "severity", "shared", "signal", "sla", "sll",+ "sra", "srl", "subtype", "then", "to", "transport", "type",+ "unaffected", "units", "until", "use", "variable", "wait", "when",+ "while", "with", "xnor", "xor"]+++++ ---------+ -- AST --+ ---------+++-- { } (0 or more) is expressed as [ ]+-- [ ] (optional) is expressed as Maybe+++-- design_file+-- Having ContextClauses associated to library units is messy+-- instead we only allow ContextClause for the whole design file.+-- Furthermore we incorrectly (and deliberately) accept a file with +-- no library units +data DesignFile = DesignFile [ContextItem] [LibraryUnit] + deriving Show++-- context_item+-- We don't allow the "name1,name2,name3" syntax, only one name is allowed+-- at once+data ContextItem = Library VHDLId | Use SelectedName+ deriving Show++-- library_unit+-- We avoid adding the overhead of a PrimaryUnit and SecondaryUnit types+data LibraryUnit = LUEntity EntityDec | + LUArch ArchBody | + LUPackageDec PackageDec |+ LUPackageBody PackageBody+ deriving Show++-- entity_declaration+-- No declarative nor statemet part is allowed +-- Only interface signal declarations are allowed in the port clause+data EntityDec = EntityDec VHDLId [IfaceSigDec]+ deriving Show++-- | interface_signal_declaration+-- We don't allow the "id1,id2,id3" syntax, only one identifier is allowed+-- at once+-- The Mode is mandatory+-- Bus is not allowed +-- Preasigned values are not allowed+-- Subtype indications are not allowed, just a typemark +-- Constraints are not allowed: just add a new type with the constarint+-- in ForSyDe.vhd if it is required+data IfaceSigDec = IfaceSigDec VHDLId Mode TypeMark+ deriving Show++-- | type_mark+-- We don't distinguish between type names and subtype names+-- We dont' support selected names, only simple names because we won't need+-- name selection (i.e. Use clauses will make name selection unnecesary)+type TypeMark = SimpleName+++-- | mode+-- INOUT | BUFFER | LINKAGE are not allowed+data Mode = In | Out+ deriving (Show, Eq)++-- | architecture_body +-- [ ARCHITECTURE ] and [ architecture_simple_name ] are not allowed+data ArchBody = ArchBody VHDLId VHDLName [BlockDecItem] [ConcSm]+ deriving Show++-- | package_declaration+-- [ PACKAGE ] and [ package_simple_name ] are not allowed+data PackageDec = PackageDec VHDLId [PackageDecItem]+ deriving Show+++-- | package_declarative_item+-- only type declarations, subtype declarations and subprogram specifications +-- (working as subprogram_declaration) allowed+data PackageDecItem = PDITD TypeDec | PDISD SubtypeDec | PDISS SubProgSpec+ deriving Show++-- | package_body+-- [ PACKAGE ] and [ package_simple_name ] are not allowed+data PackageBody = PackageBody VHDLId [PackageBodyDecItem]+ deriving Show++-- | only subprogram_body is allowed+type PackageBodyDecItem = SubProgBody++-- | subtype-declaration+data SubtypeDec = SubtypeDec VHDLId SubtypeIn+ deriving Show++-- | subtype_indication+-- resolution functions are not permitted+data SubtypeIn = SubtypeIn TypeMark (Maybe SubtypeConstraint)+ deriving Show++-- | constraint+-- Only index constraints are allowed+type Constraint = IndexConstraint++data SubtypeConstraint = ConstraintIndex Constraint | ConstraintRange Range+ deriving Show++-- | range+-- the direction must always be \"to\"+data Range = AttribRange AttribName | + SubTypeRange Expr Expr |+ ToRange Expr Expr |+ DownRange Expr Expr + deriving Show++-- | index_constraint+data IndexConstraint = IndexConstraint [DiscreteRange]+ deriving Show++-- | discrete_range+-- only ranges are allowed+type DiscreteRange = Range++-- | type_declaration+-- only full_type_declarations are allowed+data TypeDec = TypeDec VHDLId TypeDef+ deriving Show++-- | type_declaration+-- only composite types and enumeration types (a specific scalar type)+data TypeDef = TDA ArrayTypeDef | TDR RecordTypeDef | TDE EnumTypeDef+ deriving Show++-- | array_type_definition+-- unconstrained_array_definition+-- constrained_array_definition+-- A TypeMark is used instead of a subtype_indication. If subtyping is required,+-- declare a subtype explicitly. +data ArrayTypeDef = UnconsArrayDef [TypeMark] TypeMark |+ ConsArrayDef IndexConstraint TypeMark+ deriving Show++-- | record_type_definition+-- [ record_type_simple_name ] not allowed+data RecordTypeDef = RecordTypeDef [ElementDec]+ deriving Show++-- | element_declaration +-- multi-identifier element declarations not allowed+-- element_subtype_definition is simplified to a type_mark+data ElementDec = ElementDec VHDLId TypeMark+ deriving Show++-- | enumeration_type_definition +-- enumeration literals can only be identifiers+data EnumTypeDef = EnumTypeDef [VHDLId]+ deriving Show++-- | name+-- operator_names are not allowed +data VHDLName = NSimple SimpleName | + NSelected SelectedName | + NIndexed IndexedName |+ NSlice SliceName |+ NAttribute AttribName + deriving Show++-- | simple_name+type SimpleName = VHDLId++-- | selected_name+data SelectedName = Prefix :.: Suffix+ deriving Show++infixl :.:++-- | indexed_name+-- note that according to the VHDL93 grammar the index list cannot be empty +data IndexedName = IndexedName Prefix [Expr]+ deriving Show++-- | prefix+-- only names (no function calls)+type Prefix = VHDLName++-- | suffix+-- no character or operator symbols are accepted+data Suffix = SSimple SimpleName | All+ deriving Show+++-- | slice_name+data SliceName = SliceName Prefix DiscreteRange+ deriving Show++-- | attribute_name+-- signatures are not allowed+data AttribName = AttribName Prefix VHDLName (Maybe Expr)+ deriving Show++-- | block_declarative_item+-- Only subprogram bodies and signal declarations are allowed+data BlockDecItem = BDISPB SubProgBody | BDISD SigDec+ deriving Show+++-- | subprogram_body+-- No subprogram kind nor designator is allowed+data SubProgBody = SubProgBody SubProgSpec [SubProgDecItem] [SeqSm]+ deriving Show++-- | subprogram_declarative_item+-- only varaible declarations are allowed.+data SubProgDecItem = SPVD VarDec | SPCD ConstDec | SPSB SubProgBody+ deriving Show++-- | variable_declaration+-- identifier lists are not allowed+data VarDec = VarDec VHDLId SubtypeIn (Maybe Expr)+ deriving Show++data ConstDec = ConstDec VHDLId SubtypeIn (Maybe Expr)+ deriving Show++-- | subprogram_specification+-- Only Functions are allowed+-- [Pure | Impure] is not allowed+-- Only an identifier is valid as the designator+-- In the formal parameter list only variable declarations are accepted +data SubProgSpec = Function VHDLId [IfaceVarDec] TypeMark + deriving Show++-- | interface_variable_declaration+-- [variable] is not allowed+-- We don't allow the "id1,id2,id3" syntax, only one identifier is allowed+-- Mode is not allowed+-- Resolution functions and constraints are not allowed, thus a TypeMark+-- is used instead of a subtype_indication. If subtyping is required,+-- declare a subtype explicitly.+data IfaceVarDec = IfaceVarDec VHDLId TypeMark+ deriving Show++-- | sequential_statement+-- Only If, case, return, for loops, assignment, @wait for@ procedure calls+-- allowed.+-- Only for loops are allowed (thus loop_statement doesn't exist) and cannot+-- be provided labels.+-- The target cannot be an aggregate.+-- General wait statements are not allowed, only @wait for@+-- It is incorrect to have an empty [CaseSmAlt]+data SeqSm = IfSm Expr [SeqSm] [ElseIf] (Maybe Else) |+ CaseSm Expr [CaseSmAlt] |+ ReturnSm (Maybe Expr) |+ ForSM VHDLId DiscreteRange [SeqSm] |+ VHDLName := Expr |+ WaitFor Expr |+ SigAssign VHDLName Wform |+ ProcCall VHDLName [AssocElem]+ deriving Show++-- | helper type, they doesn't exist in the origianl grammar+data ElseIf = ElseIf Expr [SeqSm]+ deriving Show++-- | helper type, it doesn't exist in the origianl grammar+data Else = Else [SeqSm]+ deriving Show++-- | case_statement_alternative+-- it is incorrect to have an empty [Choice]+data CaseSmAlt = CaseSmAlt [Choice] [SeqSm]+ deriving Show++-- | choice+-- although any expression is allowed the grammar specfically only allows +-- simple_expressions (not covered in this AST) +data Choice = ChoiceE Expr | Others+ deriving Show++-- | signal_declaration+-- We don't allow the "id1,id2,id3" syntax, only one identifier is allowed+-- at once+-- Resolution functions and constraints are not allowed, thus a TypeMark+-- is used instead of a subtype_indication+-- Signal kinds are not allowed+data SigDec = SigDec VHDLId TypeMark (Maybe Expr)+ deriving Show++-- | concurrent_statement+-- only block statements, component instantiations and signal assignments +-- are allowed+data ConcSm = CSBSm BlockSm | + CSSASm ConSigAssignSm | + CSISm CompInsSm |+ CSPSm ProcSm |+ CSGSm GenerateSm+ deriving Show++-- | block_statement+-- Generics are not supported+-- The port_clause (with only signals) and port_map_aspect are mandatory+-- The ending [ block_label ] is not allowed+-- +data BlockSm = BlockSm Label [IfaceSigDec] PMapAspect [BlockDecItem] [ConcSm]+ deriving Show++-- | port_map_aspect+newtype PMapAspect = PMapAspect [AssocElem]+ deriving Show++-- | label+type Label = VHDLId++-- | association_element+data AssocElem = Maybe (FormalPart) :=>: ActualPart+ deriving Show++-- | formal_part+-- We only accept a formal_designator (which is a name after all),+-- in the forme of simple name (no need for selected names) +-- "function_name ( formal_designator )" and "type_mark ( formal_designator )"+-- are not allowed+type FormalPart = SimpleName++-- | actual_part+-- We only accept an actual_designator,+-- "function_name ( actual_designator )" and "type_mark ( actual_designator )"+-- are not allowed+type ActualPart = ActualDesig++-- | actual_designator+data ActualDesig = ADName VHDLName | ADExpr Expr | Open+ deriving Show++-- | concurrent_signal_assignment_statement+-- Only conditional_signal_assignment is allowed (without options)+-- The LHS (targets) are simply signal names, no aggregates+data ConSigAssignSm = VHDLName :<==: ConWforms+ deriving Show++-- | conditional_waveforms +data ConWforms = ConWforms [WhenElse] Wform (Maybe When) + deriving Show++-- | Helper type, it doesn't exist in the VHDL grammar+data WhenElse = WhenElse Wform Expr+ deriving Show++-- | Helper type, it doesn't exist in the VHDL grammar+newtype When = When Expr+ deriving Show++-- | waveform+-- although it is possible to leave [Expr] empty, that's obviously not+-- valid VHDL waveform+data Wform = Wform [WformElem] | Unaffected+ deriving Show++-- | waveform_element+-- Null is not accepted+data WformElem = WformElem Expr (Maybe Expr)+ deriving Show++ +-- | component_instantiation_statement+-- No generics supported+-- The port map aspect is mandatory+data CompInsSm = CompInsSm Label InsUnit PMapAspect+ deriving Show++-- | process_statement+-- The label is mandatory+-- Only simple names are accepted in the sensitivity list+-- No declarative part is allowed+data ProcSm = ProcSm Label [SimpleName] [SeqSm]+ deriving Show++-- | instantiated_unit+-- Only Entities are allowed and their architecture cannot be specified+data InsUnit = IUEntity VHDLName+ deriving Show++data GenerateSm = GenerateSm Label GenSm [BlockDecItem] [ConcSm]+ deriving Show++data GenSm = ForGn VHDLId DiscreteRange |+ IfGn Expr+ deriving Show++-----------------+-- Expression AST+-----------------++-- | expression, instead of creating an AST like the grammar +-- (see commented section below) we made our own expressions which are +-- easier to handle, but which don't don't show operand precedence+-- (that is a responsibility of the pretty printer)++data Expr = -- Logical operations+ And Expr Expr |+ Or Expr Expr |+ Xor Expr Expr |+ Nand Expr Expr |+ Nor Expr Expr |+ Xnor Expr Expr |+ -- Relational Operators+ Expr :=: Expr |+ Expr :/=: Expr |+ Expr :<: Expr |+ Expr :<=: Expr |+ Expr :>: Expr |+ Expr :>=: Expr |+ -- Shift Operators+ Sll Expr Expr |+ Srl Expr Expr |+ Sla Expr Expr |+ Sra Expr Expr |+ Rol Expr Expr |+ Ror Expr Expr |+ -- Adding Operators+ Expr :+: Expr |+ Expr :-: Expr |+ Expr :&: Expr |+ -- Sign Operators+ Neg Expr |+ Pos Expr |+ -- Multiplying Operators+ Expr :*: Expr |+ Expr :/: Expr |+ Mod Expr Expr |+ Rem Expr Expr |+ -- Miscellaneous Operators+ Expr :**: Expr |+ Abs Expr |+ Not Expr |+ -- Primary expressions+ -- Only literals, names and function calls are allowed+ PrimName VHDLName |+ PrimLit Literal |+ PrimFCall FCall | + -- Composite_types-related operators+ Aggregate [ElemAssoc] -- (exp1,exp2,exp3, ...)+ deriving Show ++-- operand precedences, according to the VHDL LRM: +-- "Where the language+-- allows a sequence of operators, operators with the same+-- precedence level are associated with their operands in textual+-- order, from left to right." In other words, they are all left associative+--+-- For example: a / b / c = (a/b)/c+-- a and b or c is illegal (mixing operators is not allowed+-- by the language and only+-- can avoid parenthesis in some +-- cases)++infixl 2 `And`, `Or`, `Xor`, `Nand`, `Nor`, `Xnor`+infixl 3 :=:, :/=:, :<:, :<=:, :>:, :>=:+infixl 4 `Sll`, `Srl`, `Sla`, `Sra`, `Rol`, `Ror`+infixl 5 :+:, :-:, :&:+infix 6 `Neg`, `Pos` +infixl 7 :*:, :/:, `Mod`, `Rem`+infixl 8 :**:, `Abs`, `Not` ++-- | Logical Operators precedence+logicalPrec :: Int+logicalPrec = 2++-- | Relational Operators Precedence+relationalPrec :: Int+relationalPrec = 3++-- | Shift Operators Precedence+shiftPrec :: Int+shiftPrec = 4++-- | Plus Operators precedence+plusPrec :: Int+plusPrec = 5++-- | Sign Operators Precedence+signPrec :: Int+signPrec = 6++-- | Multplying Operators Precedecne+multPrec :: Int+multPrec = 7++-- | Miscellaneous Operators Precedence+miscPrec :: Int+miscPrec = 8+++++-- | element_association+-- only one choice is allowed+data ElemAssoc = ElemAssoc (Maybe Choice) Expr+ deriving Show++-- | literal+-- Literals are expressed as a string (remember we are generating+-- code, not parsing)+type Literal = String++-- | function_call+data FCall = FCall VHDLName [AssocElem]+ deriving Show+ + +{-++Expression AST following the grammar (discarded)++-- again, even if it possible to leave the [Relation] lists empty+-- that wouldn't be valid VHDL code+-- regading NandExpr and NorExpr, their Relation list should +-- have a maximum size of two (i.e. NandExpr Expr (Maybe Expr))+data Expr = AndExpr [Relation] | + OrExpr [Relation] |+ XorExpr [Relation] |+ NandExpr [Relation] |+ NorExpr [Relation] |+ XnorExpr [Relation]+ deriving Show++-- relation +data Relation = Relation ShiftExpr (Maybe (RelOp,ShiftExpr))+ deriving Show++-- relational_operator+data RelOp = Eq | NEq | Less | LessEq | Gter | GterEq + deriving Show ++-- shift_expression+data ShiftExpr = ShiftExpr SimpleExpr (Maybe(ShiftOp,SimpleExpr)) + deriving Show++-- simple_expression+data SimpleExpr = SimpleExpr (Maybe Sign) Term [(AddOp,Term)]+ deriving Show++-- sign+data Sign = Pos | Neg+ deriving Show++-- shift_operator+data ShiftOp = Sll | Srl | Sla | Sra | Rol | Ror+ deriving Show ++-- adding_operator+data AddOp = Plus | Minus | Concat + deriving Show++-- term+data Term = Term Factor (Maybe (MultOp, Factor))+ deriving Show++-- multiplying_operator+data MultOp = Mult | Div | Mod | Rem+ deriving Show++-- factor+data Factor = Exp Primary (Maybe (Primary)) |+ Abs Primary |+ Not Primary+ deriving Show++-- primary+-- Only literals, names and function calls are allowed+data Primary = PrimName VHDLName |+ PrimLit Literal |+ PrimFCall FCall+ deriving Show++-- literal+-- Literals are expressed as a string (remember we are generating+-- code, not parsing)+type Literal = String++-- function_call+data FCall = FCall VHDLName [AssocElem]+ deriving Show+-}
+ Language/VHDL/AST/Ppr.hs view
@@ -0,0 +1,504 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.VHDL.AST.Ppr+-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : christiaan.baaij@gmail.com+-- Stability : experimental+-- Portability : non-portable (Template Haskell)+--+-- VHDL pretty-printing instances.+--+-----------------------------------------------------------------------------+++-- FIXME: we could avoid the LANGUAGE extensions by adding ppr_list to the Ppr +-- class (see Language.Haskell.TH.Ppr)++module Language.VHDL.AST.Ppr () where++import Language.VHDL.Ppr++import Language.VHDL.AST++import Text.PrettyPrint.HughesPJ hiding (Mode)+++-- | Number of spaces used for indentation+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+-- FIXME: improve pretty printing of the+-- declarations+-- This:+-- S1 : bit+-- Ssdds : bit+-- should really be printed as+-- S1 : bit+-- Ssdds : bit+ 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) $+$+-- TODO, show the id here+ 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+-- FIXME: improve pretty printing of the+-- declarations+-- This:+-- (S1 : bit;+-- Ssdds : bit)+-- should really be printed as+-- (S1 : bit;+-- Ssdds : bit)+ 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++-- FIXME, remove parenthesis according to precedence+instance Ppr Expr where+ ppr = pprExprPrec 0 ""+++-- | Prettyprint an binary infix operator +pprExprPrecInfix :: Int -- ^ Accumulated precedence value (initialized to 0)+ -> String -- ^ Enclosing operator (initialized to \"\")+ -> Int -- ^ Precedence of current infix operator + -> Expr -- ^ lhs expression+ -> String -- ^ operator name+ -> Expr -- ^ rhs expression+ -> Doc+-- To avoid priting parenthesis based on the left+-- associativity of all operators within the same precedence class, +-- the precedence passed to the left branch is curr instead of+-- curr+1.+--+-- However, the VHDL grammar sometimes doesn't allow it +-- e.g. "and a or b and d" is illegal. In fact,+-- you can only put two operators together without parenthesis+-- in some cases:+-- +-- * logical operators: "and", "or", "xor", "xnor", but cannot be mixed up.+-- * relational operators: none+-- * shift operators: none+-- * adding operators: all, can be mixed up+-- * multiplying operator: all, can be mixed up+-- * misc operator: none+--+-- Thus, we keep track of the enclosing+-- operator, and skip parenthesis according to left parsing associativity+-- in the cases stated above.+--+-- Note that we are only making use of syntactic associativity. e.g.+-- even if "+" is semantially associative: a+(b+c)=(a+b)+c,+-- we will only skip parenthesis in (a+b)+c++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"])++-- | Prettyprint unary prefix operators+pprExprPrecPrefix :: Int -- ^ Accumulated precedence value (initialized to 0)+ -> Int -- ^ Precedence of current infix operator+ -> String -- ^ operator name+ -> Expr -- ^ operator argument+ -> Doc+pprExprPrecPrefix ac curr op arg = parensIf (ac>curr) $+ text op <+> pprExprPrec (curr+1) op arg+++-- | Prints an expression taking precedence and left associativity+-- in account+pprExprPrec :: Int -- ^ Accumulated precedence value (initialized to 0)+ -> String -- ^ Enclosing operator+ -> Expr -- ^ Expression curently prettyprinted + -> Doc+-- Logical operations+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+-- Relational Operators+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+-- Shift Operators+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+-- Adding Operators+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+-- Sign Operators+pprExprPrec p _ (Neg e) = pprExprPrecPrefix p signPrec "-" e +pprExprPrec p _ (Pos e) = pprExprPrecPrefix p signPrec "+" e +-- Multiplying Operators+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+-- Miscellaneous Operators+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 +-- Primary expressions+pprExprPrec _ _ (PrimName name) = ppr name+pprExprPrec _ _ (PrimLit lit) = text lit+pprExprPrec _ _ (PrimFCall fCall) = ppr fCall+-- Composite-type expressions+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)+
+ Language/VHDL/Error.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.VHDL.Error+-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : christiaan.baaij@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- ForSyDe error-related types and functions.+--+-----------------------------------------------------------------------------+module Language.VHDL.Error + (VHDLErr(..),+ EProne,+ module Control.Monad.Error,+ module Debug.Trace) where++import Debug.Trace+import Control.Monad.Error ++-------------+-- VHDLErr+-------------++-- | All Errors thrown or displayed in ForSyDe+data VHDLErr = + -- Used in ForSyDe.Backend.VHDL.*+ -- | Empty VHDL identifier+ EmptyVHDLId |+ -- | Incorrect Basic VHDL Identifier+ IncVHDLBasId String |+ -- | Incorrect Extended VHDL Identifier+ IncVHDLExtId String |+ -- | Other Errors+ Other String++-- | Show errors+instance Show VHDLErr where+ show EmptyVHDLId = "Empty VHDL identifier"+ show (IncVHDLBasId id) = "Incorrect VHDL basic identifier " ++ + "`" ++ id ++ "'"+ show (IncVHDLExtId id) = "Incorrect VHDL extended identifier " ++ + "`" ++ id ++ "'"++--------------+-- Error Monad+--------------++-- | We make CLasHErr an instance of the Error class to be able to throw it+-- as an exception.+instance Error VHDLErr where+ noMsg = Other "An Error has ocurred"+ strMsg = Other++-- | 'EProne' represents failure using Left CLasHErr or a successful +-- result of type a using Right a+-- +-- 'EProne' is implicitly an instance of +-- ['MonadError'] (@Error e => MonadError e (Either e)@)+-- ['Monad'] (@Error e => Monad (Either e)@)+type EProne = Either VHDLErr+-- FIXME: Rethink Eprone so that it takes contexts in account
+ Language/VHDL/FileIO.hs view
@@ -0,0 +1,30 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.VHDL.FileIO+-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : forsyde-dev@ict.kth.se+-- Stability : experimental+-- Portability : portable+--+-- Functions working with files in the VHDL backend. +--+-----------------------------------------------------------------------------+module Language.VHDL.FileIO (writeDesignFile) where++import Language.VHDL.AST+import Language.VHDL.AST.Ppr() -- instances+import qualified Language.VHDL.Ppr as Ppr (ppr)++import System.IO+import Text.PrettyPrint.HughesPJ++-- | Write a design file to a file in disk+writeDesignFile :: DesignFile -> FilePath -> IO ()+writeDesignFile df fp = do+ handle <- openFile fp WriteMode+ hPutStrLn handle "-- Automatically generated VHDL"+ hPutStr handle $ (renderStyle mystyle . Ppr.ppr) df+ hClose handle+ where mystyle = style{lineLength=80, ribbonsPerLine=1}
+ Language/VHDL/Ppr.hs view
@@ -0,0 +1,106 @@+-----------------------------------------------------------------------------+-- |+-- Module : Language.VHDL.Ppr+-- Copyright : (c) SAM Group, KTH/ICT/ECS 2007-2008+-- License : BSD-style (see the file LICENSE)+-- +-- Maintainer : christiaan.baaij@gmail.com+-- Stability : experimental+-- Portability : non-portable (Template Haskell)+--+-- ForSyDe pretty-printing class and auxiliar functions.+--+-----------------------------------------------------------------------------+module Language.VHDL.Ppr where++import Text.PrettyPrint.HughesPJ++-- | Pretty printing class+class Ppr a where+ ppr :: a -> Doc++-- identity instantiation+instance Ppr Doc where+ ppr = id++-- | Pretty printing class with associated printing options+class PprOps ops toPpr | toPpr -> ops where+ -- NOTE: Would it be better to use a State Monad?+ -- i.e. pprOps :: toPpr -> State ops Doc+ pprOps :: ops -> toPpr -> Doc +++-- dot+dot :: Doc+dot = char '.'++-- One line vertical space+vSpace :: Doc+vSpace = text ""++-- Multi-line vertical space+multiVSpace :: Int -> Doc+multiVSpace n = vcat (replicate n (text "")) ++-- Pretty-print a list supplying the document joining function+ppr_list :: Ppr a => (Doc -> Doc -> Doc) -> [a] -> Doc+ppr_list _ [] = empty+ppr_list join (a1:rest) = go a1 rest + where go a1 [] = ppr a1+ go a1 (a2:rest) = ppr a1 `join` go a2 rest++-- Pretty-print a list supplying the document joining function+-- (PprOps version)+pprOps_list :: PprOps ops toPpr => ops -> (Doc -> Doc -> Doc) -> [toPpr] -> Doc+pprOps_list _ _ [] = empty+pprOps_list ops join (a1:rest) = go a1 rest+ where go a1 [] = pprOps ops a1+ go a1 (a2:rest) = pprOps ops a1 `join` go a2 rest++-- | Join two documents vertically leaving n vertical spaces between them+vNSpaces :: Int -> Doc -> Doc -> Doc+vNSpaces n doc1 doc2 = doc1 $+$ + multiVSpace n $+$+ doc2++-- Join two documents vertically putting a semicolon in the middle+vSemi :: Doc -> Doc -> Doc+vSemi doc1 doc2 = doc1 <> semi $+$ doc2+++-- Join two documents vertically putting a comma in the middle+vComma :: Doc -> Doc -> Doc+vComma doc1 doc2 = doc1 <> comma $+$ doc2++-- Join two documents horizontally putting a comma in the middle+hComma :: Doc -> Doc -> Doc+hComma doc1 doc2 = doc1 <> comma <+> doc2+++-- | apply sep to a list of prettyprintable elements, +-- previously interspersing commas+commaSep :: Ppr a => [a] -> Doc+commaSep = sep.(punctuate comma).(map ppr)+ ++-- | Only append if both of the documents are non-empty+($++$) :: Doc -> Doc -> Doc+d1 $++$ d2 + | isEmpty d1 || isEmpty d2 = empty+ | otherwise = d1 $+$ d2+++-- | Only append if both of the documents are non-empty+(<++>) :: Doc -> Doc -> Doc+d1 <++> d2 + | isEmpty d1 || isEmpty d2 = empty+ | otherwise = d1 <+> d2++-- | Enclose in parenthesis only if the document is non-empty+parensNonEmpty :: Doc -> Doc+parensNonEmpty doc | isEmpty doc = empty+parensNonEmpty doc = parens doc++-- | Enclose in parenthesis only if the predicate is True+parensIf :: Bool -> Doc -> Doc+parensIf p d = if p then parens d else d
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ vhdl.cabal view
@@ -0,0 +1,23 @@+name: vhdl+version: 0.1.1+synopsis: VHDL AST and pretty printer+description: VHDL AST and pretty printer, should only be used for building AST's, not as part of a VHDL parser+category: Language+license: BSD3+license-file: LICENSE+copyright: Copyright (c) 2009 Christiaan Baaij & Matthijs Kooijman+author: Christiaan Baaij+maintainer: christiaan.baaij@gmail.com+package-url: http://github.com/christiaanb/vhdl/tree/master+build-type: Simple+cabal-version: >=1.2 ++Library+ extensions: FlexibleInstances, MultiParamTypeClasses, + FunctionalDependencies+ build-depends: base >= 4.0 && < 5, regex-posix, pretty, mtl+ exposed-modules: Language.VHDL.AST,+ Language.VHDL.AST.Ppr+ Language.VHDL.Ppr,+ Language.VHDL.FileIO+ other-modules: Language.VHDL.Error