diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for language-c99 + +## 0.1.0.0 -- 2019-03-30 + +* First version. Containing full AST, but only a part of the pretty printer. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2018-2019 Frank Dedden + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/language-c99.cabal b/language-c99.cabal new file mode 100644 --- /dev/null +++ b/language-c99.cabal @@ -0,0 +1,44 @@ +-- Initial language-c99.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: language-c99 +version: 0.1.0.0 +synopsis: An implementation of the C99 AST that strictly follows the + standard. +description: + This package contains an implementation of the C99 AST as described in + . Sticking closely + to this standard assures us that the program we deal with is a valid C99 + program. + . + Additionally the library comes with a pretty printer. + . + The package does not come with handy wrapper and utility functions to write a + C99 program, it just contains the bare AST. It is highly recommended to use + the wrapper provided by 'language-c99-simple' and 'language-c99-util' for + writing programs. + +license: MIT +license-file: LICENSE +author: Frank Dedden +maintainer: Frank Dedden +-- copyright: +category: Language +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +source-repository head + type: git + location: git://github.com:fdedden/language-c99.git + +library + exposed-modules: Language.C99 + , Language.C99.AST + , Language.C99.Pretty + -- other-modules: + -- other-extensions: + build-depends: base >=4.9 && <5, + pretty >= 1.1.3 && < 1.2 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/src/Language/C99.hs b/src/Language/C99.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99.hs @@ -0,0 +1,5 @@ +module Language.C99 + ( module Language.C99.AST + ) where + +import Language.C99.AST diff --git a/src/Language/C99/AST.hs b/src/Language/C99/AST.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99/AST.hs @@ -0,0 +1,672 @@ +module Language.C99.AST where + +{- LEXICAL ELEMENTS -} +{- 6.4 -} + +-- We omit Token as there is no usage to in the AST + +data PreprocToken = PreprocHeader HeaderName + | PreprocIdent Ident + | PreprocNumber PPNumber + | PreprocChar CharConst + | PreprocString StringLit + | PreprocPunc Punc + | PreprocNoneWhite + + +{- IDENTIFIERS -} +{- 6.4.2.1 -} +data Ident = IdentBase IdentNonDigit + | IdentConsNonDigit Ident IdentNonDigit + | IdentCons Ident Digit + +data IdentNonDigit = IdentNonDigit NonDigit + | IdentNonDigitUniv UnivCharName + {- Other implementation-defined characters -} + +data NonDigit = NDUnderscore + | NDa | NDA + | NDb | NDB + | NDc | NDC + | NDd | NDD + | NDe | NDE + | NDf | NDF + | NDg | NDG + | NDh | NDH + | NDi | NDI + | NDj | NDJ + | NDk | NDK + | NDl | NDL + | NDm | NDM + | NDn | NDN + | NDo | NDO + | NDp | NDP + | NDq | NDQ + | NDr | NDR + | NDs | NDS + | NDt | NDT + | NDu | NDU + | NDv | NDV + | NDw | NDW + | NDx | NDX + | NDy | NDY + | NDz | NDZ + +data Digit = DZero + | DOne + | DTwo + | DThree + | DFour + | DFive + | DSix + | DSeven + | DEight + | DNine + + +{- UNIVERSAL CHARACTER NAMES -} +{- 6.4.3 -} +data UnivCharName = UnivCharName1 HexQuad + | UnivCharName2 HexQuad HexQuad + +data HexQuad = HexQuad HexDigit HexDigit HexDigit HexDigit + + +{- CONSTANTS -} +{- 6.4.4 -} +data Const = ConstInt IntConst + | ConstFloat FloatConst + | ConstEnum EnumConst + | ConstChar CharConst + +{- 6.4.4.1 -} +data IntConst = IntDec DecConst (Maybe IntSuffix) + | IntOc OcConst (Maybe IntSuffix) + | IntHex HexConst (Maybe IntSuffix) + +data DecConst = DecBase NonZeroDigit + | DecCons DecConst Digit + +data OcConst = Oc0 + | OcCons OcConst OcDigit + +data HexConst = HexBase HexPrefix HexDigit + | HexCons HexConst HexDigit + +data HexPrefix = OX + +data NonZeroDigit = NZOne + | NZTwo + | NZThree + | NZFour + | NZFive + | NZSix + | NZSeven + | NZEight + | NZNine + +data OcDigit = OcZero + | OcOne + | OcTwo + | OcThree + | OcFour + | OcFive + | OcSix + | OcSeven + +data HexDigit = HexZero + | HexOne + | HexTwo + | HexThree + | HexFour + | HexFive + | HexSix + | HexSeven + | HexEight + | HexNine + | Hexa | HexA + | Hexb | HexB + | Hexc | HexC + | Hexd | HexD + | Hexe | HexE + | Hexf | HexF + +data IntSuffix + = IntSuffixUnsignedLong UnsignedSuffix (Maybe LongSuffix) + | IntSuffixUnsignedLongLong UnsignedSuffix LongLongSuffix + | IntSuffixLong LongSuffix (Maybe UnsignedSuffix) + | IntSuffixLongLong LongLongSuffix (Maybe UnsignedSuffix) + +data UnsignedSuffix = U +data LongSuffix = L +data LongLongSuffix = LL + +{- 6.4.4.2 -} +data FloatConst = FloatDec DecFloatConst + | FloatHex HexFloatConst + +data DecFloatConst + = DecFloatFrac FracConst (Maybe ExpPart) (Maybe FloatSuffix) + | DecFloatDigits DigitSeq ExpPart (Maybe FloatSuffix) + +data HexFloatConst + = HexFloatFrac HexPrefix HexFracConst BinExpPart (Maybe FloatSuffix) + | HexFloatDigits HexPrefix HexDigitSeq BinExpPart (Maybe FloatSuffix) + +data FracConst = FracZero (Maybe DigitSeq) DigitSeq + | Frac DigitSeq + +data ExpPart = E (Maybe Sign) DigitSeq + +data Sign = SPlus + | SMinus + +data DigitSeq = DigitBase Digit + | DigitCons DigitSeq Digit + +data HexFracConst = HexFracZero (Maybe HexDigitSeq) HexDigitSeq + | HexFrac HexDigitSeq + +data BinExpPart = P (Maybe Sign) DigitSeq + +data HexDigitSeq = HexDigitBase HexDigit + | HexDigitCons HexDigitSeq HexDigit + +data FloatSuffix = FF + | FL + +{- 6.4.4.3 -} +data EnumConst = Enum Ident + +{- 6.4.4.4 -} +data CharConst = Char CCharSeq + | CharL CCharSeq + +data CCharSeq = CCharBase CChar + | CCharCons CCharSeq CChar + +data CChar = CChar Char -- We are a bit lenient here + | CCharEsc EscSeq + +data EscSeq = EscSimple SimpleEscSeq + | EscOc OcEscSeq + | EscHex HexEscSeq + | EscUniv UnivCharName + +data SimpleEscSeq = SEQuote + | SEDQuote + | SEQuestion + | SEBackSlash + | SEa + | SEb + | SEf + | SEn + | SEr + | SEt + | SEv + +data OcEscSeq = OcEsc1 OcDigit + | OcEsc2 OcDigit OcDigit + | OcEsc3 OcDigit OcDigit OcDigit + +data HexEscSeq = HexEscBase HexDigit + | HexEscCons HexEscSeq HexDigit + + +{- STRING LITERALS -} +{- 6.4.5 -} +data StringLit = StringLit (Maybe SCharSeq) + | StringLitL (Maybe SCharSeq) + +data SCharSeq = SCharBase SChar + | SCharCons SCharSeq SChar + +data SChar = SChar Char -- We are a bit lenient here + | SCharEsc EscSeq + + +{- PUNCTUATORS -} +{- 6.4.6 -} +data Punc = PuncSquareL | PuncSquareR + | PuncParenL | PuncParenR + | PuncBraceL | PuncBraceR + | PuncDot + | PuncArrow + | PuncPlusPlus | PuncMinMin + | PuncAmpersand | PuncAsterisk + | PuncPlus | PuncMin + | PuncTilde + | PuncExclamation + | PuncFSlash + | PuncPercent + | PuncShiftL | PuncShiftR + | PuncLT | PuncGT + | PuncLE | PuncGE + | PuncEq + | PuncNEq + | PuncCaret + | PuncBar + | PuncDoubleAmpersand + | PuncDoubleBar + | PuncQuestion + | PuncColon + | PuncSemicolon + | PuncDots + | PuncAssign + | PuncAssignTimes + | PuncAssignDiv + | PuncAssignMod + | PuncAssignPlus + | PuncAssignMin + | PuncAssignShiftL + | PuncAssignShiftR + | PuncAssignAnd + | PuncAssignXOr + | PuncAssignOr + | PuncComma + | PuncHash + | PuncDoubleHash + | PuncDiSquareL | PuncDiSquareR + | PuncDiBraceL | PuncDiBraceR + | PuncDiHash + | PuncDiDoubleHash + + +{- HEADER NAMES -} +{- 6.4.7 -} +data HeaderName = HeaderGlobal HCharSeq + | HeaderLocal QCharSeq + +data HCharSeq = HCharBase HChar + | HCharCons HCharSeq HChar + +data HChar = HChar Char + +data QCharSeq = QCharBase QChar + | QCharCons QCharSeq QChar + +data QChar = QChar Char + + +{- PREPROCESSING NUMBERS -} +{- 6.4.8 -} +data PPNumber = PPDigit Digit + | PPDec Digit + | PPNum PPNumber Digit + | PPIdent PPNumber IdentNonDigit + | PPe PPNumber Sign + | PPE PPNumber Sign + | PPp PPNumber Sign + | PPP PPNumber Sign + | PPDot PPNumber + + +{- EXPRESSIONS -} +{- 6.5.1 -} +data PrimExpr = PrimIdent Ident + | PrimConst Const + | PrimString StringLit + | PrimExpr Expr + +{- 6.5.2 -} +data PostfixExpr = PostfixPrim PrimExpr + | PostfixIndex PostfixExpr Expr + | PostfixFunction PostfixExpr (Maybe ArgExprList) + | PostfixDot PostfixExpr Ident + | PostfixArrow PostfixExpr Ident + | PostfixInc PostfixExpr + | PostfixDec PostfixExpr + | PostfixInits TypeName InitList + +data ArgExprList = ArgExprListBase AssignExpr + | ArgExprListCons ArgExprList AssignExpr + +{- 6.5.3 -} +data UnaryExpr = UnaryPostfix PostfixExpr + | UnaryInc UnaryExpr + | UnaryDec UnaryExpr + | UnaryOp UnaryOp CastExpr + | UnarySizeExpr UnaryExpr + | UnarySizeType TypeName + +data UnaryOp = UORef + | UODeref + | UOPlus + | UOMin + | UOBNot + | UONot + +{- 6.5.4 -} +data CastExpr = CastUnary UnaryExpr + | Cast TypeName CastExpr + +{- 6.5.5 -} +data MultExpr = MultCast CastExpr + | MultMult MultExpr CastExpr + | MultDiv MultExpr CastExpr + | MultMod MultExpr CastExpr + +{- 6.5.6 -} +data AddExpr = AddMult MultExpr + | AddPlus AddExpr MultExpr + | AddMin AddExpr MultExpr + +{- 6.5.7 -} +data ShiftExpr = ShiftAdd AddExpr + | ShiftLeft ShiftExpr AddExpr + | ShiftRight ShiftExpr AddExpr + +{- 6.5.8 -} +data RelExpr = RelShift ShiftExpr + | RelLT RelExpr ShiftExpr + | RelGT RelExpr ShiftExpr + | RelLE RelExpr ShiftExpr + | RelGE RelExpr ShiftExpr + +{- 6.5.9 -} +data EqExpr = EqRel RelExpr + | EqEq EqExpr RelExpr + | EqNEq EqExpr RelExpr + +{- 6.5.10 -} +data AndExpr = AndEq EqExpr + | And AndExpr EqExpr + +{- 6.5.11 -} +data XOrExpr = XOrAnd AndExpr + | XOr XOrExpr AndExpr + +{- 6.5.12 -} +data OrExpr = OrXOr XOrExpr + | Or OrExpr XOrExpr + +{- 6.5.13 -} +data LAndExpr = LAndOr OrExpr + | LAnd LAndExpr OrExpr + +{- 6.5.14 -} +data LOrExpr = LOrAnd LAndExpr + | LOr LOrExpr LAndExpr + +{- 6.5.15 -} +data CondExpr = CondLOr LOrExpr + | Cond LOrExpr Expr CondExpr + +{- 6.5.16 -} +data AssignExpr = AssignCond CondExpr + | Assign UnaryExpr AssignOp AssignExpr + +data AssignOp = AEq + | ATimes + | ADiv + | AMod + | AAdd + | ASub + | AShiftL + | AShiftR + | AAnd + | AXOr + | AOr + +{- 6.5.17 -} +data Expr = ExprAssign AssignExpr + | Expr Expr AssignExpr + +{- 6.6 -} +data ConstExpr = Const CondExpr + + +{- DECLARATIONS -} +{- 6.7 -} +data Decln = Decln DeclnSpecs (Maybe InitDeclrList) + +data DeclnSpecs = DeclnSpecsStorage StorageClassSpec (Maybe DeclnSpecs) + | DeclnSpecsType TypeSpec (Maybe DeclnSpecs) + | DeclnSpecsQual TypeQual (Maybe DeclnSpecs) + | DeclnSpecsFun FunSpec (Maybe DeclnSpecs) + +data InitDeclrList = InitDeclrBase InitDeclr + | InitDeclrCons InitDeclrList InitDeclr + +data InitDeclr = InitDeclr Declr + | InitDeclrInitr Declr Init + +{- 6.7.1 -} +data StorageClassSpec = STypedef + | SExtern + | SStatic + | SAuto + | SRegister + +{- 6.7.2 -} +data TypeSpec = TVoid + | TChar + | TShort + | TInt + | TLong + | TFloat + | TDouble + | TSigned + | TUnsigned + | TBool + | TComplex + | TStructOrUnion StructOrUnionSpec + | TEnum EnumSpec + | TTypedef TypedefName + +{- 6.7.2.1 -} +data StructOrUnionSpec + = StructOrUnionDecln StructOrUnion (Maybe Ident) StructDeclnList + | StructOrUnionForwDecln StructOrUnion Ident + +data StructOrUnion = Struct + | Union + +data StructDeclnList = StructDeclnBase StructDecln + | StructDeclnCons StructDeclnList StructDecln + +data StructDecln = StructDecln SpecQualList StructDeclrList + +data SpecQualList = SpecQualType TypeSpec (Maybe SpecQualList) + | SpecQualQual TypeQual (Maybe SpecQualList) + +data StructDeclrList = StructDeclrBase StructDeclr + | StructDeclrCons StructDeclrList StructDeclr + +data StructDeclr = StructDeclr Declr + | StructDeclrBit (Maybe Declr) ConstExpr + +{- 6.7.2.2 -} +data EnumSpec = EnumSpec (Maybe Ident) EnumrList + | EnumSpecForw Ident + +data EnumrList = EnumrBase Enumr + | EnumrCons EnumrList Enumr + +data Enumr = Enumr EnumConst + | EnumrInit EnumConst ConstExpr + +{- 6.7.3 -} +data TypeQual = QConst + | QRestrict + | QVolatile + +{- 6.7.4 -} +data FunSpec = SpecInline + +{- 6.7.5 -} +data Declr = Declr (Maybe Ptr) DirectDeclr + +data DirectDeclr + = DirectDeclrIdent Ident + | DirectDeclrDeclr Declr + | DirectDeclrArray1 DirectDeclr (Maybe TypeQualList) (Maybe AssignExpr) + | DirectDeclrArray2 DirectDeclr (Maybe TypeQualList) AssignExpr + | DirectDeclrArray3 DirectDeclr TypeQualList AssignExpr + | DirectDeclrArray4 DirectDeclr (Maybe TypeQualList) + | DirectDeclrFun1 DirectDeclr ParamTypeList + | DirectDeclrFun2 DirectDeclr (Maybe IdentList) + +data Ptr = PtrBase (Maybe TypeQualList) + | PtrCons (Maybe TypeQualList) Ptr + +data TypeQualList = TypeQualBase TypeQual + | TypeQualCons TypeQualList TypeQual + +data ParamTypeList = ParamTypeList ParamList + | ParamTypeListVar ParamList + +data ParamList = ParamBase ParamDecln + | ParamCons ParamList ParamDecln + +data ParamDecln = ParamDecln DeclnSpecs Declr + | ParamDeclnAbstract DeclnSpecs (Maybe DirectAbstractDeclr) + +data IdentList = IdentListBase Ident + | IdentListCons IdentList Ident + +{- 6.7.6 -} +data TypeName = TypeName SpecQualList (Maybe AbstractDeclr) + +data AbstractDeclr = AbstractDeclr Ptr + | AbstractDeclrDirect (Maybe Ptr) DirectAbstractDeclr + +data DirectAbstractDeclr + = DirectAbstractDeclr AbstractDeclr + | DirectAbstractDeclrArray1 + (Maybe DirectAbstractDeclr) (Maybe TypeQualList) (Maybe AssignExpr) + | DirectAbstractDeclrArray2 + (Maybe DirectAbstractDeclr) (Maybe TypeQualList) AssignExpr + | DirectAbstractDeclrArray3 (Maybe DirectAbstractDeclr) TypeQualList AssignExpr + | DirectAbstractDeclrArray4 (Maybe DirectAbstractDeclr) + | DirectAbstractDeclrFun (Maybe DirectAbstractDeclr) (Maybe ParamTypeList) + +{- 6.7.7 -} +data TypedefName = TypedefName Ident + +{- 6.7.8 -} +data Init = InitExpr AssignExpr + | InitArray InitList + -- We omit the specific case of InitArray ending with , + +data InitList = InitBase (Maybe Design) Init + | InitCons InitList (Maybe Design) Init + +data Design = Design DesigrList + +data DesigrList = DesigrBase Desigr + | DesigrCons DesigrList Desigr + +data Desigr = DesigrConst ConstExpr + | DesigrIdent Ident + + +{- STATEMENTS -} +{- 6.8 -} +data Stmt = StmtLabeled LabeledStmt + | StmtCompound CompoundStmt + | StmtExpr ExprStmt + | StmtSelect SelectStmt + | StmtIter IterStmt + | StmtJump JumpStmt + +{- 6.8.1 -} +data LabeledStmt = LabeledIdent Ident Stmt + | LabeledCase ConstExpr Stmt + | LabeledDefault Stmt + +{- 6.8.2 -} +data CompoundStmt = Compound (Maybe BlockItemList) + +data BlockItemList = BlockItemBase BlockItem + | BlockItemCons BlockItemList BlockItem + +data BlockItem = BlockItemDecln Decln + | BlockItemStmt Stmt + +{- 6.8.3 -} +data ExprStmt = ExprStmt (Maybe Expr) + +{- 6.8.4 -} +data SelectStmt = SelectIf Expr Stmt + | SelectIfElse Expr Stmt Stmt + | SelectSwitch Expr Stmt + +{- 6.8.5 -} +data IterStmt = IterWhile Expr Stmt + | IterDo Stmt Expr + | IterForUpdate (Maybe Expr) (Maybe Expr) (Maybe Expr) Stmt + | IterFor Decln (Maybe Expr) (Maybe Expr) Stmt + +{- 6.8.6 -} +data JumpStmt = JumpGoto Ident + | JumpContinue + | JumpBreak + | JumpReturn (Maybe Expr) + +{- EXTERNAL DEFINITIONS -} +{- 6.9 -} +data TransUnit = TransUnitBase ExtDecln + | TransUnitCons TransUnit ExtDecln + +data ExtDecln = ExtFun FunDef + | ExtDecln Decln + +{- 6.9.1 -} +data FunDef = FunDef DeclnSpecs Declr (Maybe DeclnList) CompoundStmt + +data DeclnList = DeclnBase Decln + | DeclnCons DeclnList Decln + + +{- PREPROCESSING DIRECTIVES -} +{- 6.10 -} +data PreprocFile = PreprocFile (Maybe Group) + +data Group = GroupBase GroupPart + | GroupCons Group GroupPart + +data GroupPart = GroupIf IfSection + | GroupControl ControlLine + | GroupText TextLine + | GroupNonDirective NonDirective + +data IfSection + = IfSection IfGroup (Maybe ElifGroups) (Maybe ElseGroup) EndIfLine + +data IfGroup = If ConstExpr NewLine (Maybe Group) + | IfDef Ident NewLine (Maybe Group) + | IfNDef Ident NewLine (Maybe Group) + +data ElifGroups = ElifBase ElifGroup + | ElifCons ElifGroups ElifGroup + +data ElifGroup = Elif ConstExpr NewLine (Maybe Group) + +data ElseGroup = Else NewLine (Maybe Group) + +data EndIfLine = EndIf NewLine + +data ControlLine = Include PPTokens NewLine + | Define1 Ident ReplaceList NewLine + | Define2 Ident LParen (Maybe IdentList) ReplaceList NewLine + | Define3 Ident LParen ReplaceList NewLine + | Define4 Ident LParen IdentList ReplaceList NewLine + | Undef Ident NewLine + | Line PPTokens NewLine + | Error (Maybe PPTokens) NewLine + | Pragma (Maybe PPTokens) NewLine + | Hash NewLine + +data TextLine = TextLine (Maybe PPTokens) NewLine + +data NonDirective = NonDirective PPTokens NewLine + +data LParen = LParen + +data ReplaceList = ReplaceList (Maybe PPTokens) + +data PPTokens = PPTokensBase PreprocToken + | PPTokensCons PPTokens PreprocToken + +data NewLine = NewLine diff --git a/src/Language/C99/Pretty.hs b/src/Language/C99/Pretty.hs new file mode 100644 --- /dev/null +++ b/src/Language/C99/Pretty.hs @@ -0,0 +1,640 @@ +module Language.C99.Pretty where + +import Language.C99.AST + +import Text.PrettyPrint +import Prelude hiding ((<>)) + + +-- Binary operator +bin :: (Pretty a, Pretty b) => a -> String -> b -> Doc +bin x op y = pretty x <+> text op <+> pretty y + +class Pretty a where + pretty :: a -> Doc + +instance Pretty a => Pretty (Maybe a) where + pretty (Just x) = pretty x + pretty Nothing = empty + +{- IDENTIFIERS -} +{- 6.4.2.1 -} +instance Pretty Ident where + pretty (IdentBase idn) = pretty idn + pretty (IdentConsNonDigit i idn) = pretty i <> pretty idn + pretty (IdentCons i d ) = pretty i <> pretty d + +instance Pretty IdentNonDigit where + pretty (IdentNonDigit nd ) = pretty nd + pretty (IdentNonDigitUniv ucn) = pretty ucn + +instance Pretty NonDigit where + pretty c = case c of + NDUnderscore -> char '_' + NDa -> char 'a' ; NDA -> char 'A' + NDb -> char 'b' ; NDB -> char 'B' + NDc -> char 'c' ; NDC -> char 'C' + NDd -> char 'd' ; NDD -> char 'D' + NDe -> char 'e' ; NDE -> char 'E' + NDf -> char 'f' ; NDF -> char 'F' + NDg -> char 'g' ; NDG -> char 'G' + NDh -> char 'h' ; NDH -> char 'H' + NDi -> char 'i' ; NDI -> char 'J' + NDj -> char 'j' ; NDJ -> char 'I' + NDk -> char 'k' ; NDK -> char 'K' + NDl -> char 'l' ; NDL -> char 'L' + NDm -> char 'm' ; NDM -> char 'M' + NDn -> char 'n' ; NDN -> char 'N' + NDo -> char 'o' ; NDO -> char 'O' + NDp -> char 'p' ; NDP -> char 'P' + NDq -> char 'q' ; NDQ -> char 'Q' + NDr -> char 'r' ; NDR -> char 'R' + NDs -> char 's' ; NDS -> char 'S' + NDt -> char 't' ; NDT -> char 'T' + NDu -> char 'u' ; NDU -> char 'U' + NDv -> char 'v' ; NDV -> char 'V' + NDw -> char 'w' ; NDW -> char 'W' + NDx -> char 'x' ; NDX -> char 'X' + NDy -> char 'y' ; NDY -> char 'Y' + NDz -> char 'z' ; NDZ -> char 'Z' + +instance Pretty Digit where + pretty c = case c of + DZero -> int 0 + DOne -> int 1 + DTwo -> int 2 + DThree -> int 3 + DFour -> int 4 + DFive -> int 5 + DSix -> int 6 + DSeven -> int 7 + DEight -> int 8 + DNine -> int 9 + + +{- UNIVERSAL CHARACTER NAMES -} +{- 6.4.3 -} +instance Pretty UnivCharName where + pretty (UnivCharName1 hq ) = text "\\u" <> pretty hq + pretty (UnivCharName2 hq1 hq2) = text "\\U" <> pretty hq1 <> pretty hq2 + +instance Pretty HexQuad where + pretty (HexQuad hd1 hd2 hd3 hd4) = pretty hd1 <> pretty hd2 + <> pretty hd3 <> pretty hd4 + + +{- CONSTANTS -} +{- 6.4.4 -} +instance Pretty Const where + pretty (ConstInt ic) = pretty ic + pretty (ConstFloat fc) = pretty fc + pretty (ConstEnum ec) = pretty ec + pretty (ConstChar cc) = pretty cc + +{- 6.4.4.1 -} +instance Pretty IntConst where + pretty (IntDec dc mis) = pretty dc <> pretty mis + pretty (IntOc oc mis) = pretty oc <> pretty mis + pretty (IntHex hc mis) = pretty hc <> pretty mis + +instance Pretty DecConst where + pretty (DecBase nzd) = pretty nzd + pretty (DecCons dc d ) = pretty dc <> pretty d + +instance Pretty OcConst where + pretty Oc0 = int 0 + pretty (OcCons oc od) = pretty oc <> pretty od + +instance Pretty HexConst where + +instance Pretty HexPrefix where + +instance Pretty NonZeroDigit where + pretty d = case d of + NZOne -> int 1 + NZTwo -> int 2 + NZThree -> int 3 + NZFour -> int 4 + NZFive -> int 5 + NZSix -> int 6 + NZSeven -> int 7 + NZEight -> int 8 + NZNine -> int 9 + +instance Pretty OcDigit where + +instance Pretty HexDigit where + +instance Pretty IntSuffix where + pretty (IntSuffixUnsignedLong u ml) = pretty u <> pretty ml + pretty (IntSuffixUnsignedLongLong u ll) = pretty u <> pretty ll + pretty (IntSuffixLong l mu) = pretty l <> pretty mu + pretty (IntSuffixLongLong ll mu) = pretty ll <> pretty mu + +instance Pretty UnsignedSuffix where + pretty U = char 'U' + +instance Pretty LongSuffix where + pretty L = char 'L' + +instance Pretty LongLongSuffix where + pretty rL = text "LL" + +{- 6.4.4.2 -} +instance Pretty FloatConst where + pretty (FloatDec dfc) = pretty dfc + pretty (FloatHex hfc) = pretty hfc + +instance Pretty DecFloatConst where + pretty (DecFloatFrac fc me mfs) = pretty fc <> pretty me <> pretty mfs + pretty (DecFloatDigits ds ep mfs) = pretty ds <> pretty ep <> pretty mfs + +instance Pretty HexFloatConst where + pretty (HexFloatFrac hp hfc bep mfs) = + pretty hp <> pretty hfc <> pretty bep <> pretty mfs + pretty (HexFloatDigits hp hds bep mfs) = + pretty hp <> pretty hds <> pretty bep <> pretty mfs + +instance Pretty FracConst where + pretty (FracZero mds ds) = pretty mds <> char '.' <> pretty ds + pretty (Frac ds) = pretty ds <> char '.' + +instance Pretty ExpPart where + pretty (E ms ds) = char 'e' <> pretty ms <> pretty ds + +instance Pretty Sign where + pretty SPlus = char '+' + pretty SMinus = char '-' + +instance Pretty DigitSeq where + pretty (DigitBase d) = pretty d + pretty (DigitCons ds d) = pretty ds <> pretty d + +instance Pretty HexFracConst where + pretty (HexFracZero mhds hds) = pretty mhds <> char '.' <> pretty hds + pretty (HexFrac hds) = pretty hds <> char '.' + +instance Pretty BinExpPart where + pretty (P ms ds) = char 'p' <> pretty ms <> pretty ds + +instance Pretty HexDigitSeq where + pretty (HexDigitBase hd) = pretty hd + pretty (HexDigitCons hds hd) = pretty hds <> pretty hd + +instance Pretty FloatSuffix where + pretty FF = char 'f' + pretty FL = char 'l' + +{- 6.4.4.3 -} +instance Pretty EnumConst where + pretty (Enum i) = pretty i + +{- 6.4.4.4 -} +instance Pretty CharConst where + +instance Pretty CCharSeq where + +instance Pretty CChar where + +instance Pretty EscSeq where + pretty (EscSimple se) = pretty se + +instance Pretty SimpleEscSeq where + pretty esc = case esc of + SEQuote -> text "\\\'" + SEDQuote -> text "\\\"" + SEQuestion -> text "\\?" + SEBackSlash -> text "\\\\" + SEa -> text "\\a" + SEb -> text "\\b" + SEf -> text "\\f" + SEn -> text "\\n" + SEr -> text "\\r" + SEt -> text "\\t" + SEv -> text "\\v" + +instance Pretty OcEscSeq where + +instance Pretty HexEscSeq where + + +{- STRING LITERALS -} +{- 6.4.5 -} +instance Pretty StringLit where + pretty (StringLit mcs) = doubleQuotes (pretty mcs) + pretty (StringLitL mcs) = char 'L' <> doubleQuotes (pretty mcs) + +instance Pretty SCharSeq where + pretty (SCharBase sc ) = pretty sc + pretty (SCharCons scs sc) = pretty scs <> pretty sc + +instance Pretty SChar where + pretty (SChar c ) = char c + pretty (SCharEsc es) = pretty es + + +{- EXPRESSIONS -} +{- 6.5.1 -} +instance Pretty PrimExpr where + pretty (PrimIdent i ) = pretty i + pretty (PrimConst c ) = pretty c + pretty (PrimString sl) = pretty sl + pretty (PrimExpr e ) = parens (pretty e) + +{- 6.5.2 -} +instance Pretty PostfixExpr where + pretty (PostfixPrim pe ) = pretty pe + pretty (PostfixIndex pe e ) = pretty pe <> brackets (pretty e) + pretty (PostfixFunction pe mael) = pretty pe <> parens (pretty mael) + pretty (PostfixDot pe i ) = pretty pe <> char '.' <> pretty i + pretty (PostfixArrow pe i ) = pretty pe <> text "->" <> pretty i + pretty (PostfixInc pe ) = pretty pe <> text "++" + pretty (PostfixDec pe ) = pretty pe <> text "--" + pretty (PostfixInits tn il ) = parens (pretty tn) <> braces (pretty il) + +instance Pretty ArgExprList where + pretty (ArgExprListBase ae) = pretty ae + pretty (ArgExprListCons ael ae) = pretty ael <> comma <+> pretty ae + +{- 6.5.3 -} +instance Pretty UnaryExpr where + pretty (UnaryPostfix pe ) = pretty pe + pretty (UnaryInc ue ) = text "++" <> pretty ue + pretty (UnaryDec ue ) = text "--" <> pretty ue + pretty (UnaryOp op ce) = pretty op <> pretty ce + pretty (UnarySizeExpr ue ) = text "sizeof" <+> pretty ue + pretty (UnarySizeType tn ) = text "sizeof" <> parens (pretty tn) + +instance Pretty UnaryOp where + pretty op = case op of + UORef -> char '&' + UODeref -> char '*' + UOPlus -> char '+' + UOMin -> char '-' + UOBNot -> char '~' + UONot -> char '!' + +{- 6.5.4 -} +instance Pretty CastExpr where + pretty (CastUnary ue) = pretty ue + pretty (Cast tn ce) = parens (pretty tn) <> pretty ce + +{- 6.5.5 -} +instance Pretty MultExpr where + pretty (MultCast ce) = pretty ce + pretty (MultMult me ce) = bin me "*" ce + pretty (MultDiv me ce) = bin me "/" ce + pretty (MultMod me ce) = bin me "%" ce + +{- 6.5.6 -} +instance Pretty AddExpr where + pretty (AddMult me) = pretty me + pretty (AddPlus ae me) = bin ae "+" me + pretty (AddMin ae me) = bin ae "-" me + +{- 6.5.7 -} +instance Pretty ShiftExpr where + pretty (ShiftAdd add) = pretty add + pretty (ShiftLeft shift add) = bin shift "<<" add + pretty (ShiftRight shift add) = bin shift ">>" add + +{- 6.5.8 -} +instance Pretty RelExpr where + pretty (RelShift shift) = pretty shift + pretty (RelLT rel shift) = bin rel "<" shift + pretty (RelGT rel shift) = bin rel ">" shift + pretty (RelLE rel shift) = bin rel "<=" shift + pretty (RelGE rel shift) = bin rel ">=" shift + +{- 6.5.9 -} +instance Pretty EqExpr where + pretty (EqRel rel) = pretty rel + pretty (EqEq eq rel) = bin eq "==" rel + pretty (EqNEq eq rel) = bin eq "!=" rel + +{- 6.5.10 -} +instance Pretty AndExpr where + pretty (AndEq eq) = pretty eq + pretty (And and eq) = bin and "&" eq + +{- 6.5.11 -} +instance Pretty XOrExpr where + pretty (XOrAnd and) = pretty and + pretty (XOr xor and) = bin xor "^" and + +{- 6.5.12 -} +instance Pretty OrExpr where + pretty (OrXOr xor) = pretty xor + pretty (Or or xor) = bin or "|" xor + +{- 6.5.13 -} +instance Pretty LAndExpr where + pretty (LAndOr or) = pretty or + pretty (LAnd and or) = bin and "&&" or + +{- 6.5.14 -} +instance Pretty LOrExpr where + pretty (LOrAnd and) = pretty and + pretty (LOr or and) = bin or "||" and + +{- 6.5.15 -} +instance Pretty CondExpr where + pretty (CondLOr le ) = pretty le + pretty (Cond le e ce) = pretty le <+> char '?' <+> pretty e <+> colon <+> pretty ce + +{- 6.5.16 -} +instance Pretty AssignExpr where + pretty (AssignCond ce) = pretty ce + pretty (Assign ue op ae) = pretty ue <+> pretty op <+> pretty ae + +instance Pretty AssignOp where + pretty op = case op of + AEq -> text "=" + ATimes -> text "*=" + ADiv -> text "/=" + AMod -> text "%=" + AAdd -> text "+=" + ASub -> text "-=" + AShiftL -> text "<<=" + AShiftR -> text ">>=" + AAnd -> text "&=" + AXOr -> text "^=" + AOr -> text "|=" + +{- 6.5.17 -} +instance Pretty Expr where + pretty (ExprAssign ae) = pretty ae + pretty (Expr e ae) = pretty e <> comma <+> pretty ae + +{- 6.6 -} +instance Pretty ConstExpr where + pretty (Const ce) = pretty ce + + +{- DECLARATIONS -} +{- 6.7 -} +instance Pretty Decln where + pretty (Decln ds midl) = pretty ds <+> pretty midl + +instance Pretty DeclnSpecs where + pretty (DeclnSpecsStorage scs mds) = pretty scs <+> pretty mds + pretty (DeclnSpecsType ts mds) = pretty ts <+> pretty mds + pretty (DeclnSpecsQual tq mds) = pretty tq <+> pretty mds + pretty (DeclnSpecsFun fs mds) = pretty fs <+> pretty mds + +instance Pretty InitDeclrList where + pretty (InitDeclrBase id) = pretty id + pretty (InitDeclrCons idl id) = pretty idl <> comma <+> pretty id + +instance Pretty InitDeclr where + pretty (InitDeclr d ) = pretty d + pretty (InitDeclrInitr d i) = pretty d <+> equals <+> pretty i + +{- 6.7.1 -} +instance Pretty StorageClassSpec where + pretty c = case c of + STypedef -> text "typedef" + SExtern -> text "extern" + SStatic -> text "static" + SAuto -> text "auto" + SRegister -> text "register" + +{- 6.7.2 -} +instance Pretty TypeSpec where + pretty ty = case ty of + TVoid -> text "void" + TChar -> text "char" + TShort -> text "short" + TInt -> text "int" + TLong -> text "long" + TFloat -> text "float" + TDouble -> text "double" + TSigned -> text "signed" + TUnsigned -> text "unsigned" + TBool -> text "_Bool" + TComplex -> text "_Complex" + TStructOrUnion sous -> pretty sous + TEnum es -> pretty es + TTypedef tn -> pretty tn + +{- 6.7.2.1 -} +instance Pretty StructOrUnionSpec where + pretty (StructOrUnionDecln sou mi sdl) = + vcat [pretty sou <+> pretty mi, lbrace, nest 2 $ pretty sdl, rbrace] + pretty (StructOrUnionForwDecln sou i ) = + pretty sou <+> pretty i + +instance Pretty StructOrUnion where + pretty Struct = text "struct" + pretty Union = text "union" + +instance Pretty StructDeclnList where + pretty (StructDeclnBase sd ) = pretty sd + pretty (StructDeclnCons sdl sd) = pretty sdl $+$ pretty sd + +instance Pretty StructDecln where + pretty (StructDecln sql sdl) = pretty sql <+> pretty sdl <> char ';' + +instance Pretty SpecQualList where + pretty (SpecQualType ts msql) = pretty ts <+> pretty msql + pretty (SpecQualQual tq msql) = pretty tq <+> pretty msql + +instance Pretty StructDeclrList where + pretty (StructDeclrBase sd) = pretty sd + pretty (StructDeclrCons sdl sd) = pretty sdl <+> char ',' <+> pretty sd + +instance Pretty StructDeclr where + pretty (StructDeclr d ) = pretty d + pretty (StructDeclrBit md ce) = pretty md <+> char ':' <+> pretty ce + +{- 6.7.2.2 -} +instance Pretty EnumSpec where + +instance Pretty EnumrList where + +instance Pretty Enumr where + +{- 6.7.3 -} +instance Pretty TypeQual where + pretty q = case q of + QConst -> text "const" + QRestrict -> text "restrict" + QVolatile -> text "volatile" + +{- 6.7.4 -} +instance Pretty FunSpec where + pretty SpecInline = text "inline" + +{- 6.7.5 -} +instance Pretty Declr where + pretty (Declr mptr dd) = pretty mptr <+> pretty dd + +instance Pretty DirectDeclr where + pretty (DirectDeclrIdent i ) = pretty i + pretty (DirectDeclrDeclr d ) = parens $ pretty d + pretty (DirectDeclrArray1 d mtl mae) = pretty d <> brackets (pretty mtl <+> pretty mae) + pretty (DirectDeclrArray2 d mtl ae ) = pretty d <> brackets (text "static" <+> pretty mtl <+> pretty ae) + pretty (DirectDeclrArray3 d tl ae ) = pretty d <> brackets (pretty tl <+> text "static" <+> pretty ae) + pretty (DirectDeclrArray4 d mtl ) = pretty d <> brackets (pretty mtl <+> char '*') + pretty (DirectDeclrFun1 d ptl ) = pretty d <> parens (pretty ptl) + pretty (DirectDeclrFun2 d mil ) = pretty d <> parens (pretty mil) + +instance Pretty Ptr where + pretty (PtrBase mtql ) = char '*' <> pretty mtql + pretty (PtrCons mtql p) = char '*' <> pretty mtql <> pretty p + +instance Pretty TypeQualList where + pretty (TypeQualBase tq) = pretty tq + pretty (TypeQualCons tql tq) = pretty tql <+> pretty tq + +instance Pretty ParamTypeList where + pretty (ParamTypeList tq) = pretty tq + pretty (ParamTypeListVar tq) = pretty tq <> comma <+> text "..." + +instance Pretty ParamList where + pretty (ParamBase pd) = pretty pd + pretty (ParamCons pl pd) = pretty pl <> comma <+> pretty pd + +instance Pretty ParamDecln where + pretty (ParamDecln ds d ) = pretty ds <+> pretty d + pretty (ParamDeclnAbstract ds mdad) = pretty ds <+> pretty mdad + +instance Pretty IdentList where + +{- 6.7.6 -} +instance Pretty TypeName where + pretty (TypeName sql mdar) = pretty sql <+> pretty mdar + +instance Pretty AbstractDeclr where + pretty (AbstractDeclr ptr ) = pretty ptr + pretty (AbstractDeclrDirect mptr ad) = pretty mptr <> pretty ad + +instance Pretty DirectAbstractDeclr where + pretty (DirectAbstractDeclr dad) = parens $ pretty dad + pretty (DirectAbstractDeclrArray1 mdad mtql mae) + = pretty mdad <> brackets (pretty mtql <> pretty mae) + pretty (DirectAbstractDeclrArray2 mdad mtql ae) + = pretty mdad <> brackets (text "static" <+> pretty mtql <> pretty ae) + pretty (DirectAbstractDeclrArray3 mdad tql ae) + = pretty mdad <> brackets (pretty tql <+> text "static" <+> pretty ae) + pretty (DirectAbstractDeclrArray4 mdad) = pretty mdad <> brackets (char '*') + pretty (DirectAbstractDeclrFun mdad mptl) = pretty mdad <> parens (pretty mptl) + +{- 6.7.7 -} +instance Pretty TypedefName where + pretty (TypedefName i) = pretty i + +{- 6.7.8 -} +instance Pretty Init where + pretty (InitExpr ae) = pretty ae + pretty (InitArray il) = braces (pretty il) + +instance Pretty InitList where + pretty (InitBase md i) = pretty md <+> pretty i + pretty (InitCons il md i) = pretty il <> comma <+> pretty md <+> pretty i + +instance Pretty Design where + pretty (Design dl) = pretty dl <+> char '=' + +instance Pretty DesigrList where + pretty (DesigrBase d) = pretty d + pretty (DesigrCons dl d) = pretty dl <+> pretty d + +instance Pretty Desigr where + pretty (DesigrConst ce) = brackets (pretty ce) + pretty (DesigrIdent i ) = char '.' <> pretty i + +{- STATEMENTS -} +{- 6.8 -} +instance Pretty Stmt where + pretty (StmtLabeled ls) = pretty ls + pretty (StmtCompound cs) = vcat [ lbrace, nest 2 $ pretty cs, rbrace ] + + pretty (StmtExpr es) = pretty es + pretty (StmtSelect ss) = pretty ss + pretty (StmtIter is) = pretty is + pretty (StmtJump js) = pretty js + +{- 6.8.1 -} +instance Pretty LabeledStmt where + pretty (LabeledIdent i s) = pretty i <> colon <+> pretty s + pretty (LabeledCase ce s) = text "case" <+> pretty ce <> colon <+> pretty s + pretty (LabeledDefault s) = text "default" <> colon <+> pretty s + +{- 6.8.2 -} +instance Pretty CompoundStmt where + pretty (Compound Nothing) = empty + pretty (Compound mbil ) = pretty mbil + +instance Pretty BlockItemList where + pretty (BlockItemBase bi) = pretty bi + pretty (BlockItemCons bil bi) = pretty bil $$ pretty bi + +instance Pretty BlockItem where + pretty (BlockItemDecln d) = pretty d <> semi + pretty (BlockItemStmt s) = pretty s <> semi + +{- 6.8.3 -} +instance Pretty ExprStmt where + pretty (ExprStmt Nothing) = empty + pretty (ExprStmt me) = pretty me + +{- 6.8.4 -} +instance Pretty SelectStmt where + pretty (SelectIf c s) = text "if" <+> parens (pretty c) <+> pretty s + pretty (SelectIfElse c s1 s2) = + text "if" <+> parens (pretty c) <+> pretty s1 <+> text "else" <+> pretty s2 + pretty (SelectSwitch c s) = text "switch" <+> parens (pretty c) <+> pretty s + +{- 6.8.5 -} +instance Pretty IterStmt where + pretty (IterWhile c s) = text "while" <+> parens (pretty c) <+> pretty s + pretty (IterDo s c) = + text "do" <+> pretty s <+> text "while" <+> parens (pretty c) <> semi + pretty (IterForUpdate me1 me2 me3 s) = + vcat [ text "for" <+> parens ( pretty me1 <> semi <+> + pretty me2 <> semi <+> + pretty me3 ) <+> lbrace + , nest 2 $ pretty s + , rbrace + ] + pretty (IterFor d me1 me2 s) = + text "for" <+> parens ( pretty d <+> pretty me1 <> semi + <+> pretty me2 ) <+> pretty s + +{- 6.8.6 -} +instance Pretty JumpStmt where + pretty (JumpGoto i) = text "goto" <+> pretty i + pretty JumpContinue = text "continue" + pretty JumpBreak = text "break" + pretty (JumpReturn me) = text "return" <+> pretty me + + +{- EXTERNAL DEFINITIONS -} +{- 6.9 -} +instance Pretty TransUnit where + pretty (TransUnitBase ed) = pretty ed + pretty (TransUnitCons tu ed) = case ed of + ExtFun _ -> vcat [pretty tu, text "", pretty ed] + _ -> vcat [pretty tu, pretty ed] + +instance Pretty ExtDecln where + pretty (ExtFun fd) = pretty fd + pretty (ExtDecln d) = pretty d <> semi + +{- 6.9.1 -} +instance Pretty FunDef where + pretty (FunDef ds d mdl (Compound Nothing)) = fheader ds d mdl <> semi + pretty (FunDef ds d mdl cs) = + vcat [ fheader ds d mdl <+> lbrace + , nest 2 $ pretty cs + , rbrace + ] + +instance Pretty DeclnList where + pretty (DeclnBase d) = pretty d + pretty (DeclnCons dl d) = pretty dl <> comma <+> pretty d + + +fheader :: DeclnSpecs -> Declr -> Maybe DeclnList -> Doc +fheader ds d mdl = pretty ds <+> pretty d <+> pretty mdl