language-bluespec (empty) → 0.1
raw patch · 26 files changed
+4317/−0 lines, 26 filesdep +basedep +containersdep +integer-gmp
Dependencies added: base, containers, integer-gmp, pretty, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +13/−0
- language-bluespec.cabal +77/−0
- src/Language/Bluespec/Classic/AST.hs +27/−0
- src/Language/Bluespec/Classic/AST/Builtin/FStrings.hs +516/−0
- src/Language/Bluespec/Classic/AST/Builtin/Ids.hs +735/−0
- src/Language/Bluespec/Classic/AST/Builtin/Types.hs +204/−0
- src/Language/Bluespec/Classic/AST/FString.hs +40/−0
- src/Language/Bluespec/Classic/AST/Id.hs +270/−0
- src/Language/Bluespec/Classic/AST/IntLit.hs +56/−0
- src/Language/Bluespec/Classic/AST/Literal.hs +24/−0
- src/Language/Bluespec/Classic/AST/Position.hs +59/−0
- src/Language/Bluespec/Classic/AST/Pragma.hs +230/−0
- src/Language/Bluespec/Classic/AST/SString.hs +10/−0
- src/Language/Bluespec/Classic/AST/SchedInfo.hs +120/−0
- src/Language/Bluespec/Classic/AST/Syntax.hs +987/−0
- src/Language/Bluespec/Classic/AST/Type.hs +283/−0
- src/Language/Bluespec/Classic/AST/Undefined.hs +22/−0
- src/Language/Bluespec/Classic/AST/VModInfo.hs +259/−0
- src/Language/Bluespec/IntegerUtil.hs +42/−0
- src/Language/Bluespec/Lex.hs +37/−0
- src/Language/Bluespec/Log2.hs +101/−0
- src/Language/Bluespec/Prelude.hs +8/−0
- src/Language/Bluespec/Pretty.hs +98/−0
- src/Language/Bluespec/Util.hs +64/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for language-bluespec++## 0.1 -- 2024-02-08++* Initial version of `language-bluespec`.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2022, Ryan Scott++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 Ryan Scott nor the names of other+ 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 HOLDERS AND CONTRIBUTORS+"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+OWNER OR CONTRIBUTORS 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.
+ README.md view
@@ -0,0 +1,13 @@+# `language-bluespec`++This package contains an implementation of the+[Bluespec](http://wiki.bluespec.com/) AST. In particular, this implements the+Bluespec Haskell (BH) syntax, also known as Bluespec Classic. We may add+support for the Bluespec SystemVerilog (BSV) syntax at a later date.++To our knowledge, there is no formal grammar that describes the syntax of BH or+BSV, so this package is based off of the code in the [Bluespec+compiler](https://github.com/B-Lang-org/bsc). Although the Bluespec compiler is+written in Haskell, it is not particularly simple to depend on the compiler as+a library, so this package exists to extract out the relevant compiler code+into a simple-to-use library.
+ language-bluespec.cabal view
@@ -0,0 +1,77 @@+cabal-version: 1.24+name: language-bluespec+version: 0.1+synopsis: An implementation of the Bluespec Haskell AST+description: This package contains an implementation of the+ <http://wiki.bluespec.com/ Bluespec> language's AST. In+ particular, this implements the Bluespec Haskell (BH)+ syntax, also known as Bluespec Classic. We may add support+ for the Bluespec SystemVerilog (BSV) syntax at a later date.++ To our knowledge, there is no formal grammar that describes+ the syntax of BH or BSV, so this package is based off of the+ code in the <https://github.com/B-Lang-org/bsc Bluespec+ compiler>. Although the Bluespec compiler is written in+ Haskell, it is not particularly simple to depend on the+ compiler as a library, so this package exists to extract out+ the relevant compiler code into a simple-to-use library.+homepage: https://github.com/GaloisInc/language-bluespec+bug-reports: https://github.com/GaloisInc/language-bluespec/issues+license: BSD3+license-file: LICENSE+author: Galois, Inc.+maintainer: Ryan Scott <rscott@galois.com>+stability: Experimental+copyright: (C) 2020-2022 Bluespec Inc., (C) 2022 Galois, Inc.+category: Language+build-type: Simple+extra-source-files: CHANGELOG.md, README.md+tested-with: GHC == 8.6.5+ , GHC == 8.8.4+ , GHC == 8.10.7+ , GHC == 9.0.2+ , GHC == 9.2.2+ , GHC == 9.4.8+ , GHC == 9.6.4+ , GHC == 9.8.1++source-repository head+ type: git+ location: https://github.com/GaloisInc/language-bluespec++library+ exposed-modules: Language.Bluespec.Classic.AST+ Language.Bluespec.Classic.AST.FString+ Language.Bluespec.Classic.AST.Id+ Language.Bluespec.Classic.AST.IntLit+ Language.Bluespec.Classic.AST.Literal+ Language.Bluespec.Classic.AST.Position+ Language.Bluespec.Classic.AST.Pragma+ Language.Bluespec.Classic.AST.SchedInfo+ Language.Bluespec.Classic.AST.SString+ Language.Bluespec.Classic.AST.Syntax+ Language.Bluespec.Classic.AST.Type+ Language.Bluespec.Classic.AST.Undefined+ Language.Bluespec.Classic.AST.VModInfo++ Language.Bluespec.Classic.AST.Builtin.FStrings+ Language.Bluespec.Classic.AST.Builtin.Ids+ Language.Bluespec.Classic.AST.Builtin.Types++ Language.Bluespec.Lex+ Language.Bluespec.Pretty+ other-modules: Language.Bluespec.IntegerUtil+ Language.Bluespec.Log2+ Language.Bluespec.Prelude+ Language.Bluespec.Util+ default-extensions: NoImplicitPrelude+ build-depends: base >= 4.12 && < 5+ , containers >= 0.1 && < 0.7+ , pretty >= 1.1.2 && < 1.2+ , text >= 0.1 && < 2.2++ if !impl(ghc >= 9.0)+ build-depends: integer-gmp+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall
+ src/Language/Bluespec/Classic/AST.hs view
@@ -0,0 +1,27 @@+module Language.Bluespec.Classic.AST+ ( module Language.Bluespec.Classic.AST.FString+ , module Language.Bluespec.Classic.AST.Id+ , module Language.Bluespec.Classic.AST.IntLit+ , module Language.Bluespec.Classic.AST.Literal+ , module Language.Bluespec.Classic.AST.Position+ , module Language.Bluespec.Classic.AST.Pragma+ , module Language.Bluespec.Classic.AST.SchedInfo+ , module Language.Bluespec.Classic.AST.SString+ , module Language.Bluespec.Classic.AST.Syntax+ , module Language.Bluespec.Classic.AST.Type+ , module Language.Bluespec.Classic.AST.Undefined+ , module Language.Bluespec.Classic.AST.VModInfo+ ) where++import Language.Bluespec.Classic.AST.FString+import Language.Bluespec.Classic.AST.Id+import Language.Bluespec.Classic.AST.IntLit+import Language.Bluespec.Classic.AST.Literal+import Language.Bluespec.Classic.AST.Position+import Language.Bluespec.Classic.AST.Pragma+import Language.Bluespec.Classic.AST.SchedInfo+import Language.Bluespec.Classic.AST.SString+import Language.Bluespec.Classic.AST.Syntax+import Language.Bluespec.Classic.AST.Type+import Language.Bluespec.Classic.AST.Undefined+import Language.Bluespec.Classic.AST.VModInfo
+ src/Language/Bluespec/Classic/AST/Builtin/FStrings.hs view
@@ -0,0 +1,516 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+-- This corresponds to src/Comp/PreStrings.hs in bsc.+module Language.Bluespec.Classic.AST.Builtin.FStrings where++import Language.Bluespec.Classic.AST.FString+import Language.Bluespec.Prelude+import Language.Bluespec.Util++fsEmpty = mkFString ""+fsUnderscore = mkFString "_"+fsUnderUnder = mkFString "__"+fsDot = mkFString "."+fsRArrow = mkFString "->"+fsBar = mkFString "|"+fsStar = mkFString "*"+fsSlash = mkFString "/"+fsPercent = mkFString "%"+fsStarStar = mkFString "**"+fsHash = mkFString "#"+fsTilde = mkFString "~"+fsTyJoin = mkFString "_$"+fsAssign = mkFString ":="+fsDollar = mkFString "$"+fsLT = mkFString "<"+fsGT = mkFString ">"+fsLTGT = mkFString "<>"+fsComma = mkFString ","+fsPlus = mkFString "+"+fsMinus = mkFString "-"+fsLsh = mkFString "<<"+fsRsh = mkFString ">>"+fsLtEq = mkFString "<="+fsGtEq = mkFString ">="+-- | Scheduling conflict operator for Classic+fsConfOp = mkFString "><"+fsPrelude = mkFString "Prelude"+fsPreludeBSV = mkFString "PreludeBSV"+fsPrimUnit = mkFString "PrimUnit"+fsBit = mkFString "Bit"+fsInt = mkFString "Int"+fsUInt = mkFString "UInt"+fsClock = mkFString "Clock"+fsClockOsc = mkFString "osc"+fsClockGate = mkFString "gate"+fsReset = mkFString "Reset"+fsInout = mkFString "Inout"+fsInout_ = mkFString "Inout_"+fsPrimInoutCast = mkFString "primInoutCast"+fsPrimInoutUncast = mkFString "primInoutUncast"+fsPrimInoutCast0 = mkFString "primInoutCast0"+fsPrimInoutUncast0 = mkFString "primInoutUncast0"+fsInteger = mkFString "Integer"+fsReal = mkFString "Real"+fsMonad = mkFString "Monad"+fsString = mkFString "String"+fsChar = mkFString "Char"+fsHandle = mkFString "Handle"+fsBufferMode = mkFString "BufferMode"+fsNoBuffering = mkFString "NoBuffering"+fsLineBuffering = mkFString "LineBuffering"+fsBlockBuffering = mkFString "BlockBuffering"+fsFmt = mkFString "Fmt"+fsPrimFmtConcat = mkFString "primFmtConcat"+fsPrimPriMux = mkFString "primPriMux"+fsFormat = mkFString "$format"+fsFShow = mkFString "FShow"+fsfshow = mkFString "fshow"+fsBool = mkFString "Bool"+fsPrimFst = mkFString "fst"+fsPrimSnd = mkFString "snd"+fsPrimPair = mkFString "PrimPair"+fsTrue = mkFString "True"+fsFalse = mkFString "False"+fsSizeOf = mkFString "SizeOf"+fsEq = mkFString "Eq"+fsBits = mkFString "Bits"+fsLiteral = mkFString "Literal"+fsRealLiteral = mkFString "RealLiteral"+fsSizedLiteral = mkFString "SizedLiteral"+fsStringLiteral = mkFString "StringLiteral"+fsPrimParam = mkFString "PrimParam"+fsPrimPort = mkFString "PrimPort"+fsPrimToParam = mkFString "primToParam"+fsPrimToPort = mkFString "primToPort"+fsPrimSeqCond = mkFString "primSeqCond"+fsPrimDeepSeqCond = mkFString "primDeepSeqCond"+fsClsDeepSeqCond = mkFString "PrimDeepSeqCond"+fsUndefined = mkFString "PrimMakeUndefined"+fsBuildUndef = mkFString "primBuildUndefined"+fsMakeUndef = mkFString "primMakeUndefined"+fsRawUndef = mkFString "primMakeRawUndefined"+fsEqual = mkFString "=="+fsNotEqual = mkFString "/="+fsPrimOrd = mkFString "primOrd"+fsPrimChr = mkFString "primChr"+fsPack = mkFString "pack"+fsUnpack = mkFString "unpack"+fsVReg = mkFString "VReg"+fsReg = mkFString "Reg"+fsRWire = mkFString "RWire"+fsPulseWire = mkFString "PulseWire"+fsFIFO = mkFString "FIFO"+fsFIFOF = mkFString "FIFOF"+fsAction = mkFString "Action"+fsPrimAction = mkFString "PrimAction"+fsToPrimAction = mkFString "toPrimAction"+fsFromPrimAction = mkFString "fromPrimAction"+fsToActionValue_ = mkFString "toActionValue_"+fsFromActionValue_ = mkFString "fromActionValue_"+fsActionValue = mkFString "ActionValue"+fsAVValue = mkFString "avValue"+fsAVAction = mkFString "avAction"+fsActionValue_ = mkFString "ActionValue_"+fsAVValue_ = mkFString "avValue_"+fsAVAction_ = mkFString "avAction_"+fs__value = mkFString "__value"+fs__action = mkFString "__action"+fsMethodReturn = mkFString "method_return"+fsRules = mkFString "Rules"+fsSchedPragma = mkFString "SchedPragma"+fsModule = mkFString "Module"+fsId = mkFString "Id__"+fsPred = mkFString "Pred__"+fsIsModule = mkFString "IsModule"+fsPrimModule = mkFString "primModule"+fsName = mkFString "Name__"+fsGetModuleName = mkFString "primGetModuleName"+fsPosition = mkFString "Position__"+fsType = mkFString "Type"+fsTypeOf = mkFString "typeOf"+fsSavePortType = mkFString "primSavePortType"+fsPrintType = mkFString "printType"+fsNoPosition = mkFString "noPosition"+fsPrimGetEvalPosition = mkFString "primGetEvalPosition"+fsPrimGetName = mkFString "primGetName"+fsPrimGetParamName = mkFString "primGetParamName"+fsPrimJoinNames = mkFString "primJoinNames"+fsPrimExtNameIdx = mkFString "primExtendNameIndex"+fsSetStateName = mkFString "setStateName"+fsForceIsModule = mkFString "forceIsModule"+fsAttributes = mkFString "Attributes__"+fsSetStateAttrib = mkFString "setStateAttrib"+fsAdd = mkFString "Add"+fsMax = mkFString "Max"+fsMin = mkFString "Min"+fsLog = mkFString "Log"+fsMul = mkFString "Mul"+fsDiv = mkFString "Div"+fsNumEq = mkFString "NumEq"+fsAnd = mkFString "&&"+fsOr = mkFString "||"+fsBitAnd = mkFString "&"+fsBitOr = mkFString "|"+fsCaret = mkFString "^"+fsTildeCaret = mkFString "~^"+fsCaretTilde = mkFString "^~"+fsReduceAnd = mkFString "reduceAnd"+fsReduceOr = mkFString "reduceOr"+fsReduceXor = mkFString "reduceXor"+fsReduceNand = mkFString "reduceNand"+fsReduceNor = mkFString "reduceNor"+fsReduceXnor = mkFString "reduceXnor"+fsNot = mkFString "not"+fsPrimSplit = mkFString "primSplit"+fsPrimConcat = mkFString "primConcat"+fsPrimMul = mkFString "primMul"+fsPrimQuot = mkFString "primQuot"+fsPrimRem = mkFString "primRem"+fsPrimTrunc = mkFString "primTrunc"+fs_lam = mkFString "_lam"+fs_if = mkFString "_if"+fs_read = mkFString "_read"+fs_write = mkFString "_write"+fsAsIfc = mkFString "asIfc"+fsAsReg = mkFString "asReg"+fsRead = mkFString "read"+fsRegWrite = mkFString "write"+fsExtract = mkFString "primExtract"+fsFromInteger = mkFString "fromInteger"+fsFromReal = mkFString "fromReal"+fsFromSizedInteger = mkFString "fromSizedInteger"+fsFromString = mkFString "fromString"+fsPrimCharToString = mkFString "primCharToString"+fs_case = mkFString "_case"+fsPrimWhen = mkFString "_when"+fsBind = mkFString "bind"+fsBind_ = mkFString "bind_"+fsReturn = mkFString "return"+fs_x = mkFString "_x"+fs_y = mkFString "_y"+fs_fun = mkFString "_fun"+fs_forallb = mkFString "_forallb"+fsBounded = mkFString "Bounded"+fsMaxBound = mkFString "maxBound"+fsMinBound = mkFString "minBound"+fsDefaultValue = mkFString "DefaultValue"+fs_defaultValue = mkFString "defaultValue"+fsPrimSplitFst = mkFString "primSplitFst"+fsPrimSplitSnd = mkFString "primSplitSnd"+fsTo = mkFString "to"+fsFrom = mkFString "from"+fs_t = mkFString "_t"+fsMux = mkFString "MUX_"+fsMuxSel = mkFString "SEL"+fsMuxPreSel = mkFString "PSEL"+fsMuxVal = mkFString "VAL"+fsEnable = mkFString "EN_"+fs_rdy = mkFString "RDY_"+fs_rl = mkFString "RL_"+fs_unnamed = mkFString "unnamed"+s_unnamed = "unnamed"+fs_T = mkFString "_T"+fs_F = mkFString "_F"+fsCanFire = mkFString "CAN_FIRE_"+fsWillFire = mkFString "WILL_FIRE_"+fsCLK = mkFString "CLK"+fsCLK_GATE = mkFString "CLK_GATE"+-- fsRSTN = mkFString "RST"+fsDefaultClock = mkFString "default_clock"+fsDefaultReset = mkFString "default_reset"+fsPrimStringConcat = mkFString "primStringConcat"+fsNoinline = mkFString "noinline"+fsLiftM = mkFString "liftM"+fsLiftModule = mkFString "liftModule"+fsPrimBAnd = mkFString "primBAnd"+fsPrimBOr = mkFString "primBOr"+fsPrimBNot = mkFString "primBNot"+fsPrimIf = mkFString "primIf"+fsPrimCase = mkFString "primCase"+fsPrimArrayDynSelect = mkFString "primArrayDynSelect"+fsPrimBuildArray = mkFString "primBuildArray"+fsPrimSelect = mkFString "primSelect"+fsPrimSelectable = mkFString "PrimSelectable"+fsPrimUpdateable = mkFString "PrimUpdateable"+fsPrimWriteable = mkFString "PrimWriteable"+fsPrimSelectFn = mkFString "primSelectFn"+fsPrimUpdateFn = mkFString "primUpdateFn"+fsPrimWriteFn = mkFString "primWriteFn"+fsPrimIndex = mkFString "PrimIndex"+fsPrimUpdateRangeFn = mkFString "primUpdateRangeFn"+fsPrimZeroExt = mkFString "primZeroExt"+fsPrimSignExt = mkFString "primSignExt"+fsPrimValueOf = mkFString "primValueOf"+fsPrimStringOf = mkFString "primStringOf"+fsStringProxy = mkFString "StringProxy"+fsPrimJoinRules = mkFString "primJoinRules"+fsPrimNoRules = mkFString "primNoRules"+fsPrimRule = mkFString "primRule"+fsPrimAddSchedPragmas = mkFString "primAddSchedPragmas"+fsPrimJoinActions = mkFString "primJoinActions"+fsPrimNoActions = mkFString "primNoActions"+fsPrimNoExpIf = mkFString "primNoExpIf"+fsPrimExpIf = mkFString "primExpIf"+fsPrimNosplitDeep = mkFString "primNosplitDeep"+fsPrimSplitDeep = mkFString "primSplitDeep"+fsSplitDeepAV = mkFString "splitDeepAV"+fsNosplitDeepAV = mkFString "nosplitDeepAV"+fsPrimInv = mkFString "primInv"+fsPrimEQ = mkFString "primEQ"+fsPrimULE = mkFString "primULE"+fsPrimULT = mkFString "primULT"+fsPrimSLE = mkFString "primSLE"+fsPrimSLT = mkFString "primSLT"+fsPrimSL = mkFString "primSL"+fsPrimSRL = mkFString "primSRL"+fsPrimAdd = mkFString "primAdd"+fsPrimSub = mkFString "primSub"+fsClsUninitialized = mkFString "PrimMakeUninitialized"+fsPrimUninitialized = mkFString "primUninitialized"+fsPrimMakeUninitialized = mkFString "primMakeUninitialized"+fsPrimRawUninitialized= mkFString "primMakeRawUninitialized"+fsPrimPoisonedDef = mkFString "primPoisonedDef"+fsChangeSpecialWires = mkFString "changeSpecialWires"+fsPrimSetSelPosition = mkFString "primSetSelPosition"+fsTAdd = mkFString "TAdd"+fsTSub = mkFString "TSub"+fsTMul = mkFString "TMul"+fsTDiv = mkFString "TDiv"+fsTLog = mkFString "TLog"+fsTExp = mkFString "TExp"+fsTMax = mkFString "TMax"+fsTMin = mkFString "TMin"+fsStaticAssert = mkFString "staticAssert"+fsDynamicAssert = mkFString "dynamicAssert"+fsContinuousAssert = mkFString "continuousAssert"+fs_staticAssert = mkFString "_staticAssert"+fs_dynamicAssert = mkFString "_dynamicAssert"+fs_continuousAssert= mkFString "_continuousAssert"+fsAddRules = mkFString "addRules"+fsASSERT = mkFString "ASSERT"+fsFire = mkFString "fire"+fsEnabled = mkFString "enabled"+fsNo = mkFString "no"+fsImplicit = mkFString "implicit"+fsConditions = mkFString "conditions"+fsCan = mkFString "can"+fsSchedule = mkFString "schedule"+fsFirst = mkFString "first"+fsClockCrossing = mkFString "clock-crossing"+fsAggressiveImplicitConditions = mkFString "aggressive_implicit_conditions"+fsConservativeImplicitConditions = mkFString "conservative_implicit_conditions"+fsNoWarn = mkFString "no_warn"+fsWarnAllConflicts = mkFString "warn_all_conflicts"+fsRule = mkFString "rule"+fsMkRegU = mkFString "mkRegU"+fsPrimFix = mkFString "primFix"+fsMfix = mkFString "mfix"+fsFmap = mkFString "fmap"+fsNegate = mkFString "negate"+fsIdentity = mkFString "id"+fsInvert = mkFString "invert"+fsEmptyIfc = mkFString "Empty"+fs1 = mkFString "1"+fsB = mkFString "B"+fsR = mkFString "R"+fsExposeCurrentClock = mkFString "exposeCurrentClock"+fsExposeCurrentReset = mkFString "exposeCurrentReset"+fsNoClock = mkFString "noClock"+fsNoReset = mkFString "noReset"+fsPrimReplaceClockGate = mkFString "primReplaceClockGate"+fsVRWireN = mkFString "VRWireN"+fsVmkRWire1 = mkFString "vMkRWire1"+fsWGet = mkFString "wget"+fsWSet = mkFString "wset"+fsWHas = mkFString "whas"+fsSend = mkFString "send"+fsFIFO_notFull = mkFString "i_notFull"+fsFIFO_notEmpty = mkFString "i_notEmpty"+fsFIFOEnq = mkFString "enq"+fsFIFODeq = mkFString "deq"+fsFIFOFirst = mkFString "first"+fsGeneric = mkFString "Generic"+fsConc = mkFString "Conc"+fsConcPrim = mkFString "ConcPrim"+fsConcPoly = mkFString "ConcPoly"+fsMeta = mkFString "Meta"+fsMetaData = mkFString "MetaData"+fsStarArg = mkFString "StarArg"+fsNumArg = mkFString "NumArg"+fsStrArg = mkFString "StrArg"+fsConArg = mkFString "ConArg"+fsMetaConsNamed = mkFString "MetaConsNamed"+fsMetaConsAnon = mkFString "MetaConsAnon"+fsMetaField = mkFString "MetaField"+fsPolyWrapField = mkFString "val"++-- XXX low ASCII only, please...+sAcute = "__"+fsAcute = mkFString sAcute+fsTheResult = mkFString "_theResult__"+fsF = mkFString "_f__"+fsM = mkFString "_m__"+fsC = mkFString "_c__"+fsClk = mkFString "_clk__"+fsRst = mkFString "_rst__"+fsList = mkFString "List"+fsPrimArray = mkFString "Array"+fsPrimArrayNew = mkFString "primArrayNew"+fsPrimArrayNewU = mkFString "primArrayNewU"+fsPrimArrayLength = mkFString "primArrayLength"+fsPrimArrayInitialize = mkFString "primArrayInitialize"+fsPrimArrayCheck = mkFString "primArrayCheck"+fsListN = mkFString "ListN"+fsVector = mkFString "Vector"+fsToVector = mkFString "toVector"+fsToListN = mkFString "toListN"+fsSAction = mkFString "SAction"+fsSActionValue = mkFString "SActionValue"+fsStmtify = mkFString "stmtify"+fsCallServer = mkFString "callServer"+fsSIf1 = mkFString "SIf1"+fsSIf2 = mkFString "SIf2"+fsSAbtIf1 = mkFString "SAbtIf1"+fsSAbtIf2 = mkFString "SAbtIf2"+fsSRepeat = mkFString "SRepeat"+fsSWhile = mkFString "SWhile"+fsSFor = mkFString "SFor"+fsSSeq = mkFString "SSeq"+fsSPar = mkFString "SPar"+fsSLabel = mkFString "SLabel"+fsSJump = mkFString "SJump"+fsSNamed = mkFString "SNamed"+fsS = mkFString "S"+fsStmt = mkFString "stmt"+fsSBreak = mkFString "SBreak"+fsSContinue = mkFString "SContinue"+fsSReturn = mkFString "SReturn"+fsCons = mkFString "Cons"+fsConcat = mkFString "concat"+fsNil = mkFString "Nil"+fsNothing = mkFString "Nothing"+fsSprime = mkFString "_s__"+fsMaybe = mkFString "Maybe"+fsInvalid = mkFString "Invalid"+fsValid = mkFString "Valid"+fsEither = mkFString "Either"+fsLeft = mkFString "Left"+fsRight = mkFString "Right"+-- | Names used for tuple fields internally?+fsTuples = map mkFString ["_"++ itos i | i <- [1..25::Int]]+-- | Names exposed to the BSV user+fsTuple2 = mkFString "Tuple2"+fsTuple3 = mkFString "Tuple3"+fsTuple4 = mkFString "Tuple4"+fsTuple5 = mkFString "Tuple5"+fsTuple6 = mkFString "Tuple6"+fsTuple7 = mkFString "Tuple7"+fsTuple8 = mkFString "Tuple8"+fsConstAllBitsSet = mkFString "constantWithAllBitsSet"+fsConstAllBitsUnset= mkFString "constantWithAllBitsUnset"+fs_the_ = mkFString "the_"+s__fire = "_fire"+fs__fire = mkFString s__fire+++fsPrimError = mkFString "primError"++-- XXX should be a system task?+fsError = mkFString "error"++-- system task strings+fsFinish = mkFString "$finish"+fsStop = mkFString "$stop"+fsDisplay = mkFString "$display"+fsDisplayh = mkFString "$displayh"+fsDisplayb = mkFString "$displayb"+fsDisplayo = mkFString "$displayo"+fsWrite = mkFString "$write"+fsWriteh = mkFString "$writeh"+fsWriteb = mkFString "$writeb"+fsWriteo = mkFString "$writeo"++fsFDisplay = mkFString "$fdisplay"+fsFDisplayh = mkFString "$fdisplayh"+fsFDisplayb = mkFString "$fdisplayb"+fsFDisplayo = mkFString "$fdisplayo"+fsFWrite = mkFString "$fwrite"+fsFWriteh = mkFString "$fwriteh"+fsFWriteb = mkFString "$fwriteb"+fsFWriteo = mkFString "$fwriteo"+fsSWriteAV = mkFString "$swriteAV"+fsSWrite = mkFString "$swrite"+fsSWritehAV = mkFString "$swritehAV"+fsSWriteh = mkFString "$swriteh"+fsSWritebAV = mkFString "$swritebAV"+fsSWriteb = mkFString "$swriteb"+fsSWriteoAV = mkFString "$swriteoAV"+fsSWriteo = mkFString "$swriteo"+fsSFormatAV = mkFString "$sformatAV"+fsSFormat = mkFString "$sformat"++fsErrorTask = mkFString "$error"+fsWarnTask = mkFString "$warning"+fsInfoTask = mkFString "$info"+fsFatalTask = mkFString "$fatal"++fsSVA = mkFString "$SVA"+fsSvaParam = mkFString "SvaParam"+fsSvaBool = mkFString "SvaBool"+fsSvaNumber = mkFString "SvaNumber"++fsSVAsampled = mkFString "$sampled"+fsSVArose = mkFString "$rose"+fsSVAfell = mkFString "$fell"+fsSVAstable = mkFString "$stable"+fsSVApast = mkFString "$past"+fsSVAonehot = mkFString "$onehot"+fsSVAonehot0 = mkFString "$onehot0"+fsSVAisunknown = mkFString "$isunknown"+fsSVAcountones = mkFString "$countones"++fsRandom = mkFString "$random"++fsDumpon = mkFString "$dumpon"+fsDumpoff = mkFString "$dumpoff"+fsDumpvars = mkFString "$dumpvars"+fsDumpall = mkFString "$dumpall"+fsDumplimit = mkFString "$dumplimit"+fsDumpflush = mkFString "$dumpflush"+fsDumpfile = mkFString "$dumpfile"+fsSigned = mkFString "$signed"+sSigned = "$signed"+fsUnsigned = mkFString "$unsigned"+sUnsigned = "$unsigned"+fsTime = mkFString "$time"+fsSTime = mkFString "$stime"+fsFOpen = mkFString "$fopen"+fsFGetc = mkFString "$fgetc"+fsUngetc = mkFString "$ungetc"+fsFClose = mkFString "$fclose"+fsFFlush = mkFString "$fflush"+fsTestPlusargs = mkFString "$test$plusargs"+fsRealToBits = mkFString "$realtobits"+fsBitsToReal = mkFString "$bitstoreal"++fsFile = mkFString "File"+++-- | Classes hardcoded in the Prelude which were added for ContextErrors+fsBitwise, fsBitReduce, fsBitExtend, fsArith, fsOrd :: FString+fsBitwise = mkFString "Bitwise"+fsBitReduce = mkFString "BitReduction"+fsBitExtend = mkFString "BitExtend"+fsArith = mkFString "Arith"+fsOrd = mkFString "Ord"++-- | Nice display names for instance hierarchy+fsLoop, fsBody :: FString+fsLoop = mkFString "Loop"+fsBody = mkFString "Body"++fsHide, fsHideAll, fsElements, fsvElements :: FString+fsHide = mkFString "hide"+fsHideAll = mkFString "hide_all"+fsElements = mkFString "_elements"+fsvElements = mkFString "_velements"
+ src/Language/Bluespec/Classic/AST/Builtin/Ids.hs view
@@ -0,0 +1,735 @@+-- This corresponds to src/Comp/PreIds.hs in bsc.+module Language.Bluespec.Classic.AST.Builtin.Ids where++import Language.Bluespec.Classic.AST.Builtin.FStrings+import Language.Bluespec.Classic.AST.FString+import Language.Bluespec.Classic.AST.Id+import Language.Bluespec.Classic.AST.Position+import Language.Bluespec.Prelude++-- | Identifier without a position+mk_no :: FString -> Id+mk_no fs = mkId noPosition fs++-- | Identifier in the Standard Prelude, with a position+prelude_id :: Position -> FString -> Id+prelude_id p fs = mkQId p fsPrelude fs++-- | Identifier in the Standard Prelude, with no position+prelude_id_no :: FString -> Id+prelude_id_no fs = prelude_id noPosition fs++-- | Identifier in the Standard Prelude, with a position+prelude_bsv_id :: Position -> FString -> Id+prelude_bsv_id p fs = mkQId p fsPreludeBSV fs++-- | Identifier in the Standard Prelude, with no position+prelude_bsv_id_no :: FString -> Id+prelude_bsv_id_no fs = prelude_bsv_id noPosition fs++-- | Add id properties to an already existing identifier+prop_prelude_id_no :: FString -> [IdProp] -> Id+prop_prelude_id_no fs props =+ addIdProps (prelude_id (updatePosStdlib noPosition True) fs) props++idB, idR :: Id+idB = prelude_id_no fsB+idR = prelude_id_no fsR+idArrow :: Position -> Id+idArrow p = prelude_id p fsRArrow+idPrimUnit, idBit, idInt, idUInt, idVReg, idReg, idRWire, idPulseWire :: Id+idPrimUnit = prelude_id_no fsPrimUnit+idBit = prelude_id_no fsBit+idInt = prelude_id_no fsInt+idUInt = prelude_id_no fsUInt+idVReg = prelude_id_no fsVReg+idReg = prelude_id_no fsReg+idRWire = prelude_bsv_id_no fsRWire+idPulseWire = prelude_bsv_id_no fsPulseWire+idFIFO, idFIFOF, idSend, id_notFull, id_notEmpty, idEnq, idDeq, idFirst :: Id+idFIFO = mkQId noPosition fsFIFO fsFIFO+idFIFOF = mkQId noPosition fsFIFOF fsFIFOF+idSend = prelude_bsv_id_no fsSend+id_notFull = mk_no fsFIFO_notFull+id_notEmpty = mk_no fsFIFO_notEmpty+idEnq = mk_no fsFIFOEnq+idDeq = mk_no fsFIFODeq+idFirst = mk_no fsFIFOFirst+idInteger, idReal :: Id+idInteger = prelude_id_no fsInteger+idReal = prelude_id_no fsReal+idRealAt :: Position -> Id+idRealAt pos = prelude_id pos fsReal+idString, idChar, idHandle, idBufferMode, idNoBuffering, idLineBuffering :: Id+idString = prelude_id_no fsString+idChar = prelude_id_no fsChar+idHandle = prelude_id_no fsHandle+idBufferMode = prelude_id_no fsBufferMode+idNoBuffering = prelude_id_no fsNoBuffering+idLineBuffering = prelude_id_no fsLineBuffering+idBlockBuffering, idFmt, idPrimFmtConcat, idPrimPriMux, idFormat, idFShow :: Id+idBlockBuffering = prelude_id_no fsBlockBuffering+idFmt = prelude_id_no fsFmt+idPrimFmtConcat = prelude_id_no fsPrimFmtConcat+idPrimPriMux = prelude_id_no fsPrimPriMux+idFormat = prelude_id_no fsFormat+idFShow = prelude_id_no fsFShow+idfshow, idBool, idPrimFst, idPrimSnd, idPrimPair, idFalse, idTrue :: Id+idfshow = prelude_id_no fsfshow+idBool = prelude_id_no fsBool+idPrimFst = prelude_id_no fsPrimFst+idPrimSnd = prelude_id_no fsPrimSnd+idPrimPair = prelude_id_no fsPrimPair+idFalse = prelude_id_no fsFalse+idTrue = prelude_id_no fsTrue+idSizeOf, idTAdd, idTSub, idTMul, idTDiv, idTLog, idTExp, idTMax, idTMin :: Id+idSizeOf = prelude_id_no fsSizeOf+idTAdd = prelude_id_no fsTAdd+idTSub = prelude_id_no fsTSub+idTMul = prelude_id_no fsTMul+idTDiv = prelude_id_no fsTDiv+idTLog = prelude_id_no fsTLog+idTExp = prelude_id_no fsTExp+idTMax = prelude_id_no fsTMax+idTMin = prelude_id_no fsTMin+idAction, idPrimAction, idToPrimAction, idFromPrimAction :: Id+idAction = prelude_id_no fsAction+idPrimAction = prelude_id_no fsPrimAction+idToPrimAction = prelude_id_no fsToPrimAction+idFromPrimAction = prelude_id_no fsFromPrimAction+idFromActionValue_, idToActionValue_, idRules, idSchedPragma, idValueOf, idStringOf, idStringProxy :: Id+idFromActionValue_ = prelude_id_no fsFromActionValue_+idToActionValue_ = prelude_id_no fsToActionValue_+idRules = prelude_id_no fsRules+idSchedPragma = prelude_id_no fsSchedPragma+idValueOf = prelude_id_no fsPrimValueOf+idStringOf = prelude_id_no fsPrimStringOf+idStringProxy = prelude_id_no fsStringProxy+idPrimIndex, idPrimSelectable, idPrimUpdateable, idPrimWriteable :: Id+idPrimIndex = prelude_id_no fsPrimIndex+idPrimSelectable = prelude_id_no fsPrimSelectable+idPrimUpdateable = prelude_id_no fsPrimUpdateable+idPrimWriteable = prelude_id_no fsPrimWriteable+idChangeSpecialWires :: Position -> Id+idChangeSpecialWires pos = prelude_id pos fsChangeSpecialWires+idPrimSetSelPosition, idMaybe, idInvalid, idValid, idEmpty, idFile :: Id+idPrimSetSelPosition = prelude_id_no fsPrimSetSelPosition+idMaybe = prelude_id_no fsMaybe+idInvalid = prelude_id_no fsInvalid+idValid = prelude_id_no fsValid+idEmpty = prelude_id_no fsEmptyIfc+idFile = prelude_id_no fsFile+idEither, idLeft, idRight :: Id+idEither = prelude_id_no fsEither+idLeft = prelude_id_no fsLeft+idRight = prelude_id_no fsRight++idActionValue :: Id+idActionValue = prelude_id_no fsActionValue+-- field names for the ActionValue interface+idAVValue, idAVAction :: Id+idAVValue = prelude_id_no fsAVValue+idAVAction = prelude_id_no fsAVAction++idActionValue_ :: Id+idActionValue_ = prelude_id_no fsActionValue_+-- field names for the ActionValue_ interface+idAVValue_, idAVAction_ :: Id+idAVValue_ = prelude_id_no fsAVValue_+idAVAction_ = prelude_id_no fsAVAction_++-- names of the special selector functions in the Prelude+id__value, id__action :: Id+id__value = prelude_id_no fs__value+id__action = prelude_id_no fs__action+id__value_at, id__action_at :: Position -> Id+id__value_at pos = prelude_id pos fs__value+id__action_at pos = prelude_id pos fs__action++idComma, idPlus, idMinus, idPrelude, idPreludeBSV :: Id+idComma = mk_no fsComma+idPlus = mk_no fsPlus+idMinus = mk_no fsMinus+idPrelude = mk_no fsPrelude+idPreludeBSV = mk_no fsPreludeBSV++idPreludePlus :: Id+idPreludePlus = prelude_id_no fsPlus++-- Used by deriving+idEq, idBits, idLiteral, idRealLiteral, idSizedLiteral, idStringLiteral :: Id+idEq = prelude_id_no fsEq+idBits = prelude_id_no fsBits+idLiteral = prelude_id_no fsLiteral+idRealLiteral = prelude_id_no fsRealLiteral+idSizedLiteral = prelude_id_no fsSizedLiteral+idStringLiteral = prelude_id_no fsStringLiteral+idPrimParam, idPrimPort, idBounded, idDefaultValue, id_defaultValue, idClsDeepSeqCond, idPrimDeepSeqCond :: Id+idPrimParam = prelude_id_no fsPrimParam+idPrimPort = prelude_id_no fsPrimPort+idBounded = prelude_id_no fsBounded+idDefaultValue = prelude_id_no fsDefaultValue+id_defaultValue = prelude_id_no fs_defaultValue+idClsDeepSeqCond = prelude_id_no fsClsDeepSeqCond+idPrimDeepSeqCond = prelude_id_no fsPrimDeepSeqCond+idPrimSeqCond, idUndefined, idEqual, idNotEqual, idPack, idUnpack, idFmap :: Id+idPrimSeqCond = prelude_id_no fsPrimSeqCond+idUndefined = prelude_id_no fsUndefined+idEqual = prelude_id_no fsEqual+idNotEqual = prelude_id_no fsNotEqual+idPack = prelude_id_no fsPack+idUnpack = prelude_id_no fsUnpack+idFmap = prelude_id_no fsFmap+idMaxBound, idMinBound, idBuildUndef, idMakeUndef, idRawUndef, idAdd :: Id+idMaxBound = prelude_id_no fsMaxBound+idMinBound = prelude_id_no fsMinBound+idBuildUndef = prelude_id_no fsBuildUndef+idMakeUndef = prelude_id_no fsMakeUndef+idRawUndef = prelude_id_no fsRawUndef+idAdd = prop_prelude_id_no fsAdd [IdPCommutativeTCon]+idMax, idMin, idLog, idMul, idDiv, idNumEq, idAnd, idNot, idPrimSplit :: Id+idMax = prop_prelude_id_no fsMax [IdPCommutativeTCon]+idMin = prop_prelude_id_no fsMin [IdPCommutativeTCon]+idLog = prelude_id_no fsLog+idMul = prop_prelude_id_no fsMul [IdPCommutativeTCon]+idDiv = prelude_id_no fsDiv+idNumEq = prop_prelude_id_no fsNumEq [IdPCommutativeTCon]+idAnd = prelude_id_no fsAnd+idNot = prelude_id_no fsNot+idPrimSplit = prelude_id_no fsPrimSplit+idPrimConcat, idPrimMul, idPrimQuot, idPrimRem, idPrimTrunc, idPrimOrd :: Id+idPrimConcat = prelude_id_no fsPrimConcat+idPrimMul = prelude_id_no fsPrimMul+idPrimQuot = prelude_id_no fsPrimQuot+idPrimRem = prelude_id_no fsPrimRem+idPrimTrunc = prelude_id_no fsPrimTrunc+idPrimOrd = prelude_id_no fsPrimOrd+idPrimChr, idLiftM, idPrimError :: Id+idPrimChr = prelude_id_no fsPrimChr+idLiftM = prelude_id_no fsLiftM+idPrimError = prelude_id_no fsPrimError+idGeneric, idFrom, idTo, idConc, idConcPrim, idConcPoly, idMeta :: Id+idGeneric = prelude_id_no fsGeneric+idFrom = prelude_id_no fsFrom+idTo = prelude_id_no fsTo+idConc = prelude_id_no fsConc+idConcPrim = prelude_id_no fsConcPrim+idConcPoly = prelude_id_no fsConcPoly+idMeta = prelude_id_no fsMeta+idMetaData, idStarArg, idNumArg, idStrArg, idConArg, idMetaConsNamed, idMetaConsAnon, idMetaField :: Id+idMetaData = prelude_id_no fsMetaData+idStarArg = prelude_id_no fsStarArg+idNumArg = prelude_id_no fsNumArg+idStrArg = prelude_id_no fsStrArg+idConArg = prelude_id_no fsConArg+idMetaConsNamed = prelude_id_no fsMetaConsNamed+idMetaConsAnon = prelude_id_no fsMetaConsAnon+idMetaField = prelude_id_no fsMetaField+idPolyWrapField :: Id+idPolyWrapField = mk_no fsPolyWrapField++-- | Used by GenWrap for "polymorphic" modules+idLiftModule :: Id+idLiftModule = prelude_id_no fsLiftModule++-- Used by desugaring+id_lam, id_if, id_read, id_write :: Position -> Id+id_lam pos = mkId pos fs_lam+id_if pos = mkId pos fs_if+id_read pos = mkId pos fs_read+id_write pos = mkId pos fs_write+idPreludeRead, idPreludeWrite, idAssign :: Id+idPreludeRead = prelude_id_no fsRead+idPreludeWrite = prelude_id_no fsRegWrite+idAssign = mkId noPosition fsAssign+idExtract, idFromInteger, idFromReal, idFromSizedInteger :: Position -> Id+idExtract pos = prelude_id pos fsExtract+idFromInteger pos = prelude_id pos fsFromInteger+idFromReal pos = prelude_id pos fsFromReal+idFromSizedInteger pos = prelude_id pos fsFromSizedInteger+idFromString, idPrimCharToString, idPrimToParam, idPrimToPort :: Position -> Id+idFromString pos = prelude_id pos fsFromString+idPrimCharToString pos = prelude_id pos fsPrimCharToString+idPrimToParam pos = prelude_id pos fsPrimToParam+idPrimToPort pos = prelude_id pos fsPrimToPort+id_case, idBind, idBind_, idReturn, idMonad :: Position -> Id+id_case pos = mkId pos fs_case+idBind pos = prelude_id pos fsBind+idBind_ pos = prelude_id pos fsBind_+idReturn pos = prelude_id pos fsReturn+idMonad pos = prelude_id pos fsMonad+idIsModule, idModule, idId :: Id+idIsModule = prelude_id_no fsIsModule+idModule = prelude_id_no fsModule+idId = prelude_id_no fsId+idPrimModule :: Position -> Id+idPrimModule pos = prelude_id pos fsPrimModule+idPrimStringConcat :: Id+idPrimStringConcat = prelude_id_no fsPrimStringConcat+idAddRules, idMkRegU, idTheResult, idF, idM, idC :: Position -> Id+idAddRules pos = prelude_id pos fsAddRules+idMkRegU pos = prelude_id pos fsMkRegU+idTheResult pos = addIdProp (mkId pos fsTheResult) IdPRenaming+idF pos = mkId pos fsF+idM pos = mkId pos fsM+idC pos = mkId pos fsC+idPrimSelectFn, idPrimUpdateFn, idPrimWriteFn, idPrimUpdateRangeFn :: Position -> Id+idPrimSelectFn pos = mkId pos fsPrimSelectFn+idPrimUpdateFn pos = mkId pos fsPrimUpdateFn+idPrimWriteFn pos = mkId pos fsPrimWriteFn+idPrimUpdateRangeFn pos = prelude_id pos fsPrimUpdateRangeFn+idSAction, idSActionValue, idStmtify, idCallServer :: Position -> Id+idSAction pos = mkId pos fsSAction+idSActionValue pos = mkId pos fsSActionValue+idStmtify pos = mkId pos fsStmtify+idCallServer pos = mkId pos fsCallServer+idSIf1, idSIf2, idSAbtIf1, idSAbtIf2, idSRepeat, idSWhile, idSFor :: Position -> Id+idSIf1 pos = mkId pos fsSIf1+idSIf2 pos = mkId pos fsSIf2+idSAbtIf1 pos = mkId pos fsSAbtIf1+idSAbtIf2 pos = mkId pos fsSAbtIf2+idSRepeat pos = mkId pos fsSRepeat+idSWhile pos = mkId pos fsSWhile+idSFor pos = mkId pos fsSFor+idSSeq, idSPar, idSLabel, idSJump, idSNamed, idS, idStmt :: Position -> Id+idSSeq pos = mkId pos fsSSeq+idSPar pos = mkId pos fsSPar+idSLabel pos = mkId pos fsSLabel+idSJump pos = mkId pos fsSJump+idSNamed pos = mkId pos fsSNamed+idS pos = mkId pos fsS+idStmt pos = mkId pos fsStmt+idSBreak, idSContinue, idSReturn, idCons, idConcat :: Position -> Id+idSBreak pos = mkId pos fsSBreak+idSContinue pos = mkId pos fsSContinue+idSReturn pos = mkId pos fsSReturn+idCons pos = mkId pos fsCons+idConcat pos = mkId pos fsConcat+idNil, idNothing, idSprime :: Position -> Id+idNil pos = mkId pos fsNil+idNothing pos = mkId pos fsNothing+idSprime pos = mkId pos fsSprime++-- | Used to prevent implicit read etc.+idAsIfc, idAsReg :: Id+idAsIfc = prelude_id_no fsAsIfc+idAsReg = prelude_id_no fsAsReg++-- used to inject state names+idName, idPrimGetName :: Id+idName = prelude_id_no fsName+idPrimGetName = prelude_id_no fsPrimGetName+idPrimGetNameAt :: Position -> Id+idPrimGetNameAt pos = prelude_id pos fsPrimGetName+idPrimGetParamName :: Id+idPrimGetParamName = prelude_id_no fsPrimGetParamName+idPrimGetParamNameAt, idPrimJoinNamesAt, idPrimExtNameIdxAt, idSetStateNameAt :: Position -> Id+idPrimGetParamNameAt pos = prelude_id pos fsPrimGetParamName+idPrimJoinNamesAt pos = prelude_id pos fsPrimJoinNames+idPrimExtNameIdxAt pos = prelude_id pos fsPrimExtNameIdx+idSetStateNameAt pos = prelude_id pos fsSetStateName+idGetModuleName :: Id+idGetModuleName = prelude_id_no fsGetModuleName++-- | Used to force the monad in a "module" expression to be a module,+-- so that we fail fast for good error positions+idForceIsModuleAt :: Position -> Id+idForceIsModuleAt pos = prelude_id pos fsForceIsModule++-- | Use for communicating positions for errors, warnings and messages+idPosition, idNoPosition, idPrimGetEvalPosition :: Id+idPosition = prelude_id_no fsPosition+idNoPosition = prelude_id_no fsNoPosition+idPrimGetEvalPosition = prelude_id_no fsPrimGetEvalPosition++-- | Used to carry attributes+idAttributes :: Id+idAttributes = prelude_id_no fsAttributes+idSetStateAttribAt :: Position -> Id+idSetStateAttribAt pos = prelude_id pos fsSetStateAttrib++idType, idTypeOf, idSavePortType, idPrintType :: Id+idType = prelude_id_no fsType+idTypeOf = prelude_id_no fsTypeOf+idSavePortType = prelude_id_no fsSavePortType+idPrintType = prelude_id_no fsPrintType++-- | Abstract type for implicit conditions+idPred :: Id+idPred = prelude_id_no fsPred++-- Used by iConv+idPrimBAnd, idPrimBOr, idPrimBNot, idPrimSL, idPrimSRL :: Id+idPrimBAnd = prelude_id_no fsPrimBAnd+idPrimBOr = prelude_id_no fsPrimBOr+idPrimBNot = prelude_id_no fsPrimBNot+idPrimSL = prelude_id_no fsPrimSL+idPrimSRL = prelude_id_no fsPrimSRL+idPrimInv, idPrimIf, idPrimCase, idPrimArrayDynSelect, idPrimBuildArray :: Id+idPrimInv = prelude_id_no fsPrimInv+idPrimIf = prelude_id_no fsPrimIf+idPrimCase = prelude_id_no fsPrimCase+idPrimArrayDynSelect = prelude_id_no fsPrimArrayDynSelect+idPrimBuildArray = prelude_id_no fsPrimBuildArray+idPrimWhen, idPrimSelect :: Id+idPrimWhen = prelude_id_no fsPrimWhen+idPrimSelect = prelude_id_no fsPrimSelect+idPrimSelectAt :: Position -> Id+idPrimSelectAt pos = prelude_id pos fsPrimSelect+idPrimZeroExt, idPrimSignExt, idPrimJoinRules, idPrimNoRules, idPrimRule :: Id+idPrimZeroExt = prelude_id_no fsPrimZeroExt+idPrimSignExt = prelude_id_no fsPrimSignExt+idPrimJoinRules = prelude_id_no fsPrimJoinRules+idPrimNoRules = prelude_id_no fsPrimNoRules+idPrimRule = prelude_id_no fsPrimRule+idPrimJoinActions, idPrimAddSchedPragmas, idPrimNoActions, idPrimNoExpIf :: Id+idPrimJoinActions = prelude_id_no fsPrimJoinActions+idPrimAddSchedPragmas = prelude_id_no fsPrimAddSchedPragmas+idPrimNoActions = prelude_id_no fsPrimNoActions+idPrimNoExpIf = prelude_id_no fsPrimNoExpIf+idPrimExpIf, idPrimNosplitDeep, idPrimSplitDeep, idSplitDeepAV :: Id+idPrimExpIf = prelude_id_no fsPrimExpIf+idPrimNosplitDeep = prelude_id_no fsPrimNosplitDeep+idPrimSplitDeep = prelude_id_no fsPrimSplitDeep+idSplitDeepAV = prelude_id_no fsSplitDeepAV+idNosplitDeepAV, idMfix, idStaticAssert, idDynamicAssert :: Id+idNosplitDeepAV = prelude_id_no fsNosplitDeepAV+idPrimFix :: Position -> Id+idPrimFix pos = prelude_id pos fsPrimFix+idMfix = prelude_id_no fsMfix+idStaticAssert = mk_no fsStaticAssert+idDynamicAssert = mk_no fsDynamicAssert+idContinuousAssert, id_staticAssert, id_dynamicAssert, id_continuousAssert :: Id+idContinuousAssert = mk_no fsContinuousAssert+id_staticAssert = mk_no fs_staticAssert+id_dynamicAssert = mk_no fs_dynamicAssert+id_continuousAssert = mk_no fs_continuousAssert+idClsUninitialized, idPrimUninitialized :: Id+idClsUninitialized = prelude_id_no fsClsUninitialized+idPrimUninitialized = prelude_id_no fsPrimUninitialized+idPrimUninitializedAt :: Position -> Id+idPrimUninitializedAt pos = prelude_id pos fsPrimUninitialized+idPrimMakeUninitialized, idPrimRawUninitialized, idPrimPoisonedDef :: Id+idPrimMakeUninitialized = prelude_id_no fsPrimMakeUninitialized+idPrimRawUninitialized = prelude_id_no fsPrimRawUninitialized+idPrimPoisonedDef = prelude_id_no fsPrimPoisonedDef+idStringAt, idFmtAt, idPrimStringConcatAt :: Position -> Id+idStringAt pos = prelude_id pos fsString+idFmtAt pos = prelude_id pos fsFmt+idPrimStringConcatAt pos = prelude_id pos fsPrimStringConcat++-- | Clock and reset identifiers+idClock, idClockOsc, idClockGate, idReset, idInout, idInout_ :: Id+idClock = prelude_id_no fsClock+idClockOsc = prelude_id_no fsClockOsc+idClockGate = prelude_id_no fsClockGate+idReset = prelude_id_no fsReset+idInout = prelude_id_no fsInout+idInout_ = prelude_id_no fsInout_+idPrimInoutCast, idPrimInoutUncast, idPrimInoutCast0, idPrimInoutUncast0 :: Id+idPrimInoutCast = prelude_id_no fsPrimInoutCast+idPrimInoutUncast = prelude_id_no fsPrimInoutUncast+idPrimInoutCast0 = prelude_id_no fsPrimInoutCast0+idPrimInoutUncast0 = prelude_id_no fsPrimInoutUncast0++idExposeCurrentClock, idExposeCurrentReset :: Id+idExposeCurrentClock = prelude_id_no fsExposeCurrentClock+idExposeCurrentReset = prelude_id_no fsExposeCurrentReset++idNoClock, idNoReset, idPrimReplaceClockGate :: Id+-- needed for noClock constant in ISyntax+idNoClock = prelude_id_no fsNoClock+-- needed for noReset constant in ISyntax+idNoReset = prelude_id_no fsNoReset+-- needed for GenWrap+idPrimReplaceClockGate = prelude_id_no fsPrimReplaceClockGate++idClk, idRst :: Id+idClk = mk_no fsClk -- position?+idRst = mk_no fsRst -- position?++idCLK, idCLK_GATE :: Id+idCLK = mk_no fsCLK+idCLK_GATE = mk_no fsCLK_GATE+-- idRSTN = mk_no fsRSTN++idDefaultClock, idDefaultReset :: Id+idDefaultClock = mk_no fsDefaultClock+idDefaultReset = mk_no fsDefaultReset++-- iConv junk+idPrimSplitFst, idPrimSplitSnd :: Id+idPrimSplitFst = prelude_id_no fsPrimSplitFst+idPrimSplitSnd = prelude_id_no fsPrimSplitSnd++id_x, id_y, id_fun, id_forallb :: Id+id_x = setBadId $ mk_no fs_x+id_y = setBadId $ mk_no fs_y+id_fun = setBadId $ mk_no fs_fun+id_forallb = setBadId $ mk_no fs_forallb++tmpVarIds, tmpVarXIds, tmpVarYIds, tmpVarSIds :: [Id]+tmpVarIds = map (enumId "a" noPosition) [1000..]+tmpVarXIds = map (enumId "x" noPosition) [1000000..]+tmpVarYIds = map (enumId "y" noPosition) [2000000..]+tmpVarSIds = map (enumId "s" noPosition) [3000000..]+tmpTyNumIds, tmpTyVarIds :: [Id]+tmpTyNumIds = map (enumId "tnum" noPosition) [4000000..]+tmpTyVarIds = map (enumId "v" noPosition) [100..]++-- | Used by iExpand+idPrimEQ, idPrimULE, idPrimULT, idPrimSLE, idPrimSLT :: Id+idPrimEQ = prelude_id_no fsPrimEQ+idPrimULE = prelude_id_no fsPrimULE+idPrimULT = prelude_id_no fsPrimULT+idPrimSLE = prelude_id_no fsPrimSLE+idPrimSLT = prelude_id_no fsPrimSLT++-- | Used by iTransform+idPrimAdd, idPrimSub :: Id+idPrimAdd = prelude_id_no fsPrimAdd+idPrimSub = prelude_id_no fsPrimSub++-- | Used by AddCFWire+idVRWireN, idVmkRWire1, idWGet, idWSet, idWHas :: Id+idVRWireN = prelude_bsv_id_no fsVRWireN+idVmkRWire1 = prelude_bsv_id_no fsVmkRWire1+idWGet = prelude_bsv_id_no fsWGet+idWSet = prelude_bsv_id_no fsWSet+idWHas = prelude_bsv_id_no fsWHas++-- versions parametrized on position+idPrimConcatAt, idTrueAt, idAddRulesAt, idOrAt, idEqualAt :: Position -> Id+idPrimConcatAt pos = prelude_id pos fsPrimConcat+idTrueAt pos = prelude_id pos fsTrue+idAddRulesAt pos = prelude_id pos fsAddRules+idOrAt pos = prelude_id pos fsOr+idEqualAt pos = prelude_id pos fsEqual+idNotEqualAt, idPrimUnitAt, idErrorAt, idNegateAt, idIdentityAt :: Position -> Id+idNotEqualAt pos = prelude_id pos fsNotEqual+idPrimUnitAt pos = prelude_id pos fsPrimUnit+idErrorAt pos = prelude_id pos fsError+idNegateAt pos = prelude_id pos fsNegate+idIdentityAt pos = prelude_id pos fsIdentity+idNotAt, idInvertAt, idPercentAt, idModuleAt, idIsModuleAt :: Position -> Id+idNotAt pos = prelude_id pos fsNot+idInvertAt pos = prelude_id pos fsInvert+idPercentAt pos = prelude_id pos fsPercent+idModuleAt pos = prelude_id pos fsModule+idIsModuleAt pos = prelude_id pos fsIsModule+idActionAt, idActionValueAt, idActionValue_At, idIntAt :: Position -> Id+idActionAt pos = prelude_id pos fsAction+idActionValueAt pos = prelude_id pos fsActionValue+idActionValue_At pos = prelude_id pos fsActionValue_+idIntAt pos = prelude_id pos fsInt+idUnpackAt, idStarAt, idSlashAt, idStarStarAt, idPlusAt :: Position -> Id+idUnpackAt pos = prelude_id pos fsUnpack+idStarAt pos = prelude_id pos fsStar+idSlashAt pos = prelude_id pos fsSlash+idStarStarAt pos = prelude_id pos fsStarStar+idPlusAt pos = prelude_id pos fsPlus+idMinusAt, idLshAt, idRshAt, idLtAt, idGtAt, idLtEqAt :: Position -> Id+idMinusAt pos = prelude_id pos fsMinus+idLshAt pos = prelude_id pos fsLsh+idRshAt pos = prelude_id pos fsRsh+idLtAt pos = prelude_id pos fsLT+idGtAt pos = prelude_id pos fsGT+idLtEqAt pos = prelude_id pos fsLtEq+idGtEqAt, idAndAt, idBitAndAt, idBitOrAt, idCaretAt :: Position -> Id+idGtEqAt pos = prelude_id pos fsGtEq+idAndAt pos = prelude_id pos fsAnd+idBitAndAt pos = prelude_id pos fsBitAnd+idBitOrAt pos = prelude_id pos fsBitOr+idCaretAt pos = prelude_id pos fsCaret+idTildeCaretAt, idCaretTildeAt, idReduceAndAt, idReduceOrAt :: Position -> Id+idTildeCaretAt pos = prelude_id pos fsTildeCaret+idCaretTildeAt pos = prelude_id pos fsCaretTilde+idReduceAndAt pos = prelude_id pos fsReduceAnd+idReduceOrAt pos = prelude_id pos fsReduceOr+idReduceXorAt, idReduceNandAt, idReduceNorAt, idReduceXnorAt :: Position -> Id+idReduceXorAt pos = prelude_id pos fsReduceXor+idReduceNandAt pos = prelude_id pos fsReduceNand+idReduceNorAt pos = prelude_id pos fsReduceNor+idReduceXnorAt pos = prelude_id pos fsReduceXnor+idRulesAt, idConstAllBitsSetAt, idConstAllBitsUnsetAt :: Position -> Id+idRulesAt pos = prelude_id pos fsRules+idConstAllBitsSetAt pos = prelude_id pos fsConstAllBitsSet+idConstAllBitsUnsetAt pos = prelude_id pos fsConstAllBitsUnset++-- | List declaration desugaring+idListAt :: Position -> Id+idListAt pos = prelude_id pos fsList++-- array declaration desugaring+idPrimArrayAt, idPrimArrayNewAt, idPrimArrayNewUAt :: Position -> Id+idPrimArrayAt pos = prelude_id pos fsPrimArray+idPrimArrayNewAt pos = prelude_id pos fsPrimArrayNew+idPrimArrayNewUAt pos = prelude_id pos fsPrimArrayNewU+idPrimArrayLengthAt, idPrimArrayInitializeAt, idPrimArrayCheckAt :: Position -> Id+idPrimArrayLengthAt pos = prelude_id pos fsPrimArrayLength+idPrimArrayInitializeAt pos = prelude_id pos fsPrimArrayInitialize+idPrimArrayCheckAt pos = prelude_id pos fsPrimArrayCheck++-- | List identifiers for catching type errors on lists+idList, idListN, idVector, idToVector, idToListN, idPrimArray :: Id+idList = prelude_id_no fsList -- there is no List::List+idListN = mkQId noPosition fsListN fsListN -- not yet moved to Prelude+idVector = mkQId noPosition fsVector fsVector -- but renamed to Vector+idToVector = mkQId noPosition fsVector fsToVector+idToListN = mkQId noPosition fsListN fsToListN+idPrimArray = prelude_id_no fsPrimArray++-- system task ids+idFinish, idStop :: Id+idFinish = prelude_id_no fsFinish+idStop = prelude_id_no fsStop++idDisplay, idDisplayh, idDisplayb, idDisplayo :: Id+idDisplay = prelude_id_no fsDisplay+idDisplayh = prelude_id_no fsDisplayh+idDisplayb = prelude_id_no fsDisplayb+idDisplayo = prelude_id_no fsDisplayo++idWrite, idWriteh, idWriteb, idWriteo :: Id+idWrite = prelude_id_no fsWrite+idWriteh = prelude_id_no fsWriteh+idWriteb = prelude_id_no fsWriteb+idWriteo = prelude_id_no fsWriteo++idFDisplay, idFDisplayh, idFDisplayb, idFDisplayo :: Id+idFDisplay = prelude_id_no fsFDisplay+idFDisplayh = prelude_id_no fsFDisplayh+idFDisplayb = prelude_id_no fsFDisplayb+idFDisplayo = prelude_id_no fsFDisplayo++idFWrite, idFWriteh, idFWriteb, idFWriteo :: Id+idFWrite = prelude_id_no fsFWrite+idFWriteh = prelude_id_no fsFWriteh+idFWriteb = prelude_id_no fsFWriteb+idFWriteo = prelude_id_no fsFWriteo++idSWriteAV, idSWrite, idSWritehAV, idSWriteh, idSWritebAV :: Id+idSWriteAV = prelude_id_no fsSWriteAV+idSWrite = prelude_id_no fsSWrite+idSWritehAV = prelude_id_no fsSWritehAV+idSWriteh = prelude_id_no fsSWriteh+idSWritebAV = prelude_id_no fsSWritebAV+idSWriteb, idSWriteoAV, idSWriteo, idSFormatAV, idSFormat :: Id+idSWriteb = prelude_id_no fsSWriteb+idSWriteoAV = prelude_id_no fsSWriteoAV+idSWriteo = prelude_id_no fsSWriteo+idSFormatAV = prelude_id_no fsSFormatAV+idSFormat = prelude_id_no fsSFormat++idErrorTask, idWarnTask, idInfoTask, idFatalTask :: Id+idErrorTask = prelude_id_no fsErrorTask+idWarnTask = prelude_id_no fsWarnTask+idInfoTask = prelude_id_no fsInfoTask+idFatalTask = prelude_id_no fsFatalTask++idSVA, idSvaParam, idSvaBool, idSvaNumber :: Id+idSVA = prelude_id_no fsSVA+idSvaParam = prelude_id_no fsSvaParam+idSvaBool = prelude_id_no fsSvaBool+idSvaNumber = prelude_id_no fsSvaNumber++idSVAsampled, idSVArose, idSVAfell, idSVAstable, idSVApast :: Id+idSVAsampled = prelude_id_no fsSVAsampled+idSVArose = prelude_id_no fsSVArose+idSVAfell = prelude_id_no fsSVAfell+idSVAstable = prelude_id_no fsSVAstable+idSVApast = prelude_id_no fsSVApast+idSVAonehot, idSVAonehot0, idSVAisunknown, idSVAcountones :: Id+idSVAonehot = prelude_id_no fsSVAonehot+idSVAonehot0 = prelude_id_no fsSVAonehot0+idSVAisunknown = prelude_id_no fsSVAisunknown+idSVAcountones = prelude_id_no fsSVAcountones++idRandom :: Id+idRandom = prelude_id_no fsRandom++idDumpon, idDumpoff, idDumpvars, idDumpall, idDumplimit, idDumpflush :: Id+idDumpon = prelude_id_no fsDumpon+idDumpoff = prelude_id_no fsDumpoff+idDumpvars = prelude_id_no fsDumpvars+idDumpall = prelude_id_no fsDumpall+idDumplimit = prelude_id_no fsDumplimit+idDumpflush = prelude_id_no fsDumpflush++idDumpfile, idTime, idSTime, idFOpen, idFGetc, idUngetc, idFClose :: Id+idDumpfile = prelude_id_no fsDumpfile+idTime = prelude_id_no fsTime+idSTime = prelude_id_no fsSTime+idFOpen = prelude_id_no fsFOpen+idFGetc = prelude_id_no fsFGetc+idUngetc = prelude_id_no fsUngetc+idFClose = prelude_id_no fsFClose++idFFlush, idTestPlusargs, idRealToBits, idBitsToReal :: Id+idFFlush = prelude_id_no fsFFlush+idTestPlusargs = prelude_id_no fsTestPlusargs+idRealToBits = prelude_id_no fsRealToBits+idBitsToReal = prelude_id_no fsBitsToReal++taskIds :: [Id]+taskIds = [ idFinish, idStop,+ --+ idDisplay, idDisplayh, idDisplayb, idDisplayo,+ idWrite, idWriteb, idWriteh, idWriteo,+ --+ idErrorTask, idWarnTask, idInfoTask, idFatalTask,+ --+ idRandom,+ --+ idFDisplay, idFDisplayh, idFDisplayb, idFDisplayo,+ idFWrite, idFWriteb, idFWriteh, idFWriteo,+ --+ idSFormatAV, idSFormat,+ idSWriteAV, idSWrite, idSWritehAV, idSWriteh,+ idSWritebAV, idSWriteb, idSWriteoAV, idSWriteo,+ idFormat,+ --+ idSVA,+ --+ idDumpon, idDumpoff, idDumpvars, idDumpflush, idDumpfile,+ idDumpall, idDumplimit,+ --+ idTime, idSTime,+ --+ idFOpen, idFGetc, idUngetc, idFClose, idFFlush,+ --+ idTestPlusargs+ ]++-- these are explicitly NOT supported in user code+-- they are for internal use only (so not part of the taskids list)+idSigned, idUnsigned :: Position -> Id+idSigned pos = prelude_id pos fsSigned+idUnsigned pos = prelude_id pos fsUnsigned++-- | Classes hardcoded in the Prelude which were added for ContextErrors+idBitwise, idBitReduce, idBitExtend, idArith, idOrd :: Id+idBitwise = prelude_id_no fsBitwise+idBitReduce = prelude_id_no fsBitReduce+idBitExtend = prelude_id_no fsBitExtend+idArith = prelude_id_no fsArith+idOrd = prelude_id_no fsOrd++-- | Names used for tuple fields internally?+tupleIds :: [Id]+tupleIds = map (\fs -> mkId noPosition fs) fsTuples+-- | Names exposed to the BSV user+idTuple2, idTuple3, idTuple4, idTuple5, idTuple6, idTuple7, idTuple8 :: Id+idTuple2 = prelude_id_no fsTuple2+idTuple3 = prelude_id_no fsTuple3+idTuple4 = prelude_id_no fsTuple4+idTuple5 = prelude_id_no fsTuple5+idTuple6 = prelude_id_no fsTuple6+idTuple7 = prelude_id_no fsTuple7+idTuple8 = prelude_id_no fsTuple8++-- Classes that we always derive implicitly.+-- Note that these are assumed to have a single parameter, or if multiple,+-- the first is the one for which the instance is defined.+autoderivedClasses :: [Id]+autoderivedClasses = [idGeneric]
+ src/Language/Bluespec/Classic/AST/Builtin/Types.hs view
@@ -0,0 +1,204 @@+-- This corresponds to src/Comp/Type.hs in bsc.+module Language.Bluespec.Classic.AST.Builtin.Types where++import Language.Bluespec.Classic.AST.Builtin.Ids+import Language.Bluespec.Classic.AST.Id+import Language.Bluespec.Classic.AST.Position+import Language.Bluespec.Classic.AST.Type+import Language.Bluespec.Prelude+import Language.Bluespec.Pretty++infixr 4 `fn`++-- XXX these definitions should be synced with StdPrel.hs where applicable++tArrow, tBit, tInt :: Type+tArrow = TCon (TyCon (idArrow noPosition) (Just (Kfun KStar (Kfun KStar KStar))) TIabstract)+tBit = TCon (TyCon idBit (Just (Kfun KNum KStar)) TIabstract)+tInt = TCon (TyCon idInt (Just (Kfun KNum KStar)) TIabstract)++tIntAt :: Position -> Type+tIntAt pos = TCon (TyCon (idIntAt pos) (Just (Kfun KNum KStar)) TIabstract)++tiData, tiEnum :: [Id] -> TISort+tiEnum cons = TIdata { tidata_cons = cons, tidata_enum = True }+tiData cons = TIdata { tidata_cons = cons, tidata_enum = False }++tUInt, tBool, tPrimUnit :: Type+tUInt = TCon (TyCon idUInt (Just (Kfun KNum KStar)) TIabstract)+tBool = TCon (TyCon idBool (Just KStar) (tiEnum [idFalse, idTrue]))+--tArray = TCon (TyCon idArray (Just (Kfun KNum (Kfun KNum KStar))) (TIstruct SInterface [id_sub, id_upd]))+tPrimUnit = TCon (TyCon idPrimUnit (Just KStar) (TIstruct SStruct []))++tPrimUnitAt :: Position -> Type+tPrimUnitAt pos = TCon (TyCon (idPrimUnitAt pos) (Just KStar) (TIstruct SStruct []))++tInteger, tReal :: Type+tInteger = TCon (TyCon idInteger (Just KStar) TIabstract)+tReal = TCon (TyCon idReal (Just KStar) TIabstract)++tRealAt :: Position -> Type+tRealAt pos = TCon (TyCon (idRealAt pos) (Just KStar) TIabstract)++tClock, tReset, tInout, tInout_, tChar, tString :: Type+tClock = TCon (TyCon idClock (Just KStar) TIabstract)+tReset = TCon (TyCon idReset (Just KStar) TIabstract)+tInout = TCon (TyCon idInout (Just (Kfun KStar KStar)) TIabstract)+tInout_ = TCon (TyCon idInout_ (Just (Kfun KNum KStar)) TIabstract)+tString = TCon (TyCon idString (Just KStar) TIabstract)+tChar = TCon (TyCon idChar (Just KStar) TIabstract)++tFmt, tName, tPosition, tType :: Type+tFmt = TCon (TyCon idFmt (Just KStar) TIabstract)+tName = TCon (TyCon idName (Just KStar) TIabstract)+tPosition = TCon (TyCon idPosition (Just KStar) TIabstract)+tType = TCon (TyCon idType (Just KStar) TIabstract)++tPred, tAttributes, tPrimPair, tSizeOf :: Type+tPred = TCon (TyCon idPred (Just KStar) TIabstract)+tAttributes = TCon (TyCon idAttributes (Just KStar) TIabstract)+tPrimPair = TCon (TyCon idPrimPair (Just (Kfun KStar (Kfun KStar KStar))) (TIstruct SStruct [idPrimFst, idPrimSnd]))+tSizeOf = TCon (TyCon idSizeOf (Just (Kfun KStar KNum)) TIabstract)++tAction, tActionValue, tActionValue_, tAction_:: Type+tAction = TCon (TyCon idAction (Just KStar) (TItype 0 (TAp tActionValue tPrimUnit)))+tActionValue = TCon (TyCon idActionValue (Just (Kfun KStar KStar)) (TIstruct SStruct [id__value, id__action]))+tActionValue_ = TCon (TyCon idActionValue_ (Just (Kfun KNum KStar)) (TIstruct SStruct [id__value, id__action]))+tAction_ = TAp tActionValue_ (tOfSize 0 noPosition)++tActionAt, tActionValueAt, tActionValue_At :: Position -> Type+tActionAt pos = TCon (TyCon (idActionAt pos) (Just KStar) (TItype 0 (TAp (tActionValueAt pos) (tPrimUnitAt pos))))+tActionValueAt pos = TCon (TyCon (idActionValueAt pos) (Just (Kfun KStar KStar)) (TIstruct SStruct [id__value_at pos, id__action_at pos]))+tActionValue_At pos = TCon (TyCon (idActionValue_At pos) (Just (Kfun KNum KStar)) (TIstruct SStruct [id__value_at pos, id__action_at pos]))++tPrimAction, tRules :: Type+tPrimAction = TCon (TyCon idPrimAction (Just KStar) TIabstract)+tRules = TCon (TyCon idRules (Just KStar) TIabstract)++tRulesAt :: Position -> Type+tRulesAt pos = TCon (TyCon (idRulesAt pos) (Just KStar) TIabstract)++tSchedPragma, tModule, tVRWireN, tId, t32 :: Type+tSchedPragma = TCon (TyCon idSchedPragma (Just KStar) TIabstract)+tModule = TCon (TyCon idModule (Just (Kfun KStar KStar)) TIabstract)+tVRWireN = TCon (TyCon idVRWireN (Just (Kfun KNum KStar)) (TIstruct SStruct [idWSet, idWGet, idWHas]))+tId = TCon (TyCon idId (Just (Kfun KStar KStar)) TIabstract)+t32 = tOfSize 32 noPosition++t32At :: Position -> Type+t32At pos = tOfSize 32 pos++tOfSize :: Integer -> Position -> Type+tOfSize n pos = cTNum n pos++tInt32At :: Position -> Type+tInt32At pos = TAp (tIntAt pos) (t32At pos)++tBitN :: Integer -> Position -> Type+tBitN n pos = TAp tBit (tOfSize n pos)++tNat :: Position -> Type+tNat pos = tBitN 32 pos++tFile, tSvaParam :: Type+tFile = TCon (TyCon idFile (Just KStar) TIabstract)+tSvaParam = TCon (TyCon idSvaParam (Just KStar) (tiData [idSvaBool, idSvaNumber]))++fn :: Type -> Type -> Type+a `fn` b = TAp (TAp tArrow a) b++-- numeric kinds and type constructors+kNNN, kNN, kNNS, kNS :: Kind+kNNN = Kfun KNum kNN+kNN = Kfun KNum KNum++kNNS = Kfun KNum kNS+kNS = Kfun KNum KStar++tAdd, tSub, tMul, tDiv, tLog, tExp, tMax, tMin :: Type+tAdd = TCon (TyCon idTAdd (Just kNNN) TIabstract)+tSub = TCon (TyCon idTSub (Just kNNN) TIabstract)+tMul = TCon (TyCon idTMul (Just kNNN) TIabstract)+tDiv = TCon (TyCon idTDiv (Just kNNN) TIabstract)+tLog = TCon (TyCon idTLog (Just kNN) TIabstract)+tExp = TCon (TyCon idTExp (Just kNN) TIabstract)+tMax = TCon (TyCon idTMax (Just kNNN) TIabstract)+tMin = TCon (TyCon idTMin (Just kNNN) TIabstract)++class HasKind t where+ kind :: t -> Kind++instance HasKind TyVar where+ kind (TyVar _v _ k) = k++instance HasKind TyCon where+ kind (TyCon _v (Just k) _) = k+ kind (TyNum _ _) = KNum+ kind (TyStr _ _) = KStr+ kind (TyCon _v Nothing _) = error "HasKind(TyCon).kind: TyCon without kind"++instance HasKind Type where+ kind (TCon tc) = kind tc+ kind (TVar u) = kind u+ kind tt@(TAp t _) = case kind t of+ Kfun _ k -> k+ k ->+ error ("kind: " ++ ppReadable k ++ (show tt) ++ "\n")+ kind (TGen _ _) = error "HasKind(Type).kind: TGen"+ kind (TDefMonad _) = error "HasKind(Type).kind: TDefMonad"++arrow :: Type -> Type -> Type+arrow a r = TAp (TAp tArrow a) r+++-- -------------------------++-- XXX kill this+isPrimAction :: Type -> Bool+isPrimAction t = t == tPrimAction++isActionValue :: Type -> Bool+isActionValue (TAp av _) = av == tActionValue+isActionValue _ = False++getAVType :: Type -> Type+getAVType (TAp av t) | av == tActionValue = t+getAVType t = error("getAVType not ActionValue: " ++ ppReadable t)++isActionWithoutValue :: Type -> Bool+isActionWithoutValue (TAp av (TCon (TyNum 0 _))) = av == tActionValue_+isActionWithoutValue _ = False++isActionWithValue :: Type -> Bool+isActionWithValue (TAp av (TCon (TyNum n _))) = (av == tActionValue_) && (n > 0)+isActionWithValue (TAp av (TVar _)) = av == tActionValue_+isActionWithValue _ = False++isClock, isReset, isInout, isInout_ :: Type -> Bool+isClock t = t == tClock+isReset t = t == tReset++isInout (TAp i _) = i == tInout+isInout _ = False++isInout_ (TAp i _) = i == tInout_+isInout_ _ = False++isBit, isInt, isUInt, isBool, isInteger, isString, isChar, isReal, isFmt :: Type -> Bool+isBit (TAp b _) = b == tBit+isBit _ = False++isInt (TAp i _) = i == tInt+isInt _ = False++isUInt (TAp u _) = u == tUInt+isUInt _ = False++isBool t = t == tBool+isInteger t = t == tInteger+isString t = t == tString+isChar t = t == tChar+isReal t = t == tReal+isFmt t = t == tFmt++-- -------------------------
+ src/Language/Bluespec/Classic/AST/FString.hs view
@@ -0,0 +1,40 @@+-- This corresponds to src/comp/FStringCompat.hs in bsc.+module Language.Bluespec.Classic.AST.FString+ ( FString+ , getFString+ , mkFString+ , tmpFString+ ) where++import Data.String (IsString(..))+import qualified Data.Text as T+import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Classic.AST.SString+import Language.Bluespec.Prelude++-- wrapper to make SStrings look like FStrings++newtype FString = FString SString+ deriving (Eq, Ord)++instance IsString FString where+ fromString = FString . T.pack++instance Show FString where+ show (FString s) = show s++instance Pretty FString where+ pPrintPrec _ _ x = text (show x)++getFString :: FString -> String+getFString = toString++mkFString :: String -> FString+mkFString s = fromString s++tmpFString :: Int -> String -> FString+tmpFString _ = fromString++toString :: FString -> String+toString (FString s) = T.unpack s
+ src/Language/Bluespec/Classic/AST/Id.hs view
@@ -0,0 +1,270 @@+-- This corresponds to src/comp/Id.hs and src/comp/IdPrint.hs in bsc.+module Language.Bluespec.Classic.AST.Id+ ( Id+ , addIdProp+ , addIdProps+ , createPositionString+ , enumId+ , getIdBase+ , getIdBaseString+ , getIdPosition+ , getIdProps+ , getIdQual+ , getIdQualString+ , getIdString+ , mkId+ , mkQId+ , ppConId+ , ppId+ , ppVarId+ , qualEq+ , setBadId+ , setIdProps++ , IdProp(..)++ , Longname+ ) where++import Data.Char (isDigit)+import qualified Data.List as L+import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Classic.AST.Builtin.FStrings+import Language.Bluespec.Classic.AST.FString+import Language.Bluespec.Classic.AST.Position+import Language.Bluespec.Lex+import Language.Bluespec.Prelude+import Language.Bluespec.Pretty+import Language.Bluespec.Util++data Id = Id { id_pos :: !Position,+ id_mfs :: !FString,+ id_fs :: !FString,+ id_props :: [IdProp] {- , id_stab :: Int -}+ }++idEq :: Id -> Id -> Bool+idEq a b = (id_fs a == id_fs b) && (id_mfs a == id_mfs b)++idCompare :: Id -> Id -> Ordering+idCompare a b = case (compare (id_fs a) (id_fs b)) of+ EQ -> compare (id_mfs a) (id_mfs b)+ LT -> LT+ GT -> GT++instance Eq Id where+ a == b = idEq a b++instance Ord Id where+ compare = idCompare++instance Show Id where+ show = show_brief++instance Pretty Id where+ pPrintPrec d _p i+ | d == pdDebug+ = text (local_show i)+ | otherwise+ = if (dbgLevel >= 1)+ then text ((getIdString i) +++ "_" +++ (createPositionString (getIdPosition i)))+ else text (getIdString i)++instance HasPosition Id where+ getPosition i = getIdPosition i++local_show :: Id -> String+local_show id' =+ let+ pos = getIdPosition id'+ mfs = getIdQualString id'+ fs = getIdBaseString id'+ str = show pos ++ " " +++ show mfs ++ " " +++ show fs+ in str++show_brief :: Id -> String+show_brief i =+ case (getFString (id_mfs i), getFString (id_fs i)) of+ ("", str) -> add_props str+ (pkg, str) -> add_props (pkg ++ "::" ++ str)+ where add_props str | null (id_props i) = str+ | otherwise = str ++ show (id_props i)++createPositionString :: Position -> String+createPositionString _ = "<NoPos>"++-- Create an id of the form "<str>_<index>".+-- This is used to ENUMerate a list of Ids with the same name,+-- but with uniquifying numbers.+--+-- Note: The Ids created with this are marked as "bad". If these Ids+-- need to be created from a user-given name, consider creating a new+-- interface for this which takes Id and not String, and derives its+-- properties from that Id.+enumId :: String -> Position -> Int -> Id+enumId str pos index =+ let id_str = tmpFString index ("_" ++ str ++ itos index)+ in setBadId+ (Id pos fsEmpty id_str [])++getIdBase :: Id -> FString+getIdBase a = id_fs a++getIdBaseString :: Id -> String+getIdBaseString a = getFString $ getIdBase a++getIdPosition :: Id -> Position+getIdPosition a = id_pos a++getIdProps :: Id -> [IdProp]+getIdProps a = id_props a++getIdQual :: Id -> FString+getIdQual a = id_mfs a++getIdQualString :: Id -> String+getIdQualString a = getFString $ getIdQual a++getIdString :: Id -> String+getIdString a | mfs == fsEmpty = getFString fs+ | otherwise = getFString mfs ++ "." ++ getFString fs+ where mfs = getIdQual a+ fs = getIdBase a++mkId :: Position -> FString -> Id+mkId pos fs =+ let value = Id pos fsEmpty fs []+ in -- trace("ID: " ++ (ppReadable value)) $+ value++-- Qualified with a path.+mkQId :: Position -> FString -> FString -> Id+mkQId pos mfs fs+ | fs == fsEmpty = Id pos fsEmpty fsEmpty []+ | fHead:_ <- getFString fs+ , isDigit fHead = Id pos fsEmpty fs [] -- XXX+ | otherwise = Id pos mfs fs []++ppConId :: PDetail -> Id -> Doc+ppConId d i+ | d == pdDebug+ = pPrintPrec pdDebug 0 i+ | otherwise+ = -- text ( "props:" ++ show (getIdProps i)) <>+ case (getIdBaseString i) of+ "->" -> text "(->)" -- arrow+ s@(_:_) | all isDigit s -> text s -- numbers+ _ -> text (getIdStringCon i) -- constructor-identifiers++ppId :: PDetail -> Id -> Doc+ppId d i+ | d == pdDebug+ = pPrintPrec pdDebug 0 i+ | otherwise+ = if (dbgLevel >= 1)+ then case (getIdBaseString i) of+ "->" -> text "(->)" -- arrow+ s@(c:_) | isDigit c -> text( s ++ "_" ++ (createPositionString (getIdPosition i)))+ c:_ | isIdChar c -> text ((getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))+ '$':c:_ | isIdChar c -> text (getIdString i) -- task names+ _ -> text ("(" ++ (getIdString i) ++ "_" ++ (createPositionString (getIdPosition i)))+ else case (getIdBaseString i) of+ "->" -> text "(->)" -- arrow+ s@(c:_) | isDigit c -> text s -- numbers+ c:_ | isIdChar c -> text (getIdString i) -- identifiers+ '$':c:_ | isIdChar c -> text (getIdString i) -- task names+ _ -> text ("("++getIdString i++")") -- infix operators++ppVarId :: PDetail -> Id -> Doc+ppVarId d i+ | d == pdDebug+ = pPrintPrec pdDebug 0 i+ | otherwise+ = if (dbgLevel >= 1)+ then case (getIdBaseString i) of+ s | all isSym s -> text ("("++ (getIdStringOp i) ++ (createPositionString (getIdPosition i)) +++ ")") -- infix operators+ '$':c:_ | isIdChar c -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))+ _ -> text ((getIdStringVar i) ++ (createPositionString (getIdPosition i)))+ else case (getIdBaseString i) of+ s | all isSym s -> text ("("++getIdStringOp i ++ ")") -- infix operators+ '$':c:_ | isIdChar c -> text (getIdStringVar i) -- task names+ _ -> text (getIdStringVar i)++qualEq :: Id -> Id -> Bool+qualEq a b | getIdQual a == fsEmpty || getIdQual b == fsEmpty = getIdBase a == getIdBase b+qualEq a b = a == b++setBadId :: Id -> Id+setBadId idx = addIdProp idx IdP_bad_name++setIdProps :: Id -> [IdProp] -> Id+setIdProps a l = a { id_props = l }++-- These used to encode properties in .bi files+getIdStringCon :: Id -> String+getIdStringCon = getIdString+getIdStringVar :: Id -> String+getIdStringVar = getIdString+getIdStringOp :: Id -> String+getIdStringOp = getIdString++data IdProp = IdPCanFire+ | IdPWillFire+ | IdPProbe+ | IdPInternal+ | IdPReady -- interface ready signal+ | IdPGeneratedIfc -- generated interface name+ | IdPMeth+ | IdPCommutativeTCon -- commutative type constructor+ | IdP_enable+ | IdP_keep+ | IdP_keepEvenUnused+ | IdPRule+ | IdPSplitRule+ | IdPDict -- is a dictionary+ | IdPRenaming -- id for temporary renaming+ | IdP_suffixed -- a _nn suffix has been added+ | IdP_SuffixCount Integer -- the number of suffixes added ... not to be used with IdP_suffixed+ | IdP_bad_name -- a name generated without good information (e.g., __d5)+ | IdP_from_rhs -- a name generated from the right-hand-side of an assignment (e.g., x_PLUS_5__d32)+ | IdP_signed -- in C backend, an id created from $signed()+ | IdP_NakedInst -- id associated with a "naked" instantiation (i.e. without a bind)+ | IdPDisplayName FString -- provide an alternate display string+ | IdP_hide+ | IdP_hide_all+ | IdP_TypeJoin Id Id -- Internally generated type name (anonymous structs)+ -- Arguments are the original type and constructor name+ | IdPMethodPredicate -- is a predicate of a method call in a rule+ -- the Id of meth calls on imported/synthesized modules+ -- can be tagged with the position of inlined method calls+ -- that it was contained in (the top methods are last)+ | IdPInlinedPositions [Position]+ -- used by the BSV parser to keep track of which array types+ -- were introduced from bracket syntax+ | IdPParserGenerated+ deriving (Eq, Ord, Show)++instance Pretty IdProp where+ pPrintPrec d _ (IdPInlinedPositions poss) =+ pparen True (text "IdPInlinedPositions" <+> pPrintPrec d 0 poss)+ pPrintPrec _ _ prop = text (show prop)++-- #############################################################################+-- # Methods for adding properties to Id's, checking for them etc.+-- #############################################################################++addIdProp :: Id -> IdProp -> Id+addIdProp a prop = setIdProps a (L.union (getIdProps a) [prop])++addIdProps :: Id -> [IdProp] -> Id+addIdProps a propl = setIdProps a (L.union (getIdProps a) propl)++-- Long names++type Longname = [Id]
+ src/Language/Bluespec/Classic/AST/IntLit.hs view
@@ -0,0 +1,56 @@+-- This corresponds to src/comp/IntLit.hs in bsc.+module Language.Bluespec.Classic.AST.IntLit+ ( IntLit(..)+ , ilDec+ , ilSizedDec+ , ilHex+ , ilSizedHex+ , ilBin+ , ilSizedBin+ ) where++import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.IntegerUtil+import Language.Bluespec.Prelude++data IntLit = IntLit { ilWidth :: Maybe Integer,+ ilBase :: Integer,+ ilValue :: Integer }++instance Eq IntLit where+ IntLit { ilValue = i1 } == IntLit { ilValue = i2 } = i1 == i2+ IntLit { ilValue = i1 } /= IntLit { ilValue = i2 } = i1 /= i2++instance Ord IntLit where+ IntLit { ilValue = i1 } <= IntLit { ilValue = i2 } = i1 <= i2+ IntLit { ilValue = i1 } < IntLit { ilValue = i2 } = i1 < i2+ IntLit { ilValue = i1 } >= IntLit { ilValue = i2 } = i1 >= i2+ IntLit { ilValue = i1 } > IntLit { ilValue = i2 } = i1 > i2+ IntLit { ilValue = i1 } `compare` IntLit { ilValue = i2 } = i1 `compare` i2++instance Show IntLit where+ showsPrec _ (IntLit { ilValue = i, ilWidth = _mw, ilBase = b }) s =+ -- width of 0 means don't pad with leading zeros+ integerFormatPref 0 b i ++ s++instance Pretty IntLit where+ pPrintPrec _d _p i = text (show i)++ilDec :: Integer -> IntLit+ilDec i = IntLit { ilWidth = Nothing, ilBase = 10, ilValue = i }++ilSizedDec :: Integer -> Integer -> IntLit+ilSizedDec w i = IntLit { ilWidth = Just w, ilBase = 10, ilValue = i }++ilHex :: Integer -> IntLit+ilHex i = IntLit { ilWidth = Nothing, ilBase = 16, ilValue = i }++ilSizedHex :: Integer -> Integer -> IntLit+ilSizedHex w i = IntLit { ilWidth = Just w, ilBase = 16, ilValue = i }++ilBin :: Integer -> IntLit+ilBin i = IntLit { ilWidth = Nothing, ilBase = 2, ilValue = i }++ilSizedBin :: Integer -> Integer -> IntLit+ilSizedBin w i = IntLit { ilWidth = Just w, ilBase = 2, ilValue = i }
+ src/Language/Bluespec/Classic/AST/Literal.hs view
@@ -0,0 +1,24 @@+-- This corresponds to src/comp/Literal.hs in bsc.+module Language.Bluespec.Classic.AST.Literal+ ( Literal(..)+ ) where++import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Classic.AST.IntLit+import Language.Bluespec.Prelude++data Literal+ = LString String+ | LChar Char+ | LInt IntLit+ | LReal Double+ | LPosition -- a position literal is a placeholder for the position in CLiteral+ deriving (Eq, Ord, Show)++instance Pretty Literal where+ pPrintPrec _ _ (LString s) = text (show s)+ pPrintPrec _ _ (LChar c) = text (show c)+ pPrintPrec d p (LInt i) = pPrintPrec d p i+ pPrintPrec d p (LReal r) = pPrintPrec d p r+ pPrintPrec _ _ LPosition = text ("<Position>")
+ src/Language/Bluespec/Classic/AST/Position.hs view
@@ -0,0 +1,59 @@+{-# LANGUAGE FlexibleInstances #-}+-- This corresponds to src/comp/Position.hs in bsc.+module Language.Bluespec.Classic.AST.Position+ ( Position(..)+ , bestPosition+ , noPosition+ , updatePosStdlib+ , HasPosition(..)+ ) where++import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Prelude++-- For now, we don't track positions, although we may do so in the future.+data Position = NoPos+ deriving (Eq, Ord, Show)++instance Pretty Position where+ pPrintPrec _ _ NoPos = text "<NoPos>"++bestPosition :: Position -> Position -> Position+bestPosition p1 p2 = if p1 == noPosition then p2 else p1++noPosition :: Position+noPosition = NoPos++updatePosStdlib :: Position -> Bool -> Position+updatePosStdlib pos _is_stdlib = pos++class HasPosition a where+ getPosition :: a -> Position++instance HasPosition Position where+ getPosition p = p++instance (HasPosition a) => HasPosition (Maybe a) where+ getPosition (Just x) = getPosition x+ getPosition Nothing = noPosition++instance (HasPosition a, HasPosition b) => HasPosition (Either a b) where+ getPosition (Right x) = getPosition x+ getPosition (Left x) = getPosition x++instance (HasPosition a) => HasPosition [a] where+ getPosition [] = noPosition+ getPosition (x:xs) = getPosition x `bestPosition` getPosition xs++instance (HasPosition a, HasPosition b) => HasPosition (a, b) where+ getPosition (x, y) = getPosition x `bestPosition` getPosition y++instance (HasPosition a, HasPosition b, HasPosition c) => HasPosition (a, b, c) where+ getPosition (x, y, z) = getPosition x `bestPosition` getPosition y `bestPosition` getPosition z++instance (HasPosition a, HasPosition b, HasPosition c, HasPosition d) => HasPosition (a, b, c, d) where+ getPosition (x, y, z, w) = getPosition x `bestPosition` getPosition y `bestPosition` getPosition z `bestPosition` getPosition w++instance HasPosition String where+ getPosition _x = noPosition
+ src/Language/Bluespec/Classic/AST/Pragma.hs view
@@ -0,0 +1,230 @@+-- This corresponds to src/comp/Pragma.hs in bsc.+module Language.Bluespec.Classic.AST.Pragma+ ( Pragma(..)+ , PProp(..)+ , RulePragma(..)+ , SchedulePragma(..)+ , CSchedulePragma+ , IfcPragma(..)++ , ppPProp+ ) where++import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Classic.AST.Id+import Language.Bluespec.Classic.AST.Position+import Language.Bluespec.Classic.AST.SchedInfo+import Language.Bluespec.Prelude+import Language.Bluespec.Pretty+import Language.Bluespec.Util++data Pragma+ = Pproperties Id [PProp]-- module Id and properties associate with+ | Pnoinline [Id] -- [Id] is a list of functions which should not be inlined+ deriving (Eq, Ord, Show)++instance Pretty Pragma where+ pPrintPrec d _p (Pproperties i pps) =+ (text "{-# properties" <+> ppId d i <+> text "= { ") <>+ sepList (map (pPrintPrec d 0) pps) (text ",") <> text " } #-}"+ pPrintPrec d _p (Pnoinline is) =+ text "{-# noinline" <+> sep (map (ppId d) is) <+> text " #-}"++instance HasPosition Pragma where+ getPosition (Pproperties i _) = getPosition i+ getPosition (Pnoinline (i:_)) = getPosition i+ getPosition (Pnoinline []) = error "HasPosition(Pragma).getPosition: Pnoinline []"++-- Module definition properties:+data PProp+ = PPverilog -- generate verilog+ | PPforeignImport Id -- wrapper for a foreign import+ -- (Id is link name, needed for dependency check, if we're+ -- generating the .ba file for the link name, not the src name)+ | PPalwaysReady [Longname] -- no ready signals for these methods ([] means all)+ | PPalwaysEnabled [Longname] -- execute on every cycle+ | PPenabledWhenReady [Longname] -- enable is equivalent to ready+ | PPscanInsert Integer -- insert scan chain ports+ | PPbitBlast -- do "bit blasting",+ -- e.g., split multibit ports+ | PPCLK String -- clock port prefix+ | PPGATE String -- gate port prefix+ | PPRSTN String -- reset port prefix+ | PPclock_osc [(Id,String)] -- port name for clock+ | PPclock_gate [(Id,String)] -- port name for gate+ | PPgate_inhigh [Id] -- clock args with inhigh gates+ | PPgate_unused [Id] -- clock args with unused gates+ | PPreset_port [(Id,String)] -- port name for reset+ | PParg_param [(Id,String)] -- name for parameter argument+ | PParg_port [(Id,String)] -- port name for other arguments+ | PParg_clocked_by [(Id,String)] -- clocks of module arguments+ | PParg_reset_by [(Id,String)] -- resets of module arguments+ | PPoptions [String] -- compiler options+ | PPgate_input_clocks [Id] -- list of clock args with gates+ | PPmethod_scheduling (MethodConflictInfo Longname)+ -- scheduling constraints for interface arg methods+ | PPdoc String -- comment to carry through to Verilog+ | PPperf_spec [[Id]] -- method composition order for performance specs+ | PPclock_family [Id] -- ids of input clocks in the same family+ | PPclock_ancestors [[Id]] -- input clock ancestry sequences+ -- module arguments which should generate to params instead of ports+ | PPparam [Id]+ | PPinst_name Id+ | PPinst_hide+ | PPinst_hide_all+ | PPdeprecate String+ deriving (Eq, Ord, Show)++instance Pretty PProp where+ pPrintPrec d _ (PPscanInsert i) = text "scanInsert = " <+> pPrintPrec d 0 i+ pPrintPrec _d _ (PPCLK s) = text ("clock_prefix = " ++ s)+ pPrintPrec _d _ (PPGATE s) = text ("gate_prefix = " ++ s)+ pPrintPrec _d _ (PPRSTN s) = text ("reset_prefix = " ++ s)+ pPrintPrec d _ (PPclock_osc xs) =+ text "clock_osc = {"+ <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")"+ | (i,s) <- xs ]+ (text ",")+ <> text "}"+ pPrintPrec d _ (PPclock_gate xs) =+ text "clock_gate = {"+ <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")"+ | (i,s) <- xs ]+ (text ",")+ <> text "}"+ pPrintPrec d _ (PPgate_inhigh is) =+ text "gate_inhigh = {" <> sepList (map (ppId d) is) (text ",") <> text "}"+ pPrintPrec d _ (PPgate_unused is) =+ text "gate_unused = {" <> sepList (map (ppId d) is) (text ",") <> text "}"+ pPrintPrec d _ (PPreset_port xs) =+ text "reset_port = {"+ <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")"+ | (i,s) <- xs ]+ (text ",")+ <> text "}"+ pPrintPrec d _ (PParg_param xs) =+ text "arg_param = {"+ <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")"+ | (i,s) <- xs ]+ (text ",")+ <> text "}"+ pPrintPrec d _ (PParg_port xs) =+ text "arg_port = {"+ <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")"+ | (i,s) <- xs ]+ (text ",")+ <> text "}"+ pPrintPrec d _ (PParg_clocked_by xs) =+ text "clocked_by = {"+ <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")"+ | (i,s) <- xs ]+ (text ",")+ <> text "}"+ pPrintPrec d _ (PParg_reset_by xs) =+ text "reset_by = {"+ <> sepList [ text "(" <> ppId d i <> text "," <> (text s) <> text ")"+ | (i,s) <- xs ]+ (text ",")+ <> text "}"+ pPrintPrec _d _ (PPoptions os) =+ text "options = {"+ <> sepList (map (text . show) os) (text ",")+ <> text "}"+ pPrintPrec _d _ (PPdoc comment) = text ("doc = " ++ doubleQuote comment)+ pPrintPrec _d _ (PPdeprecate comment) = text ("deprecate = " ++ doubleQuote comment)+ pPrintPrec _d _ (PPinst_hide) = text "hide"+ pPrintPrec _d _p v = text (drop 2 (show v))++ppPProp :: PDetail -> PProp -> Doc+ppPProp d pprop = text "{-#" <+> pPrintPrec d 0 pprop <+> text "#-};"++data RulePragma+ = RPfireWhenEnabled+ | RPnoImplicitConditions+ | RPaggressiveImplicitConditions+ | RPconservativeImplicitConditions+ | RPnoWarn -- suppress (on a per-rule basis) warnings G0023, G0036, and G0117+ | RPwarnAllConflicts+ | RPcanScheduleFirst+ | RPclockCrossingRule+ | RPdoc String -- comment to carry through to Verilog+ | RPhide+ deriving (Eq, Ord, Show)++-- used for classic printing of CSyntax+-- and by various internal dumps of ISyntax/ASyntax+instance Pretty RulePragma where+ pPrintPrec _d _p RPfireWhenEnabled = text "{-# ASSERT fire when enabled #-}"+ pPrintPrec _d _p RPnoImplicitConditions =+ text "{-# ASSERT no implicit conditions #-}"+ pPrintPrec _d _p RPcanScheduleFirst =+ text "{-# ASSERT can schedule first #-}"+ pPrintPrec _d _p RPaggressiveImplicitConditions =+ text "{-# aggressive_implicit_conditions #-}"+ pPrintPrec _d _p RPconservativeImplicitConditions =+ text "{-# conservative_implicit_conditions #-}"+ pPrintPrec _d _p RPnoWarn =+ text "{-# no_warn #-}"+ pPrintPrec _d _p RPwarnAllConflicts =+ text "{-# warn_all_conflicts #-}"+ pPrintPrec _d _p RPclockCrossingRule =+ text "{-# clock-crossing rule #-}"+ pPrintPrec _d _p (RPdoc comment) =+ text ("{-# doc = " ++ doubleQuote comment ++ " #-}")+ pPrintPrec _d _p RPhide =+ text ("{-# hide #-}")++data SchedulePragma id_t+ = SPUrgency [id_t]+ | SPExecutionOrder [id_t]+ | SPMutuallyExclusive [[id_t]]+ | SPConflictFree [[id_t]]+ | SPPreempt [id_t] [id_t]+ | SPSchedule (MethodConflictInfo id_t)+ deriving (Eq, Ord, Show)++instance (Pretty t, Ord t) => Pretty (SchedulePragma t) where+ pPrintPrec d p (SPUrgency ids) =+ text "{-# ASSERT descending urgency: " <+>+ pPrintPrec d p ids <+> text "#-}"+ pPrintPrec d p (SPExecutionOrder ids) =+ text "{-# ASSERT execution order: " <+>+ pPrintPrec d p ids <+> text "#-}"+ pPrintPrec d p (SPMutuallyExclusive idss) =+ text "{-# ASSERT mutually exclusive: " <+>+ pPrintPrec d p idss <+> text "#-}"+ pPrintPrec d p (SPConflictFree idss) =+ text "{-# ASSERT conflict-free: " <+>+ pPrintPrec d p idss <+> text "#-}"+ pPrintPrec d p (SPPreempt ids1 ids2) =+ text "{-# ASSERT preempt: " <+>+ pPrintPrec d p ids1 <+> pPrintPrec d p ids2 <+> text "#-}"+ pPrintPrec d p (SPSchedule s) =+ text "{-# ASSERT schedule: " <+>+ pPrintPrec d p s <+> text "#-}"++type CSchedulePragma = SchedulePragma Longname++-- Interface definition pragmas+-- These pragma are associated with interfaces and/or the fields within the interface+-- The first arg is the field name which the attribute is associated with+data IfcPragma+ = PIArgNames [Id] -- arg names used as dummy names (XX this can be removed?)+ | PIPrefixStr String -- Method or interface+ | PIResultName String -- name for the result of the method AV or value methods+ | PIRdySignalName String -- name for the ready signal on this method+ | PIEnSignalName String -- name for the enable signal+ | PIAlwaysRdy -- ifc or methods tagged as always ready+ | PIAlwaysEnabled -- ifc or methods tagged as always enabled+ deriving (Eq, Ord, Show)++instance Pretty IfcPragma where+ pPrintPrec d _ (PIArgNames ids) = text "arg_names =" <+>+ brackets ( (sepList (map (ppVarId d) ids) comma) )+ pPrintPrec _d _ (PIPrefixStr flds) = text "prefixs =" <+> doubleQuotes (text flds)+ pPrintPrec _d _ (PIRdySignalName flds) = text "ready =" <+> doubleQuotes (text flds)+ pPrintPrec _d _ (PIEnSignalName flds) = text "enable =" <+> doubleQuotes (text flds)+ pPrintPrec _d _ (PIResultName flds) = text "result =" <+> doubleQuotes (text flds)+ pPrintPrec _d _ (PIAlwaysRdy ) = text "always_ready "+ pPrintPrec _d _ (PIAlwaysEnabled ) = text "always_enabled "
+ src/Language/Bluespec/Classic/AST/SString.hs view
@@ -0,0 +1,10 @@+-- This corresponds to src/comp/SpeedyString.hs in bsc.+module Language.Bluespec.Classic.AST.SString+ ( SString+ ) where++import Data.Text (Text)++-- bsc represents SStrings as interned strings, but we simplify things as bit+-- and represent them as Text.+type SString = Text
+ src/Language/Bluespec/Classic/AST/SchedInfo.hs view
@@ -0,0 +1,120 @@+-- This corresponds to src/comp/SchedInfo.hs in bsc.+module Language.Bluespec.Classic.AST.SchedInfo+ ( SchedInfo(..)+ , MethodConflictInfo(..)+ , makeMethodConflictDocs+ ) where++import qualified Data.List as L+import qualified Data.Map as M+import qualified Data.Set as S+import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Prelude+import Language.Bluespec.Pretty++data SchedInfo idtype = SchedInfo {+ methodConflictInfo :: MethodConflictInfo idtype,+ -- methods which have a rule that must execute between them+ -- (in the given order) and the list of rules+ -- XXX should we include the rule names? they don't exist+ -- XXX on the boundary, but could be useful for debugging+ rulesBetweenMethods :: [((idtype, idtype), [idtype])],+ -- methods which have a rule that must execute before it+ -- along with the list of rules involved.+ -- Left = rule directly before this method+ -- Right = method called by this method which requires a rule before it+ rulesBeforeMethods :: [(idtype,[Either idtype idtype])],+ -- methods which allow an unsynchronized clock domain crossing+ clockCrossingMethods :: [idtype]+ }+ deriving (Eq, Ord, Show)++instance (Pretty idtype, Ord idtype) => Pretty (SchedInfo idtype) where+ pPrintPrec d _p si =+ sep [text "SchedInfo",+ pPrintPrec d 0 (methodConflictInfo si),+ pPrintPrec d 0 (rulesBetweenMethods si),+ pPrintPrec d 0 (rulesBeforeMethods si),+ pPrintPrec d 0 (clockCrossingMethods si)]++{- a CF b => a & b have the same effect when executed in parallel+ in the same rule, or when executed in either order+ in different rules in the same cycle.+ a SB b => a & b have the same effect when executed in parallel+ in the same rule, or when a is executed before b in+ different rules in the same cycle. Executing b before+ a within one cycle is illegal.+ ME [a,b,c] => only one of a,b or c can execute in any cycle.+ a P b => a & b may be executed in parallel within a single+ rule. It is illegal to execute a & b in the same+ cycle in two different rules, in any order.+ a SBR b => a may be executed before b in different rules in+ the same cycle. It is illegal to execute a & b in+ parallel in a single rule, or to execute b before a+ in two different rules in the same cycle.+ a C b => a & b may not execute in the same cycle, whether in+ one rule or two, in any order.+ EXT a => two executions of a cannot occur in one rule.+ a & b can execute in two different rules in the same+ cycle but the effect will be different. The+ difference must be resolved external to the module.+-}+data MethodConflictInfo idtype =+ MethodConflictInfo {+ sCF :: [(idtype, idtype)],+ sSB :: [(idtype, idtype)],+ sME :: [[idtype]],+ sP :: [(idtype, idtype)],+ sSBR :: [(idtype, idtype)],+ sC :: [(idtype, idtype)],+ sEXT :: [idtype]+ }+ deriving (Eq, Ord, Show)++instance (Pretty idtype, Ord idtype) => Pretty (MethodConflictInfo idtype) where+ pPrintPrec d p mci =+ let ds = makeMethodConflictDocs (pPrintPrec d p) ppReadable "[" "]" mci+ in text "[" <> sepList ds (text ",") <> text "]"++-- Given:+-- * a printing function for ids (pPrint or pvPrint)+-- * a function for turning the ids into strings for sorting order+-- * start and stop enclosure for a list (we assume comma-separated)+-- * a MethodConflictInfo structure+-- Produce:+-- a list of Doc for the MethodConflictInfo info+-- (un-factored from pairs to groups)+--+makeMethodConflictDocs :: (Ord idtype) =>+ (idtype -> Doc) ->+ (idtype -> String) ->+ String -> String ->+ MethodConflictInfo idtype -> [Doc]+makeMethodConflictDocs pId sId listStart listEnd+ (MethodConflictInfo { sCF=sCF0, sSB=sSB0, sME=sME0, sP=sP0,+ sSBR=sSBR0, sC=sC0, sEXT=sEXT0 }) =+ [pp m <+> text "CF" <+> pp m' | (m,m') <- toPairsOfLists sCF0 ] +++ [pp m <+> text "SB" <+> pp m' | (m,m') <- toPairsOfLists sSB0 ] +++ [ text "ME" <+> pp m | m <- sME_ordered ] +++ [pp m <+> text "P" <+> pp m' | (m,m') <- toPairsOfLists sP0 ] +++ [pp m <+> text "SBR" <+> pp m' | (m,m') <- toPairsOfLists sSBR0 ] +++ [pp m <+> text "C" <+> pp m' | (m,m') <- toPairsOfLists sC0 ] +++ (if null sEXT0 then [] else [text "EXT" <+> pp sEXT_ordered])+ where+ pp [m] = pId m+ pp ms =+ text listStart <> (sepList (map pId ms) (text ",")) <> text listEnd++ collect ps = M.fromListWith (S.union) [(a,S.singleton b) | (a,b) <- ps]+ toPairsOfLists ps = let m1 = collect ps+ m2 = collect [(s,a) | (a,s) <- M.toList m1]+ in sortLP [ (sortI (S.toList s2), sortI (S.toList s1))+ | (s1,s2) <- M.toList m2+ ]++ sortI = L.sortBy (\ i1 i2 -> (sId i1) `compare` (sId i2))+ sortL = L.sortBy (\ is1 is2 -> (map sId is1) `compare` (map sId is2))+ sortLP = L.sortBy (\(is1,_) (is2,_) -> (map sId is1) `compare` (map sId is2))+ sME_ordered = sortL (map sortI sME0)+ sEXT_ordered = sortI sEXT0
+ src/Language/Bluespec/Classic/AST/Syntax.hs view
@@ -0,0 +1,987 @@+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
+ src/Language/Bluespec/Classic/AST/Type.hs view
@@ -0,0 +1,283 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- This corresponds to src/comp/CType.hs in bsc.+module Language.Bluespec.Classic.AST.Type+ ( Type(..)+ , TyVar(..)+ , TyCon(..)+ , TISort(..)+ , StructSubType(..)+ , CType+ , Kind(..)+ , PartialKind(..)+ , CTypeclass(..)+ , CPred(..)+ , CQType(..)++ , baseKVar+ , cTNum+ , isTConArrow+ , isTConPair+ , leftCon+ ) where++import Data.Char (chr)+import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Classic.AST.Builtin.Ids+import Language.Bluespec.Classic.AST.FString+import Language.Bluespec.Classic.AST.Id+import Language.Bluespec.Classic.AST.Position+import Language.Bluespec.Classic.AST.Pragma+import Language.Bluespec.Prelude+import Language.Bluespec.Pretty+import Language.Bluespec.Util++-- | Representation of types+data Type = TVar TyVar -- ^ type variable+ | TCon TyCon -- ^ type constructor+ | TAp Type Type -- ^ type-level application+ | TGen Position Int -- ^ quantified type variable used in type schemes+ | TDefMonad Position -- ^ not used after CVParserImperative+ deriving Show++instance Eq Type where+ x == y = cmp x y == EQ++instance Ord Type where+ compare x y = cmp x y++instance Pretty Type where+ pPrintPrec _d _p (TCon (TyCon unit _ _)) | unit == idPrimUnit = text "()"+ pPrintPrec d _p (TCon c) = pPrintPrec d 0 c+ pPrintPrec d _p (TVar i) = pPrintPrec d 0 i+ pPrintPrec d p (TAp (TAp (TCon pair) a) b) | isTConPair pair =+ pparen (p >= 0) (sep [pPrintPrec d 0 a <> text ",", pPrintPrec d (-1) b])+ pPrintPrec d p (TAp (TAp (TCon arr) a) r) | isTConArrow arr =+ pparen (p > 8) (sep [pPrintPrec d 9 a <+> text "->", pPrintPrec d 8 r])+ pPrintPrec d p (TAp e e') = pparen (p>9) $+ sep [pPrintPrec d 9 e, pPrintPrec d 10 e']+ pPrintPrec _d _p (TDefMonad _) = text ("TDefMonad")+ pPrintPrec d p (TGen _ n) = pparen True (text "TGen" <+> pPrintPrec d p n)++instance HasPosition Type where+ getPosition (TVar var) = getPosition var+ getPosition (TCon con) = getPosition con+ getPosition (TAp f a) = getPosition f `bestPosition` getPosition a+ getPosition (TGen pos _) = pos+ getPosition (TDefMonad pos) = pos++cTNum :: Integer -> Position -> CType+cTNum n pos = TCon (TyNum n pos)++isTConArrow :: TyCon -> Bool+isTConArrow (TyCon i _ _) = i == idArrow noPosition+isTConArrow t = error("isTConArrow: not TCon " ++ show t)++isTConPair :: TyCon -> Bool+isTConPair (TyCon i _ _) = i == idPrimPair+isTConPair t = error("isTConPair: not TCon " ++ show t)++-- | used to do the sorting of instances+-- so that overlapping matches go to the most specific+-- TAp first because it brings forward instances with larger structure+-- see the Has_tpl_n instances in the Prelude+cmp :: Type -> Type -> Ordering+cmp (TAp f1 a1) (TAp f2 a2) = compare (f1, a1) (f2, a2)+cmp (TAp _ _) _ = LT+cmp (TCon c1) (TCon c2) = compare c1 c2+cmp (TCon _) (TAp _ _) = GT+cmp (TCon _) _ = LT+cmp (TVar _) (TCon _) = GT+cmp (TVar _) (TAp _ _) = GT+cmp (TVar v1) (TVar v2) = compare v1 v2+cmp (TVar _) _ = LT+cmp (TGen _ i1) (TGen _ i2) = compare i1 i2+cmp (TGen _ _) (TDefMonad _) = LT+cmp (TGen _ _) _ = GT+cmp (TDefMonad _) (TDefMonad _) = EQ+cmp (TDefMonad _) _ = GT++-- | Representation of a type variable+data TyVar = TyVar { tv_name :: Id -- ^ name of the type variable+ , tv_num :: Int -- ^ number for a generated type variable+ , tv_kind :: Kind -- ^ kind of the type variable+ }+ deriving Show++instance Eq TyVar where+ TyVar i n _ == TyVar i' n' _ = (n, i) == (n', i')++instance Ord TyVar where+ TyVar i n _ <= TyVar i' n' _ = (n, i) <= (n', i')+ TyVar i n _ < TyVar i' n' _ = (n, i) < (n', i')+ TyVar i n _ >= TyVar i' n' _ = (n, i) >= (n', i')+ TyVar i n _ > TyVar i' n' _ = (n, i) > (n', i')+ TyVar i n _ `compare` TyVar i' n' _ = (n, i) `compare` (n', i')++instance Pretty TyVar where+ pPrintPrec d _ (TyVar i _ _) = ppVarId d i++instance HasPosition TyVar where+ getPosition (TyVar name _ _) = getPosition name++-- | Representation of a type constructor+data TyCon = -- | A constructor for a type of value kind+ TyCon { tcon_name :: Id -- ^ name of the type constructor+ , tcon_kind :: (Maybe Kind) -- ^ kind of the type constructor+ , tcon_sort :: TISort -- ^ purpose of the type constructor+ }+ -- | A constructor for a type of numeric kind+ | TyNum { tynum_value :: Integer -- ^ type-level numeric value+ , tynum_pos :: Position -- ^ position of introduction+ }+ -- | A constructor for a type of string kind+ | TyStr { tystr_value :: FString -- ^ type-level string value+ , tystr_pos :: Position -- ^ position of introduction+ }+ deriving Show++instance Eq TyCon where+ TyCon i k _ == TyCon i' k' _ = qualEq i i' && k == k'+ TyNum i _ == TyNum i' _ = i == i'+ TyStr s _ == TyStr s' _ = s == s'+ _ == _ = False++instance Ord TyCon where+ TyCon i k _ `compare` TyCon i' k' _ = (getIdBase i, getIdQual i, k) `compare` (getIdBase i', getIdQual i', k')+ TyCon _ _ _ `compare` TyNum _ _ = LT+ TyCon _ _ _ `compare` TyStr _ _ = LT+ TyNum _ _ `compare` TyCon _ _ _ = GT+ TyNum i _ `compare` TyNum i' _ = i `compare` i'+ TyNum _ _ `compare` TyStr _ _ = LT+ TyStr _ _ `compare` TyCon _ _ _ = GT+ TyStr _ _ `compare` TyNum _ _ = GT+ TyStr s _ `compare` TyStr s' _ = s `compare` s'++instance Pretty TyCon where+ pPrintPrec d _ (TyCon i _ _) = ppConId d i+ pPrintPrec _d _ (TyNum i _) = text (itos i)+ pPrintPrec _d _ (TyStr s _) = text (show s)++instance HasPosition TyCon where+ getPosition (TyCon name _k _) = getPosition name+ getPosition (TyNum _ pos) = pos+ getPosition (TyStr _ pos) = pos++data TISort+ = -- type synonym+ TItype Integer Type+ | TIdata { tidata_cons :: [Id]+ , tidata_enum :: Bool+ }+ | TIstruct StructSubType [Id]+ -- primitive abstract type+ -- e.g. Integer, Bit, Module, etc.+ | TIabstract+ deriving (Eq, Ord, Show)++instance Pretty TISort where+ pPrintPrec d p (TItype n t) = pparen (p>0) $ text "TItype" <+> pPrintPrec d 0 n <+> pPrintPrec d 1 t+ pPrintPrec d p (TIdata is enum) = pparen (p>0) $ text (if enum then "TIdata (enum)" else "TIdata") <+> pPrintPrec d 1 is+ pPrintPrec d p (TIstruct ss is) = pparen (p>0) $ text "TIstruct" <+> pPrintPrec d 1 ss <+> pPrintPrec d 1 is+ pPrintPrec _d _p (TIabstract) = text "TIabstract"++data StructSubType+ = SStruct+ | SClass+ | SDataCon { sdatacon_id :: Id+ , sdatacon_named_fields :: Bool+ }+ | SInterface [IfcPragma]+ | SPolyWrap { spolywrap_id :: Id -- ^ name of the type with the wrapped field+ , spolywrap_ctor :: Maybe Id -- ^ name of the data constructor+ , spolywrap_field :: Id -- ^ name of the wrapped field+ }+ deriving (Eq, Ord, Show)++instance Pretty StructSubType where+ pPrintPrec _ _ ss = text (show ss)++type CType = Type++leftCon :: CType -> Maybe Id+leftCon (TAp f _) = leftCon f+leftCon (TCon (TyCon i _ _)) = Just i+leftCon _ = Nothing++-- | Representation of kinds+data Kind = KStar -- ^ kind of a simple value type+ | KNum -- ^ kind of a simple numeric type+ | KStr -- ^ kind of a simple string type+ | Kfun Kind Kind -- ^ kind of type constructors (type-level function)+ | KVar Int -- ^ generated kind variable (used only during kind inference)+ deriving (Eq, Ord, Show)++instance Pretty Kind where+ pPrintPrec _ _ KStar = text "*"+ pPrintPrec _ _ KNum = text "#"+ pPrintPrec _ _ KStr = text "$"+ pPrintPrec d p (Kfun l r) = pparen (p>9) $ pPrintPrec d 10 l <+> text "->" <+> pPrintPrec d 9 r+ pPrintPrec _ _ (KVar i) = text (showKVar i)++-- KIMisc.newKVar starts at this number+baseKVar :: Int+baseKVar = 1000++-- Display the kind variable with letters+showKVar :: Int -> String+showKVar v =+ let+ makeDigit x = chr (x + 97) -- 97 = ASCII a++ showDigits :: Int -> String+ showDigits x | (x < 26) = [makeDigit x]+ showDigits x = (showDigits (x `div` 26)) ++ [makeDigit (x `mod` 26)]+ in+ if (v < baseKVar)+ then (itos v)+ else (showDigits (v - baseKVar))++-- Used for providing partial Kind information+data PartialKind+ = PKNoInfo -- this is what makes it partial+ | PKStar+ | PKNum+ | PKStr+ | PKfun PartialKind PartialKind+ deriving (Eq, Ord, Show)++instance Pretty PartialKind where+ pPrintPrec _ _ PKNoInfo = text "?"+ pPrintPrec _ _ PKStar = text "*"+ pPrintPrec _ _ PKNum = text "#"+ pPrintPrec _ _ PKStr = text "$"+ pPrintPrec d p (PKfun l r) =+ pparen (p>9) $ pPrintPrec d 10 l <+> text "->" <+> pPrintPrec d 9 r++-- | A named typeclass+newtype CTypeclass = CTypeclass Id+ deriving (Eq, Ord, Show, Pretty, HasPosition)++-- | Representation of the provisos and other class constraints+data CPred = CPred { cpred_tc :: CTypeclass -- ^ constraint class, e.g., "Eq"+ , cpred_args :: [CType] -- ^ argument types+ }+ deriving (Eq, Ord, Show)++instance Pretty CPred where+ pPrintPrec d _p (CPred (CTypeclass c) []) = ppConId d c+ pPrintPrec d _p (CPred (CTypeclass c) ts) = ppConId d c <+> sep (map (pPrintPrec d (fromIntegral (maxPrec+1))) ts)++instance HasPosition CPred where+ getPosition (CPred c ts) = getPosition (c, ts)++data CQType = CQType [CPred] CType+ deriving (Eq, Ord, Show)++instance Pretty CQType where+ pPrintPrec d p (CQType [] ct) = pPrintPrec d p ct+ pPrintPrec d _p (CQType preds ct) = sep [text "(" <> sepList (map (pPrintPrec d 0) preds) (text ",") <> text ")" <+> text "=>", pPrintPrec d 0 ct]++instance HasPosition CQType where+ -- prefer t to ps, since that is a better position for BSV+ getPosition (CQType ps t) = getPosition t `bestPosition` getPosition ps
+ src/Language/Bluespec/Classic/AST/Undefined.hs view
@@ -0,0 +1,22 @@+-- This corresponds to src/comp/Undefined.hs in bsc.+module Language.Bluespec.Classic.AST.Undefined+ ( UndefKind(..)+ ) where++import Language.Bluespec.Prelude++-- Undefined values in BSC carry information about their origin.+-- (The evaluator uses this for choosing error messages and optimizations.)++-- * UNotUsed is for values that we expect will never be used, such as+-- in unreachable code or the return value for an expression whose value+-- is unused.++-- * UNoMatch is the value returned from a case expression when no arm+-- matches but some value still needs to be returned.++-- * UDontCare is an explicit dont-care value written by the user, or+-- any other dont-care value that doesn't fit the above kinds.++data UndefKind = UNotUsed | UDontCare | UNoMatch+ deriving (Eq, Ord, Show)
+ src/Language/Bluespec/Classic/AST/VModInfo.hs view
@@ -0,0 +1,259 @@+-- This corresponds to src/comp/VModInfo.hs in bsc.+module Language.Bluespec.Classic.AST.VModInfo+ ( VName(..)+ , VPathInfo(..)+ , VeriPortProp(..)+ , VArgInfo(..)+ , VPort+ , VSchedInfo+ , VFieldInfo(..)+ , InputClockInf+ , OutputClockInf+ , VOscPort+ , VInputGatePort+ , VOutputGatePort+ , VClockInfo(..)+ , ResetInf+ , VResetInfo(..)+ ) where++import qualified Data.List as L+import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Classic.AST.Id+import Language.Bluespec.Classic.AST.Position+import Language.Bluespec.Classic.AST.SchedInfo+import Language.Bluespec.Prelude+import Language.Bluespec.Pretty++newtype VName = VName String+ deriving (Eq, Ord, Show)++instance Pretty VName where+ pPrintPrec _ _ (VName s) = text s++newtype VPathInfo = VPathInfo [(VName, VName)]+ deriving (Eq, Ord, Show)++instance Pretty VPathInfo where+ pPrintPrec _d _p (VPathInfo []) =+ s2par "No combinational paths from inputs to outputs"+ pPrintPrec d p (VPathInfo nns) =+ let+ -- function to join paths going to the same output+ joinPaths [] = []+ joinPaths zs@((_,o):_) =+ case (L.partition ((== o) . snd) zs) of+ (xs, ys) -> (map fst xs, o) : joinPaths ys++ -- function to display one pair+ ppOne ([i],out) = pPrintPrec d p i <+> text "->" <+> pPrintPrec d p out+ ppOne (ins,out) = text "(" <>+ sepList (map (pPrintPrec d p) ins) (text ",") <>+ text ")" <+> text "->" <+> pPrintPrec d p out+ in+ s2par "Combinational paths from inputs to outputs:" $+$+ nest 2 (vcat (map ppOne (joinPaths nns)))++instance HasPosition VFieldInfo where+ getPosition (Method { vf_name = n }) = getPosition n+ getPosition (Clock i) = getPosition i -- or noPosition?+ getPosition (Reset i) = getPosition i -- or noPosition?+ getPosition (Inout { vf_name = n }) = getPosition n++-- the order is important for VIOProps ("unused" should come last)+data VeriPortProp = VPreg+ | VPconst+ | VPinhigh+ | VPouthigh+ | VPclock+ | VPclockgate+ | VPreset+ | VPinout+ | VPunused+ deriving (Eq, Ord, Show)++instance Pretty VeriPortProp where+ pPrintPrec _ _ VPreg = text "reg"+ pPrintPrec _ _ VPclock = text "clock"+ pPrintPrec _ _ VPconst = text "const"+ pPrintPrec _ _ VPinhigh = text "inhigh"+ pPrintPrec _ _ VPouthigh = text "outhigh"+ pPrintPrec _ _ VPunused = text "unused"+ pPrintPrec _ _ VPreset = text "reset"+ pPrintPrec _ _ VPinout = text "inout"+ pPrintPrec _ _ VPclockgate = text "clock gate"++data VArgInfo = Param VName -- named module parameter+ -- named module port, with associated clock and reset+ | Port VPort (Maybe Id) (Maybe Id)+ | ClockArg Id -- named clock+ | ResetArg Id -- named reset+ -- named module inout, with associated clock and reset+ | InoutArg VName (Maybe Id) (Maybe Id)+ deriving (Eq, Ord, Show)++instance Pretty VArgInfo where+ pPrintPrec d _p (Param x) = text "param " <> pPrintPrec d 0 x <> text ";"+ pPrintPrec d _p (Port x mclk mrst) =+ text "port " <> pPrintPrec d 0 x <+>+ ppMClk d mclk <+> ppMRst d mrst <>+ text ";"+ pPrintPrec d p (ClockArg x) = text "clockarg " <> pPrintPrec d p x <> text ";"+ pPrintPrec d p (ResetArg x) = text "resetarg " <> pPrintPrec d p x <> text ";"+ pPrintPrec d _p (InoutArg x mclk mrst) =+ text "inoutarg " <> pPrintPrec d 0 x <+>+ ppMClk d mclk <+> ppMRst d mrst <>+ text ";"++ppMClk :: PDetail -> Maybe Id -> Doc+ppMClk d mclk =+ let clk = case mclk of+ Nothing -> text "no_clock"+ Just c -> pPrintPrec d 0 c+ in text "clocked_by (" <> clk <> text ")"++ppMRst :: PDetail -> Maybe Id -> Doc+ppMRst d mrst =+ let rst = case mrst of+ Nothing -> text "no_reset"+ Just r -> pPrintPrec d 0 r+ in text "reset_by (" <> rst <> text ")"++type VPort = (VName, [VeriPortProp])++type VSchedInfo = SchedInfo Id++-- XXX why does the VFieldInfo not contain a ready signal?+data VFieldInfo = Method { vf_name :: Id, -- method name+ vf_clock :: (Maybe Id), -- optional clock+ -- optional because the method may be combinational+ vf_reset :: (Maybe Id), -- optional reset+ -- optional because the method may be independent of a reset signal+ vf_mult :: Integer, -- multiplicity+ vf_inputs :: [VPort],+ vf_output :: Maybe VPort,+ vf_enable :: Maybe VPort }+ | Clock { vf_name :: Id } -- output clock name+ -- connection information is in the ClockInfo+ | Reset { vf_name :: Id } -- output reset name+ -- connection information is in the ResetInfo+ | Inout { vf_name :: Id, -- output inout name+ vf_inout :: VName,+ vf_clock :: (Maybe Id), -- optional clock+ vf_reset :: (Maybe Id) } -- optional reset+ deriving (Eq, Ord, Show)++instance Pretty VFieldInfo where+ pPrintPrec d p (Method n c r m i o e) =+ text "method " <> pout o <> pPrintPrec d p n <> pmult m <>+ pins i <> pena e <+> ppMClk d c <+> ppMRst d r <>+ text ";"+ where pout Nothing = empty+ pout (Just po) = pPrintPrec d p po+ pmult 1 = empty+ pmult n' = text "[" <> pPrintPrec d p n' <> text "]"+ pins [] = empty+ pins i' = text "(" <> sepList (map (pPrintPrec d p) i') (text ",") <> text ")"+ pena Nothing = empty+ pena (Just en) = text " enable (" <> pPrintPrec d p en <> text ")"+ pPrintPrec d p (Clock i) = text "clock " <> pPrintPrec d p i <> text ";"+ pPrintPrec d p (Reset i) = text "reset " <> pPrintPrec d p i <> text ";"+ pPrintPrec d p (Inout n port c r) =+ text "inout " <> pPrintPrec d p n <+>+ text "(" <> pPrintPrec d p port <> text ")" <+>+ ppMClk d c <+> ppMRst d r <> text ";"++-- describes the clocks imported by a module+type InputClockInf = (Id, Maybe (VOscPort, VInputGatePort))++-- describes the clocks exported by a module+type OutputClockInf = (Id, Maybe (VOscPort, VOutputGatePort))++-- no VeriPortProp needed, so we use VName and not VPort+type VOscPort = VName++-- gate port for input clocks+-- Either there is no port, in which case the boolean indicates+-- whether the gate is assumed True or is unneeded, or there is gate port.+type VInputGatePort = Either Bool VName++-- gate port for output clocks+-- Either there is no port, in which case users should assume a value True,+-- or there is a port, and we annotate whether it is "outhigh" with a+-- port property (VPouthigh)+type VOutputGatePort = Maybe VPort++data VClockInfo = ClockInfo {+ -- named list of input clocks+ input_clocks :: [InputClockInf],+ -- named list of output clocks+ output_clocks :: [OutputClockInf],+ -- edges in the ancestor relationships (transitive)+ -- first clock is parent, second is child+ ancestorClocks :: [(Id, Id)],+ -- other sibling relationships+ -- transitive (but often trumped by ancestry)+ -- method calls are permitted across sibling relationships+ -- but *both* gate conditions must be enforced+ siblingClocks :: [(Id, Id)] }+ deriving (Eq, Ord, Show)++instance Pretty VClockInfo where+ pPrintPrec d _p (ClockInfo in_cs out_cs as ss) =+ vcat (map pOutCInf out_cs +++ map pInCInf in_cs +++ map pAnc as +++ map pSib ss)+ where+ pOutCInf (i,mc) = text "clock " <> pPrintPrec d 0 i <>+ text "(" <> pOutMClk mc <> text ");"+ pOutMClk Nothing = empty+ pOutMClk (Just (vn, mg)) = pPrintPrec d 0 vn <> pOutMGate mg+ pOutMGate Nothing = empty+ pOutMGate (Just (vn, vpps)) =+ text ", " <> pPortProps vpps <> pPrintPrec d 0 vn+ pPortProps [] = empty+ pPortProps (vp:vpps) =+ text "{-" <> pPrintPrec d 0 vp <> text "-} " <> pPortProps vpps++ pInCInf (i,mc) = text "clock " <> pPrintPrec d 0 i <>+ text "(" <> pInMClk mc <> text ");"+ pInMClk Nothing = empty+ pInMClk (Just (vn, mg)) = pPrintPrec d 0 vn <> pInMGate mg+ pInMGate (Left True) = text ", {-inhigh-}"+ pInMGate (Left False) = text ", {-unused-}"+ pInMGate (Right vn) = text ", " <> pPrintPrec d 0 vn++ pAnc (i,j) = text "ancestor (" <> pPrintPrec d 0 i <> text ", " <>+ pPrintPrec d 0 j <> text ");"+ pSib (i,j) = text "sibling (" <> pPrintPrec d 0 i <> text ", " <>+ pPrintPrec d 0 j <> text ");"++instance HasPosition VClockInfo where+ getPosition (ClockInfo { output_clocks = ((id',_):_)}) = getPosition id'+ getPosition (ClockInfo { input_clocks = ((id',_):_)}) = getPosition id'+ getPosition _ = noPosition++-- reset name, Verilog port (optional), clock (optional)+type ResetInf = (Id, (Maybe VName, Maybe Id))++-- basic information on reset signals+-- more information to be added (sync/async, clock relationships, etc.)+data VResetInfo = ResetInfo {+ input_resets :: [ResetInf],+ output_resets :: [ResetInf]+ }+ deriving (Eq, Ord, Show)++instance Pretty VResetInfo where+ pPrintPrec d p (ResetInfo in_rs out_rs) = vcat (map pRInf (out_rs ++ in_rs))+ where t = text+ pRInf (i,(mn,mc)) =+ t"reset " <> pPrintPrec d p i <>+ t"(" <> pMRst mn <> t")" <+>+ t"clocked_by(" <> pMClk mc <> t");"+ pMRst Nothing = empty+ pMRst (Just n) = pPrintPrec d p n+ pMClk Nothing = t"no_clock"+ pMClk (Just c) = pPrintPrec d p c
+ src/Language/Bluespec/IntegerUtil.hs view
@@ -0,0 +1,42 @@+-- This corresponds to src/comp/IntegerUtil.hs in bsc.+module Language.Bluespec.IntegerUtil+ ( integerFormat+ , integerFormatPref+ , integerToString+ ) where++import Language.Bluespec.Prelude++integerFormat :: Integer -> Integer -> Integer -> String+integerFormat width base value =+ if value < 0 then+ '-' : integerFormat width base (-value)+ else+ let s = integerToString (fromInteger base) value+ l = length s+ w = fromInteger width+ pad = if l < w then replicate (w-l) '0' else ""+ in pad ++ s++integerFormatPref :: Integer -> Integer -> Integer -> String+integerFormatPref width 2 value = "0b" ++ integerFormat width 2 value+integerFormatPref width 8 value = "0o" ++ integerFormat width 8 value+integerFormatPref width 10 value = integerFormat width 10 value+integerFormatPref width 16 value = "0x" ++ integerFormat width 16 value+-- otherwise, use decimal+integerFormatPref width _ value = integerFormatPref width 10 value++integerToString :: Int -> Integer -> String+integerToString b i | b < 2 = error "integerToString: base must be >= 2"+ | i < 0 = '-' : showIntBase (toInteger b) (negate i) ""+ | otherwise = showIntBase (toInteger b) i ""++-- mostly duplicates the function in the Prelude from the Haskell 98 Report+showIntBase :: Integer -> Integer -> String -> String+showIntBase b n r | n < 0 = error "Numeric.showInt: can't show negative numbers"+ | otherwise =+ let (n',d) = quotRem n b+ r' = digit d : r+ digit d' | d' < 10 = toEnum (fromEnum '0' + fromIntegral d')+ | otherwise = toEnum (fromEnum 'A' + fromIntegral d' - 10)+ in if n' == 0 then r' else showIntBase b n' r'
+ src/Language/Bluespec/Lex.hs view
@@ -0,0 +1,37 @@+-- This corresponds to src/comp/Lex.hs in bsc.+module Language.Bluespec.Lex+ ( isIdChar+ , isSym+ ) where++import Data.Char (isAlphaNum)++import Language.Bluespec.Prelude++isSym :: Char -> Bool+isSym '!' = True; isSym '@' = True; isSym '#' = True; isSym '$' = True+isSym '%' = True; isSym '&' = True; isSym '*' = True; isSym '+' = True+isSym '.' = True; isSym '/' = True; isSym '<' = True; isSym '=' = True+isSym '>' = True; isSym '?' = True; isSym '\\' = True; isSym '^' = True+isSym '|' = True; isSym ':' = True; isSym '-' = True; isSym '~' = True+isSym ',' = True+isSym c | c >= '\x80' = c `elem` ['\162', '\163', '\164', '\165', '\166',+ '\167', '\168', '\169', '\170', '\171',+ '\172', '\173', '\174', '\175', '\176',+ '\177', '\178', '\179', '\180', '\181',+ '\183', '\184', '\185', '\186', '\187',+ '\188', '\189', '\190', '\191', '\215',+ '\247' ]++--isSym c | c >= '\x80' = isSymbol c+isSym _ = False++isIdChar :: Char -> Bool+isIdChar '\'' = True+isIdChar '_' = True++-- \176 (hexB0) (octal 0260) is the degree symbol+isIdChar '\176' = True+-- \180 (hexB4) (octal 0264) is the prime (acute accent) symbol+isIdChar '\180' = True+isIdChar c = isAlphaNum c
+ src/Language/Bluespec/Log2.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+-- This corresponds to src/comp/Log2.hs in bsc.+module Language.Bluespec.Log2+ ( log2+ ) where++import Data.Bits+import GHC.Exts++-- GHC 9.0 has an entirely new ghc-bignum package.+-- See https://iohk.io/en/blog/posts/2020/07/28/improving-haskells-big-numbers-support/+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 900)+import GHC.Num.Integer (Integer(IS, IP, IN))+import GHC.Num.BigNat+#else+import GHC.Integer.GMP.Internals+#endif++import Language.Bluespec.Prelude++-- In GHC 7.8, internal primops return Int# instead of Bool+eqInt, neqInt :: Int# -> Int# -> Bool+{-# INLINE eqInt #-}+{-# INLINE neqInt #-}+eqInt a b = isTrue# (a ==# b)+neqInt a b = isTrue# (a /=# b)++-- |Number of bits in an Int (or Int#) on this machine+wordSize :: Int+wordSize = finiteBitSize (0 :: Int)++-- |Compute the logarithm base 2, rounded up, for Integral types.+-- One interpretation of this log2 function is that it tells you+-- the minimum number of bits required to represent a given number+-- of distinct values.+log2 :: (Integral a, Integral b) => a -> b+log2 0 = 0+log2 x = case (toInteger x) of+ -- for values which fit in a single word, we+ -- find the index of the most significant non-zero+ -- bit. if all other bits are zero, then this is+ -- the value of the base 2 log, otherwise we must+ -- add one to the value to get the base 2 log.+ -- 'small' integer that fits in a single word+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 900)+ IS n -> let !(top_one,any_other_ones) = analyze (I# n)+ in toEnum (top_one + (if any_other_ones then 1 else 0))+#else+ S# n -> let !(top_one,any_other_ones) = analyze (I# n)+ in toEnum (top_one + (if any_other_ones then 1 else 0))+#endif+ -- for values which exceed the word size, we use the+ -- log2large function to examine the values in the array.+ -- positive and negative multiword integers respectively+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 900)+ IP bn -> let sz = bigNatSize# bn+ in log2large (sz -# 1#) bn+ IN bn -> let sz = bigNatSize# bn+ in log2large (sz -# 1#) bn+#else+ Jp# bn@(BN# arr) -> let sz = sizeofBigNat# bn+ in log2large (sz -# 1#) arr+ Jn# bn@(BN# arr) -> let sz = sizeofBigNat# bn+ in log2large (sz -# 1#) arr+#endif++-- |Utility function to find the index of the most significant+-- non-zero bit in a single-word Int and also report if any+-- other bits are non-zero. Note: this assumes n /= 0.+analyze :: Int -> (Int,Bool)+analyze n = helper n (wordSize - 1)+ where helper v idx = if (testBit v idx)+ then (idx, (clearBit v idx) /= 0)+ else helper n (idx - 1)++-- |Utility function to determine if any words in a ByteArray#+-- up to a given index are non-zero.+anyNonZero :: ByteArray# -> Int# -> Bool+anyNonZero arr idx = if (indexIntArray# arr idx) `neqInt` 0#+ then True+ else (idx `neqInt` 0#) && (anyNonZero arr (idx -# 1#))++-- |Compute the log2 for Integers which span multiple words. This+-- first scans the memory for the most significant word that is not 0.+-- Then it analyzes that word to determine, along with the word's+-- index, the provisional logarithm value, If that word had any+-- additional non-zero bits, or if any other words in the ByteArray#+-- are non-zero, then the actual logarithm will be one more than the+-- provisional value.+log2large :: (Integral b) => Int# -> ByteArray# -> b+log2large i arr =+ let !w = indexIntArray# arr i+ in if w `eqInt` 0#+ then if i `eqInt` 0# then 0 else log2large (i -# 1#) arr+ else let !(top_one,any_other_ones) = analyze (I# w)+ base = (wordSize * (I# i) + top_one)+ in if any_other_ones || ((i `neqInt` 0#) && (anyNonZero arr (i -# 1#)))+ then toEnum (base + 1)+ else toEnum base
+ src/Language/Bluespec/Prelude.hs view
@@ -0,0 +1,8 @@+-- Unfortunately, the (<>) function from the Prelude has a different fixity than+-- the (<>) function from the pretty library, so we avoid re-exporting (<>) from+-- the Prelude to avoid fixity clashes.+module Language.Bluespec.Prelude+ ( module Prelude+ ) where++import Prelude hiding ((<>))
+ src/Language/Bluespec/Pretty.hs view
@@ -0,0 +1,98 @@+-- This adapts definitions found in src/comp/PPrint.hs and src/comp/Pretty.hs+-- in bsc.+module Language.Bluespec.Pretty+ ( PDetail+ , pdReadable+ , pdAll+ , pdDebug+ , pdMark+ , pdInfo+ , pdNoqual++ , ppReadable+ , ppReadableIndent+ , ppAll+ , ppDebug++ , pparen+ , sepList+ , ppr+ , maxPrec++ , s2par+ ) where++import Text.PrettyPrint.HughesPJClass++import Language.Bluespec.Prelude++type PDetail = PrettyLevel++pdReadable :: PDetail+pdReadable = PrettyLevel 1++pdAll :: PDetail+pdAll = PrettyLevel 2++pdDebug :: PDetail+pdDebug = PrettyLevel 3++pdMark :: PDetail+pdMark = PrettyLevel 4++pdInfo :: PDetail+pdInfo = PrettyLevel 5++pdNoqual :: PDetail+pdNoqual = PrettyLevel 6++ppReadable :: Pretty a => a -> String+ppReadable = ppr pdReadable++ppReadableIndent :: Pretty a => Int -> a -> String+ppReadableIndent i = pprIndent i pdReadable++ppAll :: Pretty a => a -> String+ppAll = ppr pdAll++ppDebug :: Pretty a => a -> String+ppDebug = ppr pdDebug++pparen :: Bool -> Doc -> Doc+pparen False x = x+pparen True x = text"(" <> x <> text")"++sepList :: [Doc] -> Doc -> Doc+sepList [] _ = empty+sepList xs s = sep (map (\x->x <> s) (init xs) ++ [last xs])++maxPrec :: Int+maxPrec = 20++ppr :: Pretty a => PDetail -> a -> String+ppr d = pretty lineWidth linePref . pPrintPrec d 0++pprIndent :: Pretty a => Int -> PDetail -> a -> String+pprIndent i d = pretty lineWidth linePref . nest i . pPrintPrec d 0++lineWidth, linePref :: Int+lineWidth = 120+linePref = 100++-- Produces a string from a text "x" in Normal mode with "w" line+-- length, "w/m" ribbons per line.+pretty :: Int -> Int -> Doc -> String+pretty w m x = fullRender PageMode w (toEnum w / toEnum m) string_txt "\n" x++-- The function which tells fullRender how to compose Doc elements+-- into a String.+string_txt :: TextDetails -> String -> String+string_txt (Chr c) s = c:s+string_txt (Str s1) s2 = s1 ++ s2+string_txt (PStr s1) s2 = s1 ++ s2++-- Pretty printing utilities++-- Creates a paragraph+s2par :: String -> Doc+s2par str = fsep $ map text (words str)
+ src/Language/Bluespec/Util.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE FlexibleInstances #-}+-- This corresponds to src/comp/Util.hs in bsc.+module Language.Bluespec.Util+ ( dbgLevel+ , doubleQuote+ , ToString(..)+ ) where++import Data.Char (intToDigit)++import Language.Bluespec.Prelude++-- =====+-- Configurable traces+-- (currently only used in Id and XRef)++dbgLevel :: Int+dbgLevel = -1++-- =====+-- String utilities++doubleQuote :: String -> String+doubleQuote s = "\"" ++ s ++ "\""++-- =====+-- ToString class++class ToString a where+ to_string :: a -> String+ itos :: a -> String++instance ToString Int where+ itos a = show a+ to_string a = error ("to_string applied to nonsymbol (Int) "+ ++ show a)++instance ToString Integer where+ itos a = show a+ to_string a = error ("to_string applied to nonsymbol (Integer) "+ ++ show a)++instance ToString Char where+ itos a = show a+ to_string a = case a of+ '\n' -> "\\n"+ '\r' -> "\\r"+ '\t' -> "\\t"+ '\a' -> "\\a"+ '\\' -> "\\\\"+ '"' -> "\\\"" -- backslash double-quote+ _ | n < 0 ||+ n > 0x100 -> error $ "quoting a character value " ++ show n+ _ | n < 0x20 || n >= 0x7F ->+ [ '\\', intToDigit highest, intToDigit middle, intToDigit lowest ]+ _ -> [a]+ where+ n = fromEnum a+ (top2, lowest) = quotRem n 8+ (highest, middle) = quotRem top2 8++instance ToString String where+ itos a = error $ "itos applied to string " ++ show a+ to_string a = concatMap to_string a