From 19e45c13acbaea04182674ec6be1db9f23369975 Mon Sep 17 00:00:00 2001 From: iphydf Date: Sun, 26 Dec 2021 20:17:57 +0000 Subject: [PATCH] WIP: fixpoint types --- BUILD.bazel | 5 + cimple.cabal | 3 + src/Language/Cimple.hs | 2 +- src/Language/Cimple/AST.hs | 184 ++++++------- src/Language/Cimple/Diagnostics.hs | 102 +++++++- src/Language/Cimple/IO.hs | 8 +- src/Language/Cimple/Parser.y | 318 ++++++++++++----------- src/Language/Cimple/Pretty.hs | 240 +++++++++-------- src/Language/Cimple/Program.hs | 4 +- src/Language/Cimple/SemCheck/Includes.hs | 9 +- src/Language/Cimple/TranslationUnit.hs | 2 +- src/Language/Cimple/TraverseAst.hs | 300 +++++++++++---------- src/Language/Cimple/TreeParser.y | 257 +++++++++--------- test/Language/CimpleSpec.hs | 91 +++---- 14 files changed, 811 insertions(+), 714 deletions(-) diff --git a/BUILD.bazel b/BUILD.bazel index 921f1ca..12b7ae5 100644 --- a/BUILD.bazel +++ b/BUILD.bazel @@ -46,6 +46,8 @@ haskell_library( hazel_library("aeson"), hazel_library("array"), hazel_library("base"), + hazel_library("data-fix"), + hazel_library("transformers-compat"), ], ) @@ -65,6 +67,7 @@ haskell_library( ":parser", hazel_library("array"), hazel_library("base"), + hazel_library("data-fix"), hazel_library("text"), ], ) @@ -91,6 +94,7 @@ haskell_library( hazel_library("base"), hazel_library("bytestring"), hazel_library("containers"), + hazel_library("data-fix"), hazel_library("filepath"), hazel_library("groom"), hazel_library("mtl"), @@ -105,6 +109,7 @@ hspec_test( ":hs-cimple", hazel_library("ansi-wl-pprint"), hazel_library("base"), + hazel_library("data-fix"), hazel_library("hspec"), hazel_library("text"), ], diff --git a/cimple.cabal b/cimple.cabal index f8dba5b..731cb80 100644 --- a/cimple.cabal +++ b/cimple.cabal @@ -48,10 +48,12 @@ library , array , bytestring , containers + , data-fix , filepath , groom , mtl , text + , transformers-compat executable cimplefmt default-language: Haskell2010 @@ -121,5 +123,6 @@ test-suite testsuite base < 5 , ansi-wl-pprint , cimple + , data-fix , hspec , text diff --git a/src/Language/Cimple.hs b/src/Language/Cimple.hs index 79b6eda..4502daf 100644 --- a/src/Language/Cimple.hs +++ b/src/Language/Cimple.hs @@ -13,7 +13,7 @@ import Language.Cimple.Parser as X import Language.Cimple.Tokens as X import Language.Cimple.TraverseAst as X -type AstActions a = X.IdentityActions (State a) () Text +type AstActions a = X.IdentityActions (State a) Text defaultActions :: AstActions state defaultActions = X.identityActions diff --git a/src/Language/Cimple/AST.hs b/src/Language/Cimple/AST.hs index 6356a15..a9b9d11 100644 --- a/src/Language/Cimple/AST.hs +++ b/src/Language/Cimple/AST.hs @@ -1,125 +1,133 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StrictData #-} module Language.Cimple.AST ( AssignOp (..) , BinaryOp (..) , UnaryOp (..) , LiteralType (..) - , Node (..) + , Node, NodeF (..) , Scope (..) , CommentStyle (..) ) where -import Data.Aeson (FromJSON, ToJSON) -import GHC.Generics (Generic) +import Data.Aeson (FromJSON, ToJSON) +import Data.Fix (Fix) +import Data.Functor.Classes (Eq1, Read1, Show1) +import Data.Functor.Classes.Generic (FunctorClassesDefault (..)) +import GHC.Generics (Generic, Generic1) -data Node attr lexeme - = Attr attr (Node attr lexeme) +data NodeF lexeme a -- Preprocessor - | PreprocInclude lexeme + = PreprocInclude lexeme | PreprocDefine lexeme - | PreprocDefineConst lexeme (Node attr lexeme) - | PreprocDefineMacro lexeme [Node attr lexeme] (Node attr lexeme) - | PreprocIf (Node attr lexeme) [Node attr lexeme] (Node attr lexeme) - | PreprocIfdef lexeme [Node attr lexeme] (Node attr lexeme) - | PreprocIfndef lexeme [Node attr lexeme] (Node attr lexeme) - | PreprocElse [Node attr lexeme] - | PreprocElif (Node attr lexeme) [Node attr lexeme] (Node attr lexeme) + | PreprocDefineConst lexeme a + | PreprocDefineMacro lexeme [a] a + | PreprocIf a [a] a + | PreprocIfdef lexeme [a] a + | PreprocIfndef lexeme [a] a + | PreprocElse [a] + | PreprocElif a [a] a | PreprocUndef lexeme | PreprocDefined lexeme - | PreprocScopedDefine (Node attr lexeme) [Node attr lexeme] (Node attr lexeme) - | MacroBodyStmt (Node attr lexeme) - | MacroBodyFunCall (Node attr lexeme) + | PreprocScopedDefine a [a] a + | MacroBodyStmt a + | MacroBodyFunCall a | MacroParam lexeme - | StaticAssert (Node attr lexeme) lexeme + | StaticAssert a lexeme -- Comments - | LicenseDecl lexeme [Node attr lexeme] + | LicenseDecl lexeme [a] | CopyrightDecl lexeme (Maybe lexeme) [lexeme] | Comment CommentStyle lexeme [lexeme] lexeme | CommentBlock lexeme - | Commented (Node attr lexeme) (Node attr lexeme) + | Commented a a -- Namespace-like blocks - | ExternC [Node attr lexeme] - | Class Scope lexeme [Node attr lexeme] [Node attr lexeme] - | Namespace Scope lexeme [Node attr lexeme] + | ExternC [a] + | Class Scope lexeme [a] [a] + | Namespace Scope lexeme [a] -- Statements - | CompoundStmt [Node attr lexeme] + | CompoundStmt [a] | Break | Goto lexeme | Continue - | Return (Maybe (Node attr lexeme)) - | SwitchStmt (Node attr lexeme) [Node attr lexeme] - | IfStmt (Node attr lexeme) (Node attr lexeme) (Maybe (Node attr lexeme)) - | ForStmt (Node attr lexeme) (Node attr lexeme) (Node attr lexeme) (Node attr lexeme) - | WhileStmt (Node attr lexeme) (Node attr lexeme) - | DoWhileStmt (Node attr lexeme) (Node attr lexeme) - | Case (Node attr lexeme) (Node attr lexeme) - | Default (Node attr lexeme) - | Label lexeme (Node attr lexeme) + | Return (Maybe a) + | SwitchStmt a [a] + | IfStmt a a (Maybe a) + | ForStmt a a a a + | WhileStmt a a + | DoWhileStmt a a + | Case a a + | Default a + | Label lexeme a -- Variable declarations - | VLA (Node attr lexeme) lexeme (Node attr lexeme) - | VarDecl (Node attr lexeme) (Node attr lexeme) - | Declarator (Node attr lexeme) (Maybe (Node attr lexeme)) + | VLA a lexeme a + | VarDecl a a + | Declarator a (Maybe a) | DeclSpecVar lexeme - | DeclSpecArray (Node attr lexeme) (Maybe (Node attr lexeme)) + | DeclSpecArray a (Maybe a) -- Expressions - | InitialiserList [Node attr lexeme] - | UnaryExpr UnaryOp (Node attr lexeme) - | BinaryExpr (Node attr lexeme) BinaryOp (Node attr lexeme) - | TernaryExpr (Node attr lexeme) (Node attr lexeme) (Node attr lexeme) - | AssignExpr (Node attr lexeme) AssignOp (Node attr lexeme) - | ParenExpr (Node attr lexeme) - | CastExpr (Node attr lexeme) (Node attr lexeme) - | CompoundExpr (Node attr lexeme) (Node attr lexeme) - | SizeofExpr (Node attr lexeme) - | SizeofType (Node attr lexeme) + | InitialiserList [a] + | UnaryExpr UnaryOp a + | BinaryExpr a BinaryOp a + | TernaryExpr a a a + | AssignExpr a AssignOp a + | ParenExpr a + | CastExpr a a + | CompoundExpr a a + | SizeofExpr a + | SizeofType a | LiteralExpr LiteralType lexeme | VarExpr lexeme - | MemberAccess (Node attr lexeme) lexeme - | PointerAccess (Node attr lexeme) lexeme - | ArrayAccess (Node attr lexeme) (Node attr lexeme) - | FunctionCall (Node attr lexeme) [Node attr lexeme] - | CommentExpr (Node attr lexeme) (Node attr lexeme) + | MemberAccess a lexeme + | PointerAccess a lexeme + | ArrayAccess a a + | FunctionCall a [a] + | CommentExpr a a -- Type definitions - | EnumClass lexeme [Node attr lexeme] - | EnumConsts (Maybe lexeme) [Node attr lexeme] - | EnumDecl lexeme [Node attr lexeme] lexeme - | Enumerator lexeme (Maybe (Node attr lexeme)) - | ClassForward lexeme [Node attr lexeme] - | Typedef (Node attr lexeme) lexeme - | TypedefFunction (Node attr lexeme) - | Struct lexeme [Node attr lexeme] - | Union lexeme [Node attr lexeme] - | MemberDecl (Node attr lexeme) (Node attr lexeme) (Maybe lexeme) - | TyConst (Node attr lexeme) - | TyPointer (Node attr lexeme) + | EnumClass lexeme [a] + | EnumConsts (Maybe lexeme) [a] + | EnumDecl lexeme [a] lexeme + | Enumerator lexeme (Maybe a) + | ClassForward lexeme [a] + | Typedef a lexeme + | TypedefFunction a + | Struct lexeme [a] + | Union lexeme [a] + | MemberDecl a a (Maybe lexeme) + | TyConst a + | TyPointer a | TyStruct lexeme | TyFunc lexeme | TyStd lexeme | TyVar lexeme | TyUserDefined lexeme -- Functions - | FunctionDecl Scope (Node attr lexeme) (Maybe (Node attr lexeme)) - | FunctionDefn Scope (Node attr lexeme) (Node attr lexeme) - | FunctionPrototype (Node attr lexeme) lexeme [Node attr lexeme] - | FunctionParam (Node attr lexeme) (Node attr lexeme) - | Event lexeme (Node attr lexeme) - | EventParams [Node attr lexeme] - | Property (Node attr lexeme) (Node attr lexeme) [Node attr lexeme] - | Accessor lexeme [Node attr lexeme] (Maybe (Node attr lexeme)) - | ErrorDecl lexeme [Node attr lexeme] - | ErrorList [Node attr lexeme] + | FunctionDecl Scope a (Maybe a) + | FunctionDefn Scope a a + | FunctionPrototype a lexeme [a] + | FunctionParam a a + | Event lexeme a + | EventParams [a] + | Property a a [a] + | Accessor lexeme [a] (Maybe a) + | ErrorDecl lexeme [a] + | ErrorList [a] | ErrorFor lexeme | Ellipsis -- Constants - | ConstDecl (Node attr lexeme) lexeme - | ConstDefn Scope (Node attr lexeme) lexeme (Node attr lexeme) - deriving (Show, Eq, Generic, Functor, Foldable, Traversable) + | ConstDecl a lexeme + | ConstDefn Scope a lexeme a + deriving (Show, Read, Eq, Generic, Generic1, Functor, Foldable, Traversable) + deriving (Show1, Read1, Eq1) via FunctorClassesDefault (NodeF lexeme) -instance (FromJSON attr, FromJSON lexeme) => FromJSON (Node attr lexeme) -instance (ToJSON attr, ToJSON lexeme) => ToJSON (Node attr lexeme) +type Node lexeme = Fix (NodeF lexeme) + +instance (FromJSON lexeme, FromJSON a) => FromJSON (NodeF lexeme a) +instance (ToJSON lexeme, ToJSON a) => ToJSON (NodeF lexeme a) data AssignOp = AopEq @@ -133,7 +141,7 @@ data AssignOp | AopMod | AopLsh | AopRsh - deriving (Show, Eq, Generic) + deriving (Show, Read, Eq, Generic) instance FromJSON AssignOp instance ToJSON AssignOp @@ -157,7 +165,7 @@ data BinaryOp | BopGt | BopGe | BopRsh - deriving (Show, Eq, Generic) + deriving (Show, Read, Eq, Generic) instance FromJSON BinaryOp instance ToJSON BinaryOp @@ -170,7 +178,7 @@ data UnaryOp | UopDeref | UopIncr | UopDecr - deriving (Show, Eq, Generic) + deriving (Show, Read, Eq, Generic) instance FromJSON UnaryOp instance ToJSON UnaryOp @@ -181,7 +189,7 @@ data LiteralType | Bool | String | ConstId - deriving (Show, Eq, Generic) + deriving (Show, Read, Eq, Generic) instance FromJSON LiteralType instance ToJSON LiteralType @@ -189,7 +197,7 @@ instance ToJSON LiteralType data Scope = Global | Static - deriving (Show, Eq, Generic) + deriving (Show, Read, Eq, Generic) instance FromJSON Scope instance ToJSON Scope @@ -198,7 +206,7 @@ data CommentStyle = Regular | Doxygen | Block - deriving (Show, Eq, Generic) + deriving (Show, Read, Eq, Generic) instance FromJSON CommentStyle instance ToJSON CommentStyle diff --git a/src/Language/Cimple/Diagnostics.hs b/src/Language/Cimple/Diagnostics.hs index 1cc784b..50c3add 100644 --- a/src/Language/Cimple/Diagnostics.hs +++ b/src/Language/Cimple/Diagnostics.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StrictData #-} module Language.Cimple.Diagnostics @@ -11,9 +12,11 @@ module Language.Cimple.Diagnostics import Control.Monad.State.Lazy (State) import qualified Control.Monad.State.Lazy as State +import Data.Fix (foldFix) +import Data.Maybe (maybeToList) import Data.Text (Text) import qualified Data.Text as Text -import Language.Cimple.AST (Node) +import Language.Cimple.AST (Node, NodeF (..)) import Language.Cimple.Lexer (AlexPosn (..), Lexeme (..), lexemeLine) import Language.Cimple.Tokens (LexemeClass (..)) @@ -37,8 +40,101 @@ sloc :: FilePath -> Lexeme text -> Text sloc file l = Text.pack file <> ":" <> Text.pack (show (lexemeLine l)) -at :: Node a (Lexeme Text) -> Lexeme Text +at :: Node (Lexeme Text) -> Lexeme Text at n = - case foldMap (:[]) n of + case foldFix lexemes n of [] -> L (AlexPn 0 0 0) Error "unknown source location" l:_ -> l + +lexemes :: NodeF (Lexeme Text) [Lexeme Text] -> [Lexeme Text] +lexemes = \case + PreprocInclude l1 -> [l1] + PreprocDefine l1 -> [l1] + PreprocDefineConst l1 l2 -> l1:l2 + PreprocDefineMacro l1 l2 l3 -> l1:concat l2++l3 + PreprocIf l1 l2 l3 -> l1++concat l2++l3 + PreprocIfdef l1 l2 l3 -> l1:concat l2++l3 + PreprocIfndef l1 l2 l3 -> l1:concat l2++l3 + PreprocElse l1 -> concat l1 + PreprocElif l1 l2 l3 -> l1++concat l2++l3 + PreprocUndef l1 -> [l1] + PreprocDefined l1 -> [l1] + PreprocScopedDefine l1 l2 l3 -> l1++concat l2++l3 + MacroBodyStmt l1 -> l1 + MacroBodyFunCall l1 -> l1 + MacroParam l1 -> [l1] + StaticAssert l1 l2 -> l1++[l2] + LicenseDecl l1 l2 -> l1:concat l2 + CopyrightDecl l1 l2 l3 -> l1:maybeToList l2++l3 + Comment _ l1 l2 l3 -> l1:l2++[l3] + CommentBlock l1 -> [l1] + Commented l1 l2 -> l1++l2 + ExternC l1 -> concat l1 + Class _ l1 l2 l3 -> l1:concat l2++concat l3 + Namespace _ l1 l2 -> l1:concat l2 + CompoundStmt l1 -> concat l1 + Break -> [] + Goto l1 -> [l1] + Continue -> [] + Return l1 -> concat (maybeToList l1) + SwitchStmt l1 l2 -> l1++concat l2 + IfStmt l1 l2 l3 -> l1++l2++concat (maybeToList l3) + ForStmt l1 l2 l3 l4 -> l1++l2++l3++l4 + WhileStmt l1 l2 -> l1++l2 + DoWhileStmt l1 l2 -> l1++l2 + Case l1 l2 -> l1++l2 + Default l1 -> l1 + Label l1 l2 -> l1:l2 + VLA l1 l2 l3 -> l1++[l2]++l3 + VarDecl l1 l2 -> l1++l2 + Declarator l1 l2 -> l1++concat (maybeToList l2) + DeclSpecVar l1 -> [l1] + DeclSpecArray l1 l2 -> l1++concat (maybeToList l2) + InitialiserList l1 -> concat l1 + UnaryExpr _ l1 -> l1 + BinaryExpr l1 _ l2 -> l1++l2 + TernaryExpr l1 l2 l3 -> l1++l2++l3 + AssignExpr l1 _ l2 -> l1++l2 + ParenExpr l1 -> l1 + CastExpr l1 l2 -> l1++l2 + CompoundExpr l1 l2 -> l1++l2 + SizeofExpr l1 -> l1 + SizeofType l1 -> l1 + LiteralExpr _ l1 -> [l1] + VarExpr l1 -> [l1] + MemberAccess l1 l2 -> l1++[l2] + PointerAccess l1 l2 -> l1++[l2] + ArrayAccess l1 l2 -> l1++l2 + FunctionCall l1 l2 -> l1++concat l2 + CommentExpr l1 l2 -> l1++l2 + EnumClass l1 l2 -> l1:concat l2 + EnumConsts l1 l2 -> maybeToList l1++concat l2 + EnumDecl l1 l2 l3 -> l1:concat l2++[l3] + Enumerator l1 l2 -> l1:concat (maybeToList l2) + ClassForward l1 l2 -> l1:concat l2 + Typedef l1 l2 -> l1++[l2] + TypedefFunction l1 -> l1 + Struct l1 l2 -> l1:concat l2 + Union l1 l2 -> l1:concat l2 + MemberDecl l1 l2 l3 -> l1++l2++maybeToList l3 + TyConst l1 -> l1 + TyPointer l1 -> l1 + TyStruct l1 -> [l1] + TyFunc l1 -> [l1] + TyStd l1 -> [l1] + TyVar l1 -> [l1] + TyUserDefined l1 -> [l1] + FunctionDecl _ l1 l2 -> l1++concat (maybeToList l2) + FunctionDefn _ l1 l2 -> l1++l2 + FunctionPrototype l1 l2 l3 -> l1++[l2]++concat l3 + FunctionParam l1 l2 -> l1++l2 + Event l1 l2 -> l1:l2 + EventParams l1 -> concat l1 + Property l1 l2 l3 -> l1++l2++concat l3 + Accessor l1 l2 l3 -> l1:concat l2++concat (maybeToList l3) + ErrorDecl l1 l2 -> l1:concat l2 + ErrorList l1 -> concat l1 + ErrorFor l1 -> [l1] + Ellipsis -> [] + ConstDecl l1 l2 -> l1++[l2] + ConstDefn _ l1 l2 l3 -> l1++[l2]++l3 diff --git a/src/Language/Cimple/IO.hs b/src/Language/Cimple/IO.hs index 5c834c4..019af82 100644 --- a/src/Language/Cimple/IO.hs +++ b/src/Language/Cimple/IO.hs @@ -14,7 +14,7 @@ import qualified Data.Map.Strict as Map import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text -import Language.Cimple.AST (Node (..)) +import Language.Cimple.AST (Node) import Language.Cimple.Lexer (Lexeme, runAlex) import qualified Language.Cimple.Parser as Parser import Language.Cimple.Program (Program) @@ -24,14 +24,14 @@ import Language.Cimple.TraverseAst (TextActions, textActions, traverseAst) import qualified Language.Cimple.TreeParser as TreeParser -type StringNode = Node () (Lexeme String) -type TextNode = Node () (Lexeme Text) +type StringNode = Node (Lexeme String) +type TextNode = Node (Lexeme Text) toTextAst :: [StringNode] -> [TextNode] toTextAst stringAst = evalState (traverseAst cacheActions stringAst) Map.empty where - cacheActions :: TextActions (State (Map String Text)) () String Text + cacheActions :: TextActions (State (Map String Text)) String Text cacheActions = textActions $ \s -> do m <- get case Map.lookup s m of diff --git a/src/Language/Cimple/Parser.y b/src/Language/Cimple/Parser.y index 26dc720..94a393e 100644 --- a/src/Language/Cimple/Parser.y +++ b/src/Language/Cimple/Parser.y @@ -3,9 +3,11 @@ module Language.Cimple.Parser ( parseTranslationUnit ) where +import Data.Fix (Fix (..)) import Language.Cimple.AST (AssignOp (..), BinaryOp (..), CommentStyle (..), LiteralType (..), - Node (..), Scope (..), UnaryOp (..)) + Node, NodeF (..), Scope (..), + UnaryOp (..)) import Language.Cimple.Lexer (Alex, AlexPosn (..), Lexeme (..), alexError, alexMonadScan) import Language.Cimple.Tokens (LexemeClass (..)) @@ -158,7 +160,7 @@ TranslationUnit LicenseDecl :: { StringNode } LicenseDecl -: '/*' 'License' CMT_WORD '\n' CopyrightDecls '*/' { LicenseDecl $3 $5 } +: '/*' 'License' CMT_WORD '\n' CopyrightDecls '*/' { Fix $ LicenseDecl $3 $5 } CopyrightDecls :: { [StringNode] } CopyrightDecls @@ -167,7 +169,7 @@ CopyrightDecls CopyrightDecl :: { StringNode } CopyrightDecl -: ' * ' 'Copyright' CopyrightDates CopyrightOwner '\n' { CopyrightDecl (fst $3) (snd $3) $4 } +: ' * ' 'Copyright' CopyrightDates CopyrightOwner '\n' { Fix $ CopyrightDecl (fst $3) (snd $3) $4 } CopyrightDates :: { (StringLexeme, Maybe StringLexeme) } CopyrightDates @@ -204,7 +206,7 @@ ToplevelDecl StaticAssert :: { StringNode } StaticAssert -: static_assert '(' ConstExpr ',' LIT_STRING ')' ';' { StaticAssert $3 $5 } +: static_assert '(' ConstExpr ',' LIT_STRING ')' ';' { Fix $ StaticAssert $3 $5 } Namespace :: { StringNode } Namespace @@ -213,18 +215,18 @@ Namespace NamespaceDeclarator :: { Scope -> StringNode } NamespaceDeclarator -: class ID_SUE_TYPE TypeParams '{' ToplevelDecls '}' { \s -> Class s $2 $3 (reverse $5) } -| namespace IdVar '{' ToplevelDecls '}' { \s -> Namespace s $2 (reverse $4) } +: class ID_SUE_TYPE TypeParams '{' ToplevelDecls '}' { \s -> Fix $ Class s $2 $3 (reverse $5) } +| namespace IdVar '{' ToplevelDecls '}' { \s -> Fix $ Namespace s $2 (reverse $4) } TypeParams :: { [StringNode] } TypeParams : { [] } -| '<' ID_TYVAR '>' { [TyVar $2] } +| '<' ID_TYVAR '>' { [Fix $ TyVar $2] } Event :: { StringNode } Event -: event IdVar '{' Comment EventType '}' { Event $2 (Commented $4 $5) } -| event IdVar const '{' Comment EventType '}' { Event $2 (Commented $5 $6) } +: event IdVar '{' Comment EventType '}' { Fix $ Event $2 (Fix $ Commented $4 $5) } +| event IdVar const '{' Comment EventType '}' { Fix $ Event $2 (Fix $ Commented $5 $6) } EventType :: { StringNode } EventType @@ -232,18 +234,18 @@ EventType EventParams :: { StringNode } EventParams -: FunctionParamList { EventParams $1 } +: FunctionParamList { Fix $ EventParams $1 } ErrorDecl :: { StringNode } ErrorDecl -: 'error' for IdVar EnumeratorList { ErrorDecl $3 $4 } +: 'error' for IdVar EnumeratorList { Fix $ ErrorDecl $3 $4 } Comment :: { StringNode } Comment -: '/*' CommentTokens '*/' { Comment Regular $1 (reverse $2) $3 } -| '/**' CommentTokens '*/' { Comment Doxygen $1 (reverse $2) $3 } -| '/***' CommentTokens '*/' { Comment Block $1 (reverse $2) $3 } -| '/**/' { CommentBlock $1 } +: '/*' CommentTokens '*/' { Fix $ Comment Regular $1 (reverse $2) $3 } +| '/**' CommentTokens '*/' { Fix $ Comment Doxygen $1 (reverse $2) $3 } +| '/***' CommentTokens '*/' { Fix $ Comment Block $1 (reverse $2) $3 } +| '/**/' { Fix $ CommentBlock $1 } CommentTokens :: { [StringLexeme] } CommentTokens @@ -284,42 +286,42 @@ CommentWord | '=' { $1 } PreprocIfdef(decls) -: '#ifdef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfdef $2 (reverse $3) $4 } -| '#ifndef' ID_CONST decls PreprocElse(decls) '#endif' { PreprocIfndef $2 (reverse $3) $4 } +: '#ifdef' ID_CONST decls PreprocElse(decls) '#endif' { Fix $ PreprocIfdef $2 (reverse $3) $4 } +| '#ifndef' ID_CONST decls PreprocElse(decls) '#endif' { Fix $ PreprocIfndef $2 (reverse $3) $4 } PreprocIf(decls) -: '#if' PreprocConstExpr '\n' decls PreprocElse(decls) '#endif' { PreprocIf $2 (reverse $4) $5 } +: '#if' PreprocConstExpr '\n' decls PreprocElse(decls) '#endif' { Fix $ PreprocIf $2 (reverse $4) $5 } PreprocElse(decls) -: { PreprocElse [] } -| '#else' decls { PreprocElse $2 } -| '#elif' PreprocConstExpr '\n' decls PreprocElse(decls) { PreprocElif $2 (reverse $4) $5 } +: { Fix $ PreprocElse [] } +| '#else' decls { Fix $ PreprocElse $2 } +| '#elif' PreprocConstExpr '\n' decls PreprocElse(decls) { Fix $ PreprocElif $2 (reverse $4) $5 } PreprocInclude :: { StringNode } PreprocInclude -: '#include' LIT_STRING { PreprocInclude $2 } -| '#include' LIT_SYS_INCLUDE { PreprocInclude $2 } +: '#include' LIT_STRING { Fix $ PreprocInclude $2 } +| '#include' LIT_SYS_INCLUDE { Fix $ PreprocInclude $2 } PreprocDefine :: { StringNode } PreprocDefine -: '#define' ID_CONST '\n' { PreprocDefine $2 } -| '#define' ID_CONST PreprocSafeExpr(ConstExpr) '\n' { PreprocDefineConst $2 $3 } -| '#define' ID_CONST MacroParamList MacroBody '\n' { PreprocDefineMacro $2 $3 $4 } +: '#define' ID_CONST '\n' { Fix $ PreprocDefine $2 } +| '#define' ID_CONST PreprocSafeExpr(ConstExpr) '\n' { Fix $ PreprocDefineConst $2 $3 } +| '#define' ID_CONST MacroParamList MacroBody '\n' { Fix $ PreprocDefineMacro $2 $3 $4 } PreprocUndef :: { StringNode } PreprocUndef -: '#undef' ID_CONST { PreprocUndef $2 } +: '#undef' ID_CONST { Fix $ PreprocUndef $2 } PreprocConstExpr :: { StringNode } PreprocConstExpr : PureExpr(PreprocConstExpr) { $1 } -| 'defined' '(' ID_CONST ')' { PreprocDefined $3 } +| 'defined' '(' ID_CONST ')' { Fix $ PreprocDefined $3 } MacroParamList :: { [StringNode] } MacroParamList : '(' ')' { [] } | '(' MacroParams ')' { reverse $2 } -| '(' MacroParams ',' '...' ')' { reverse $ Ellipsis : $2 } +| '(' MacroParams ',' '...' ')' { reverse $ Fix Ellipsis : $2 } MacroParams :: { [StringNode] } MacroParams @@ -328,12 +330,12 @@ MacroParams MacroParam :: { StringNode } MacroParam -: IdVar { MacroParam $1 } +: IdVar { Fix $ MacroParam $1 } MacroBody :: { StringNode } MacroBody : do CompoundStmt while '(' LIT_INTEGER ')' {% macroBodyStmt $2 $5 } -| FunctionCall { MacroBodyFunCall $1 } +| FunctionCall { Fix $ MacroBodyFunCall $1 } ExternC :: { StringNode } ExternC @@ -354,7 +356,7 @@ Stmt :: { StringNode } Stmt : PreprocIfdef(Stmts) { $1 } | PreprocIf(Stmts) { $1 } -| PreprocDefine Stmts PreprocUndef { PreprocScopedDefine $1 $2 $3 } +| PreprocDefine Stmts PreprocUndef { Fix $ PreprocScopedDefine $1 $2 $3 } | DeclStmt { $1 } | CompoundStmt { $1 } | IfStmt { $1 } @@ -364,24 +366,24 @@ Stmt | AssignExpr ';' { $1 } | ExprStmt ';' { $1 } | FunctionCall ';' { $1 } -| break ';' { Break } -| goto ID_CONST ';' { Goto $2 } -| ID_CONST ':' Stmt { Label $1 $3 } -| continue ';' { Continue } -| return ';' { Return Nothing } -| return Expr ';' { Return (Just $2) } -| switch '(' Expr ')' '{' SwitchCases '}' { SwitchStmt $3 $6 } +| break ';' { Fix $ Break } +| goto ID_CONST ';' { Fix $ Goto $2 } +| ID_CONST ':' Stmt { Fix $ Label $1 $3 } +| continue ';' { Fix $ Continue } +| return ';' { Fix $ Return Nothing } +| return Expr ';' { Fix $ Return (Just $2) } +| switch '(' Expr ')' '{' SwitchCases '}' { Fix $ SwitchStmt $3 $6 } | Comment { $1 } IfStmt :: { StringNode } IfStmt -: if '(' Expr ')' CompoundStmt { IfStmt $3 $5 Nothing } -| if '(' Expr ')' CompoundStmt else IfStmt { IfStmt $3 $5 (Just $7) } -| if '(' Expr ')' CompoundStmt else CompoundStmt { IfStmt $3 $5 (Just $7) } +: if '(' Expr ')' CompoundStmt { Fix $ IfStmt $3 $5 Nothing } +| if '(' Expr ')' CompoundStmt else IfStmt { Fix $ IfStmt $3 $5 (Just $7) } +| if '(' Expr ')' CompoundStmt else CompoundStmt { Fix $ IfStmt $3 $5 (Just $7) } ForStmt :: { StringNode } ForStmt -: for '(' ForInit Expr ';' ForNext ')' CompoundStmt { ForStmt $3 $4 $6 $8 } +: for '(' ForInit Expr ';' ForNext ')' CompoundStmt { Fix $ ForStmt $3 $4 $6 $8 } ForInit :: { StringNode } ForInit @@ -395,11 +397,11 @@ ForNext WhileStmt :: { StringNode } WhileStmt -: while '(' Expr ')' CompoundStmt { WhileStmt $3 $5 } +: while '(' Expr ')' CompoundStmt { Fix $ WhileStmt $3 $5 } DoWhileStmt :: { StringNode } DoWhileStmt -: do CompoundStmt while '(' Expr ')' ';' { DoWhileStmt $2 $5 } +: do CompoundStmt while '(' Expr ')' ';' { Fix $ DoWhileStmt $2 $5 } SwitchCases :: { [StringNode] } SwitchCases @@ -408,39 +410,39 @@ SwitchCases SwitchCase :: { StringNode } SwitchCase -: case Expr ':' SwitchCaseBody { Case $2 $4 } -| default ':' SwitchCaseBody { Default $3 } +: case Expr ':' SwitchCaseBody { Fix $ Case $2 $4 } +| default ':' SwitchCaseBody { Fix $ Default $3 } SwitchCaseBody :: { StringNode } SwitchCaseBody : CompoundStmt { $1 } | SwitchCase { $1 } -| return Expr ';' { Return (Just $2) } +| return Expr ';' { Fix $ Return (Just $2) } DeclStmt :: { StringNode } DeclStmt : VarDecl { $1 } -| VLA '(' QualType ',' IdVar ',' Expr ')' ';' { VLA $3 $5 $7 } +| VLA '(' QualType ',' IdVar ',' Expr ')' ';' { Fix $ VLA $3 $5 $7 } VarDecl :: { StringNode } VarDecl -: QualType Declarator ';' { VarDecl $1 $2 } +: QualType Declarator ';' { Fix $ VarDecl $1 $2 } Declarator :: { StringNode } Declarator -: DeclSpec '=' InitialiserExpr { Declarator $1 (Just $3) } -| DeclSpec { Declarator $1 Nothing } +: DeclSpec '=' InitialiserExpr { Fix $ Declarator $1 (Just $3) } +| DeclSpec { Fix $ Declarator $1 Nothing } InitialiserExpr :: { StringNode } InitialiserExpr -: InitialiserList { InitialiserList $1 } +: InitialiserList { Fix $ InitialiserList $1 } | Expr { $1 } DeclSpec :: { StringNode } DeclSpec -: IdVar { DeclSpecVar $1 } -| DeclSpec '[' ']' { DeclSpecArray $1 Nothing } -| DeclSpec '[' Expr ']' { DeclSpecArray $1 (Just $3) } +: IdVar { Fix $ DeclSpecVar $1 } +| DeclSpec '[' ']' { Fix $ DeclSpecArray $1 Nothing } +| DeclSpec '[' Expr ']' { Fix $ DeclSpecArray $1 (Just $3) } IdVar :: { Lexeme String } IdVar @@ -461,19 +463,19 @@ Initialisers Initialiser :: { StringNode } Initialiser : Expr { $1 } -| InitialiserList { InitialiserList $1 } +| InitialiserList { Fix $ InitialiserList $1 } CompoundStmt :: { StringNode } CompoundStmt -: '{' Stmts '}' { CompoundStmt (reverse $2) } +: '{' Stmts '}' { Fix $ CompoundStmt (reverse $2) } -- Expressions that are safe for use as macro body without () around it.. PreprocSafeExpr(x) : LiteralExpr { $1 } -| '(' x ')' { ParenExpr $2 } -| '(' QualType ')' x %prec CAST { CastExpr $2 $4 } -| sizeof '(' x ')' { SizeofExpr $3 } -| sizeof '(' QualType ')' { SizeofType $3 } +| '(' x ')' { Fix $ ParenExpr $2 } +| '(' QualType ')' x %prec CAST { Fix $ CastExpr $2 $4 } +| sizeof '(' x ')' { Fix $ SizeofExpr $3 } +| sizeof '(' QualType ')' { Fix $ SizeofType $3 } ConstExpr :: { StringNode } ConstExpr @@ -481,51 +483,51 @@ ConstExpr PureExpr(x) : PreprocSafeExpr(x) { $1 } -| x '!=' x { BinaryExpr $1 BopNe $3 } -| x '==' x { BinaryExpr $1 BopEq $3 } -| x '||' x { BinaryExpr $1 BopOr $3 } -| x '^' x { BinaryExpr $1 BopBitXor $3 } -| x '|' x { BinaryExpr $1 BopBitOr $3 } -| x '&&' x { BinaryExpr $1 BopAnd $3 } -| x '&' x { BinaryExpr $1 BopBitAnd $3 } -| x '/' x { BinaryExpr $1 BopDiv $3 } -| x '*' x { BinaryExpr $1 BopMul $3 } -| x '%' x { BinaryExpr $1 BopMod $3 } -| x '+' x { BinaryExpr $1 BopPlus $3 } -| x '-' x { BinaryExpr $1 BopMinus $3 } -| x '<' x { BinaryExpr $1 BopLt $3 } -| x '<=' x { BinaryExpr $1 BopLe $3 } -| x '<<' x { BinaryExpr $1 BopLsh $3 } -| x '>' x { BinaryExpr $1 BopGt $3 } -| x '>=' x { BinaryExpr $1 BopGe $3 } -| x '>>' x { BinaryExpr $1 BopRsh $3 } -| x '?' x ':' x { TernaryExpr $1 $3 $5 } -| '!' x { UnaryExpr UopNot $2 } -| '~' x { UnaryExpr UopNeg $2 } -| '-' x %prec NEG { UnaryExpr UopMinus $2 } -| '&' x %prec ADDRESS { UnaryExpr UopAddress $2 } +| x '!=' x { Fix $ BinaryExpr $1 BopNe $3 } +| x '==' x { Fix $ BinaryExpr $1 BopEq $3 } +| x '||' x { Fix $ BinaryExpr $1 BopOr $3 } +| x '^' x { Fix $ BinaryExpr $1 BopBitXor $3 } +| x '|' x { Fix $ BinaryExpr $1 BopBitOr $3 } +| x '&&' x { Fix $ BinaryExpr $1 BopAnd $3 } +| x '&' x { Fix $ BinaryExpr $1 BopBitAnd $3 } +| x '/' x { Fix $ BinaryExpr $1 BopDiv $3 } +| x '*' x { Fix $ BinaryExpr $1 BopMul $3 } +| x '%' x { Fix $ BinaryExpr $1 BopMod $3 } +| x '+' x { Fix $ BinaryExpr $1 BopPlus $3 } +| x '-' x { Fix $ BinaryExpr $1 BopMinus $3 } +| x '<' x { Fix $ BinaryExpr $1 BopLt $3 } +| x '<=' x { Fix $ BinaryExpr $1 BopLe $3 } +| x '<<' x { Fix $ BinaryExpr $1 BopLsh $3 } +| x '>' x { Fix $ BinaryExpr $1 BopGt $3 } +| x '>=' x { Fix $ BinaryExpr $1 BopGe $3 } +| x '>>' x { Fix $ BinaryExpr $1 BopRsh $3 } +| x '?' x ':' x { Fix $ TernaryExpr $1 $3 $5 } +| '!' x { Fix $ UnaryExpr UopNot $2 } +| '~' x { Fix $ UnaryExpr UopNeg $2 } +| '-' x %prec NEG { Fix $ UnaryExpr UopMinus $2 } +| '&' x %prec ADDRESS { Fix $ UnaryExpr UopAddress $2 } LiteralExpr :: { StringNode } LiteralExpr : StringLiteralExpr { $1 } -| LIT_CHAR { LiteralExpr Char $1 } -| LIT_INTEGER { LiteralExpr Int $1 } -| LIT_FALSE { LiteralExpr Bool $1 } -| LIT_TRUE { LiteralExpr Bool $1 } -| ID_CONST { LiteralExpr ConstId $1 } +| LIT_CHAR { Fix $ LiteralExpr Char $1 } +| LIT_INTEGER { Fix $ LiteralExpr Int $1 } +| LIT_FALSE { Fix $ LiteralExpr Bool $1 } +| LIT_TRUE { Fix $ LiteralExpr Bool $1 } +| ID_CONST { Fix $ LiteralExpr ConstId $1 } StringLiteralExpr :: { StringNode } StringLiteralExpr -: LIT_STRING { LiteralExpr String $1 } +: LIT_STRING { Fix $ LiteralExpr String $1 } | StringLiteralExpr LIT_STRING { $1 } LhsExpr :: { StringNode } LhsExpr -: IdVar { VarExpr $1 } -| '*' LhsExpr %prec DEREF { UnaryExpr UopDeref $2 } -| LhsExpr '.' IdVar { MemberAccess $1 $3 } -| LhsExpr '->' IdVar { PointerAccess $1 $3 } -| LhsExpr '[' Expr ']' { ArrayAccess $1 $3 } +: IdVar { Fix $ VarExpr $1 } +| '*' LhsExpr %prec DEREF { Fix $ UnaryExpr UopDeref $2 } +| LhsExpr '.' IdVar { Fix $ MemberAccess $1 $3 } +| LhsExpr '->' IdVar { Fix $ PointerAccess $1 $3 } +| LhsExpr '[' Expr ']' { Fix $ ArrayAccess $1 $3 } Expr :: { StringNode } Expr @@ -538,11 +540,11 @@ Expr -- Allow `(Type){0}` to set struct values to all-zero. CompoundExpr :: { StringNode } CompoundExpr -: '(' QualType ')' '{' Expr '}' { CompoundExpr $2 $5 } +: '(' QualType ')' '{' Expr '}' { Fix $ CompoundExpr $2 $5 } AssignExpr :: { StringNode } AssignExpr -: LhsExpr AssignOperator Expr { AssignExpr $1 $2 $3 } +: LhsExpr AssignOperator Expr { Fix $ AssignExpr $1 $2 $3 } AssignOperator :: { AssignOp } AssignOperator @@ -560,12 +562,12 @@ AssignOperator ExprStmt :: { StringNode } ExprStmt -: '++' Expr { UnaryExpr UopIncr $2 } -| '--' Expr { UnaryExpr UopDecr $2 } +: '++' Expr { Fix $ UnaryExpr UopIncr $2 } +| '--' Expr { Fix $ UnaryExpr UopDecr $2 } FunctionCall :: { StringNode } FunctionCall -: Expr ArgList { FunctionCall $1 $2 } +: Expr ArgList { Fix $ FunctionCall $1 $2 } ArgList :: { [StringNode] } ArgList @@ -580,15 +582,15 @@ Args Arg :: { StringNode } Arg : Expr { $1 } -| Comment Expr { CommentExpr $1 $2 } +| Comment Expr { Fix $ CommentExpr $1 $2 } EnumDecl :: { StringNode } EnumDecl -: enum class ID_SUE_TYPE EnumeratorList { EnumClass $3 $4 } -| enum ID_SUE_TYPE EnumeratorList ';' { EnumConsts (Just $2) $3 } -| enum EnumeratorList ';' { EnumConsts Nothing $2 } -| typedef enum ID_SUE_TYPE EnumeratorList ID_SUE_TYPE ';' { EnumDecl $3 $4 $5 } -| bitmask ID_SUE_TYPE EnumeratorList { EnumDecl $2 $3 $2 } +: enum class ID_SUE_TYPE EnumeratorList { Fix $ EnumClass $3 $4 } +| enum ID_SUE_TYPE EnumeratorList ';' { Fix $ EnumConsts (Just $2) $3 } +| enum EnumeratorList ';' { Fix $ EnumConsts Nothing $2 } +| typedef enum ID_SUE_TYPE EnumeratorList ID_SUE_TYPE ';' { Fix $ EnumDecl $3 $4 $5 } +| bitmask ID_SUE_TYPE EnumeratorList { Fix $ EnumDecl $2 $3 $2 } EnumeratorList :: { [StringNode] } EnumeratorList @@ -601,9 +603,9 @@ Enumerators Enumerator :: { StringNode } Enumerator -: EnumeratorName ',' { Enumerator $1 Nothing } -| EnumeratorName '=' ConstExpr ',' { Enumerator $1 (Just $3) } -| namespace ID_CONST '{' Enumerators '}' { Namespace Global $2 $4 } +: EnumeratorName ',' { Fix $ Enumerator $1 Nothing } +| EnumeratorName '=' ConstExpr ',' { Fix $ Enumerator $1 (Just $3) } +| namespace ID_CONST '{' Enumerators '}' { Fix $ Namespace Global $2 $4 } | Comment { $1 } EnumeratorName :: { Lexeme String } @@ -614,14 +616,14 @@ EnumeratorName AggregateDecl :: { StringNode } AggregateDecl : AggregateType ';' { $1 } -| class ID_SUE_TYPE TypeParams ';' { ClassForward $2 $3 } -| typedef AggregateType ID_SUE_TYPE ';' { Typedef $2 $3 } +| class ID_SUE_TYPE TypeParams ';' { Fix $ ClassForward $2 $3 } +| typedef AggregateType ID_SUE_TYPE ';' { Fix $ Typedef $2 $3 } AggregateType :: { StringNode } AggregateType -: struct ID_SUE_TYPE '{' MemberDeclList '}' { Struct $2 $4 } -| struct this '{' MemberDeclList '}' { Struct $2 $4 } -| union ID_SUE_TYPE '{' MemberDeclList '}' { Union $2 $4 } +: struct ID_SUE_TYPE '{' MemberDeclList '}' { Fix $ Struct $2 $4 } +| struct this '{' MemberDeclList '}' { Fix $ Struct $2 $4 } +| union ID_SUE_TYPE '{' MemberDeclList '}' { Fix $ Union $2 $4 } MemberDeclList :: { [StringNode] } MemberDeclList @@ -634,42 +636,42 @@ MemberDecls MemberDecl :: { StringNode } MemberDecl -: QualType DeclSpec ';' { MemberDecl $1 $2 Nothing } -| QualType DeclSpec ':' LIT_INTEGER ';' { MemberDecl $1 $2 (Just $4) } -| namespace IdVar '{' MemberDeclList '}' { Namespace Global $2 $4 } +: QualType DeclSpec ';' { Fix $ MemberDecl $1 $2 Nothing } +| QualType DeclSpec ':' LIT_INTEGER ';' { Fix $ MemberDecl $1 $2 (Just $4) } +| namespace IdVar '{' MemberDeclList '}' { Fix $ Namespace Global $2 $4 } | PreprocIfdef(MemberDeclList) { $1 } | Comment { $1 } TypedefDecl :: { StringNode } TypedefDecl -: typedef QualType ID_SUE_TYPE ';' { Typedef $2 $3 } -| typedef FunctionPrototype(ID_FUNC_TYPE) ';' { TypedefFunction $2 } +: typedef QualType ID_SUE_TYPE ';' { Fix $ Typedef $2 $3 } +| typedef FunctionPrototype(ID_FUNC_TYPE) ';' { Fix $ TypedefFunction $2 } QualType :: { StringNode } QualType : LeafType { $1 } -| LeafType '*' { TyPointer $1 } -| LeafType '*' '*' { TyPointer (TyPointer $1) } -| LeafType '*' const { TyConst (TyPointer $1) } -| LeafType '*' const '*' { TyPointer (TyConst (TyPointer $1)) } -| LeafType const { TyConst $1 } -| LeafType const '*' { TyPointer (TyConst $1) } -| LeafType const '*' const { TyConst (TyPointer (TyConst $1)) } -| LeafType const '*' const '*' { TyPointer (TyConst (TyPointer (TyConst $1))) } -| const LeafType { TyConst $2 } -| const LeafType '*' { TyPointer (TyConst $2) } -| const LeafType '*' const { TyConst (TyPointer (TyConst $2)) } -| const LeafType '*' const '*' { TyPointer (TyConst (TyPointer (TyConst $2))) } +| LeafType '*' { tyPointer $1 } +| LeafType '*' '*' { tyPointer (tyPointer $1) } +| LeafType '*' const { tyConst (tyPointer $1) } +| LeafType '*' const '*' { tyPointer (tyConst (tyPointer $1)) } +| LeafType const { tyConst $1 } +| LeafType const '*' { tyPointer (tyConst $1) } +| LeafType const '*' const { tyConst (tyPointer (tyConst $1)) } +| LeafType const '*' const '*' { tyPointer (tyConst (tyPointer (tyConst $1))) } +| const LeafType { tyConst $2 } +| const LeafType '*' { tyPointer (tyConst $2) } +| const LeafType '*' const { tyConst (tyPointer (tyConst $2)) } +| const LeafType '*' const '*' { tyPointer (tyConst (tyPointer (tyConst $2))) } LeafType :: { StringNode } LeafType -: struct ID_SUE_TYPE { TyStruct $2 } -| void { TyStd $1 } -| this { TyStd $1 } -| ID_FUNC_TYPE { TyFunc $1 } -| ID_STD_TYPE { TyStd $1 } -| ID_SUE_TYPE { TyUserDefined $1 } -| ID_TYVAR { TyVar $1 } +: struct ID_SUE_TYPE { Fix $ TyStruct $2 } +| void { Fix $ TyStd $1 } +| this { Fix $ TyStd $1 } +| ID_FUNC_TYPE { Fix $ TyFunc $1 } +| ID_STD_TYPE { Fix $ TyStd $1 } +| ID_SUE_TYPE { Fix $ TyUserDefined $1 } +| ID_TYVAR { Fix $ TyVar $1 } FunctionDecl :: { StringNode } FunctionDecl @@ -678,9 +680,9 @@ FunctionDecl FunctionDeclarator :: { Scope -> StringNode } FunctionDeclarator -: FunctionPrototype(IdVar) WithError { \s -> FunctionDecl s $1 $2 } -| FunctionPrototype(IdVar) CompoundStmt { \s -> FunctionDefn s $1 $2 } -| QualType DeclSpec '{' Accessors '}' { \s -> Property $1 $2 (reverse $4) } +: FunctionPrototype(IdVar) WithError { \s -> Fix $ FunctionDecl s $1 $2 } +| FunctionPrototype(IdVar) CompoundStmt { \s -> Fix $ FunctionDefn s $1 $2 } +| QualType DeclSpec '{' Accessors '}' { \s -> Fix $ Property $1 $2 (reverse $4) } Accessors :: { [StringNode] } Accessors @@ -689,25 +691,25 @@ Accessors Accessor :: { StringNode } Accessor -: IdVar FunctionParamList WithError { Accessor $1 $2 $3 } +: IdVar FunctionParamList WithError { Fix $ Accessor $1 $2 $3 } | Comment { $1 } WithError :: { Maybe StringNode } WithError : ';' { Nothing } -| with 'error' EnumeratorList { Just (ErrorList $3) } -| with 'error' for IdVar ';' { Just (ErrorFor $4) } +| with 'error' EnumeratorList { Just (Fix (ErrorList $3)) } +| with 'error' for IdVar ';' { Just (Fix (ErrorFor $4)) } FunctionPrototype(id) -: QualType id FunctionParamList { FunctionPrototype $1 $2 $3 } -| QualType id FunctionParamList const { FunctionPrototype $1 $2 $3 } +: QualType id FunctionParamList { Fix $ FunctionPrototype $1 $2 $3 } +| QualType id FunctionParamList const { Fix $ FunctionPrototype $1 $2 $3 } FunctionParamList :: { [StringNode] } FunctionParamList : '(' ')' { [] } -| '(' void ')' { [TyStd $2] } +| '(' void ')' { [Fix $ TyStd $2] } | '(' FunctionParams ')' { reverse $2 } -| '(' FunctionParams ',' '...' ')' { reverse $ Ellipsis : $2 } +| '(' FunctionParams ',' '...' ')' { reverse $ Fix Ellipsis : $2 } FunctionParams :: { [StringNode] } FunctionParams @@ -716,17 +718,21 @@ FunctionParams FunctionParam :: { StringNode } FunctionParam -: QualType DeclSpec { FunctionParam $1 $2 } +: QualType DeclSpec { Fix $ FunctionParam $1 $2 } ConstDecl :: { StringNode } ConstDecl -: extern const LeafType ID_VAR ';' { ConstDecl $3 $4 } -| const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Global $2 $3 $5 } -| static const LeafType ID_VAR '=' InitialiserExpr ';' { ConstDefn Static $3 $4 $6 } +: extern const LeafType ID_VAR ';' { Fix $ ConstDecl $3 $4 } +| const LeafType ID_VAR '=' InitialiserExpr ';' { Fix $ ConstDefn Global $2 $3 $5 } +| static const LeafType ID_VAR '=' InitialiserExpr ';' { Fix $ ConstDefn Static $3 $4 $6 } { type StringLexeme = Lexeme String -type StringNode = Node () StringLexeme +type StringNode = Node StringLexeme + +tyPointer, tyConst :: StringNode -> StringNode +tyPointer = Fix . TyPointer +tyConst = Fix . TyConst parseError :: Show text => (Lexeme text, [String]) -> Alex a parseError (L (AlexPn _ line col) c t, options) = @@ -743,7 +749,7 @@ externC -> Lexeme String -> Alex StringNode externC (L _ _ "__cplusplus") (L _ _ "\"C\"") decls (L _ _ "__cplusplus") = - return $ ExternC decls + return $ Fix $ ExternC decls externC _ lang _ _ = alexError $ show lang <> ": extern \"C\" declaration invalid (did you spell __cplusplus right?)" @@ -753,7 +759,7 @@ macroBodyStmt -> Lexeme String -> Alex StringNode macroBodyStmt decls (L _ _ "0") = - return $ MacroBodyStmt decls + return $ Fix $ MacroBodyStmt decls macroBodyStmt _ cond = alexError $ show cond <> ": macro do-while body must end in 'while (0)'" diff --git a/src/Language/Cimple/Pretty.hs b/src/Language/Cimple/Pretty.hs index 7b4154a..25be1ac 100644 --- a/src/Language/Cimple/Pretty.hs +++ b/src/Language/Cimple/Pretty.hs @@ -1,13 +1,14 @@ module Language.Cimple.Pretty (ppTranslationUnit) where +import Data.Fix (Fix (..)) import qualified Data.List as List import Data.Text (Text) import qualified Data.Text as Text import Language.Cimple (AssignOp (..), BinaryOp (..), CommentStyle (..), Lexeme (..), - LexemeClass (..), Node (..), - Scope (..), UnaryOp (..), - lexemeText) + LexemeClass (..), Node, + NodeF (..), Scope (..), + UnaryOp (..), lexemeText) import Prelude hiding ((<$>)) import Text.Groom (groom) import Text.PrettyPrint.ANSI.Leijen @@ -75,15 +76,15 @@ ppScope :: Scope -> Doc ppScope Global = empty ppScope Static = text "static " -ppType :: Show a => Node a (Lexeme Text) -> Doc -ppType (TyPointer ty) = ppType ty <> char '*' -ppType (TyConst ty) = ppType ty <+> text "const" -ppType (TyUserDefined l ) = ppLexeme l -ppType (TyStd l ) = ppLexeme l -ppType (TyFunc l ) = ppLexeme l -ppType (TyStruct l ) = text "struct" <+> ppLexeme l -ppType (TyVar l ) = ppLexeme l -ppType x = error . groom $ x +ppType :: Node (Lexeme Text) -> Doc +ppType (Fix (TyPointer ty)) = ppType ty <> char '*' +ppType (Fix (TyConst ty)) = ppType ty <+> text "const" +ppType (Fix (TyUserDefined l )) = ppLexeme l +ppType (Fix (TyStd l )) = ppLexeme l +ppType (Fix (TyFunc l )) = ppLexeme l +ppType (Fix (TyStruct l )) = text "struct" <+> ppLexeme l +ppType (Fix (TyVar l )) = ppLexeme l +ppType x = error . groom $ x ppAssignOp :: AssignOp -> Doc ppAssignOp op = case op of @@ -130,71 +131,70 @@ ppUnaryOp op = case op of UopIncr -> text "++" UopDecr -> text "--" -ppInitialiserList :: Show a => [Node a (Lexeme Text)] -> Doc +ppInitialiserList :: [Node (Lexeme Text)] -> Doc ppInitialiserList l = char '{' <+> ppCommaSep ppExpr l <+> char '}' -ppDeclSpec :: Show a => Node a (Lexeme Text) -> Doc -ppDeclSpec (DeclSpecVar var ) = ppLexeme var -ppDeclSpec (DeclSpecArray dspec dim) = ppDeclSpec dspec <> ppDim dim +ppDeclSpec :: Node (Lexeme Text) -> Doc +ppDeclSpec (Fix (DeclSpecVar var )) = ppLexeme var +ppDeclSpec (Fix (DeclSpecArray dspec dim)) = ppDeclSpec dspec <> ppDim dim where ppDim Nothing = text "[]" ppDim (Just x) = char '[' <> ppExpr x <> char ']' ppDeclSpec x = error $ groom x -ppDeclarator :: Show a => Node a (Lexeme Text) -> Doc -ppDeclarator (Declarator dspec Nothing) = +ppDeclarator :: Node (Lexeme Text) -> Doc +ppDeclarator (Fix (Declarator dspec Nothing)) = ppDeclSpec dspec -ppDeclarator (Declarator dspec (Just initr)) = +ppDeclarator (Fix (Declarator dspec (Just initr))) = ppDeclSpec dspec <+> char '=' <+> ppExpr initr ppDeclarator x = error $ groom x -ppFunctionParamList :: Show a => [Node a (Lexeme Text)] -> Doc +ppFunctionParamList :: [Node (Lexeme Text)] -> Doc ppFunctionParamList xs = char '(' <> ppCommaSep go xs <> char ')' where - go (TyStd l@(L _ KwVoid _)) = ppLexeme l - go (FunctionParam ty dspec) = ppType ty <+> ppDeclSpec dspec - go Ellipsis = text "..." - go x = error $ groom x + go (Fix (TyStd l@(L _ KwVoid _))) = ppLexeme l + go (Fix (FunctionParam ty dspec)) = ppType ty <+> ppDeclSpec dspec + go (Fix Ellipsis) = text "..." + go x = error $ groom x ppFunctionPrototype - :: Show a - => Node a (Lexeme Text) + :: Node (Lexeme Text) -> Lexeme Text - -> [Node a (Lexeme Text)] + -> [Node (Lexeme Text)] -> Doc ppFunctionPrototype ty name params = ppType ty <+> ppLexeme name <> ppFunctionParamList params -ppWithError :: Show a => Maybe (Node a (Lexeme Text)) -> Doc +ppWithError :: Maybe (Node (Lexeme Text)) -> Doc ppWithError Nothing = char ';' -ppWithError (Just (ErrorFor name)) = +ppWithError (Just (Fix (ErrorFor name))) = text " with error for" <+> ppLexeme name <> char ';' -ppWithError (Just (ErrorList errs)) = +ppWithError (Just (Fix (ErrorList errs))) = nest 2 ( text " with error" <+> char '{' <$> ppEnumeratorList errs ) <$> char '}' ppWithError x = error $ groom x -ppFunctionCall :: Show a => Node a (Lexeme Text) -> [Node a (Lexeme Text)] -> Doc +ppFunctionCall :: Node (Lexeme Text) -> [Node (Lexeme Text)] -> Doc ppFunctionCall callee args = ppExpr callee <> char '(' <> ppCommaSep ppExpr args <> char ')' -ppMacroBody :: Show a => Node a (Lexeme Text) -> Doc -ppMacroBody (MacroBodyFunCall e@FunctionCall{}) = ppExpr e -ppMacroBody (MacroBodyStmt (CompoundStmt body)) = +ppMacroBody :: Node (Lexeme Text) -> Doc +ppMacroBody (Fix (MacroBodyFunCall e@(Fix FunctionCall{}))) = ppExpr e +ppMacroBody (Fix (MacroBodyStmt (Fix (CompoundStmt body)))) = nest 2 ( text "do {" <$> ppStmtList body ) <$> text "} while (0)" ppMacroBody x = error $ groom x -ppMacroParam :: Show a => Node a (Lexeme Text) -> Doc -ppMacroParam (MacroParam l) = ppLexeme l -ppMacroParam Ellipsis = text "..." -ppMacroParam x = error $ groom x +ppMacroParam :: Node (Lexeme Text) -> Doc +ppMacroParam (Fix (MacroParam l)) = ppLexeme l +ppMacroParam (Fix Ellipsis) = text "..." +ppMacroParam x = error $ groom x -ppMacroParamList :: Show a => [Node a (Lexeme Text)] -> Doc +ppMacroParamList :: [Node (Lexeme Text)] -> Doc ppMacroParamList xs = char '(' <> ppCommaSep ppMacroParam xs <> char ')' ppNamespace :: ([a] -> Doc) -> Scope -> Lexeme Text -> [a] -> Doc @@ -205,62 +205,61 @@ ppNamespace pp scope name members = pp members ) <$> char '}' -ppEnumerator :: Show a => Node a (Lexeme Text) -> Doc -ppEnumerator (Comment style _ cs _ ) = ppComment style cs -ppEnumerator (Enumerator name Nothing) = ppLexeme name <> char ',' -ppEnumerator (Enumerator name (Just value)) = +ppEnumerator :: Node (Lexeme Text) -> Doc +ppEnumerator (Fix (Comment style _ cs _ )) = ppComment style cs +ppEnumerator (Fix (Enumerator name Nothing)) = ppLexeme name <> char ',' +ppEnumerator (Fix (Enumerator name (Just value))) = ppLexeme name <+> char '=' <+> ppExpr value <> char ',' -ppEnumerator (Namespace scope name members) = +ppEnumerator (Fix (Namespace scope name members)) = ppNamespace ppEnumeratorList scope name members ppEnumerator x = error $ groom x -ppEnumeratorList :: Show a => [Node a (Lexeme Text)] -> Doc +ppEnumeratorList :: [Node (Lexeme Text)] -> Doc ppEnumeratorList = ppLineSep ppEnumerator -ppMemberDecl :: Show a => Node a (Lexeme Text) -> Doc +ppMemberDecl :: Node (Lexeme Text) -> Doc ppMemberDecl = ppDecl -ppMemberDeclList :: Show a => [Node a (Lexeme Text)] -> Doc +ppMemberDeclList :: [Node (Lexeme Text)] -> Doc ppMemberDeclList = ppLineSep ppMemberDecl -ppAccessor :: Show a => Node a (Lexeme Text) -> Doc -ppAccessor (Comment style _ cs _) = ppComment style cs -ppAccessor (Accessor name params errs) = +ppAccessor :: Node (Lexeme Text) -> Doc +ppAccessor (Fix (Comment style _ cs _)) = ppComment style cs +ppAccessor (Fix (Accessor name params errs)) = ppLexeme name <> ppFunctionParamList params <> ppWithError errs ppAccessor x = error $ groom x -ppAccessorList :: Show a => [Node a (Lexeme Text)] -> Doc +ppAccessorList :: [Node (Lexeme Text)] -> Doc ppAccessorList = ppLineSep ppAccessor -ppEventType :: Show a => Node a (Lexeme Text) -> Doc -ppEventType (Commented (Comment style _ cs _) ty) = +ppEventType :: Node (Lexeme Text) -> Doc +ppEventType (Fix (Commented (Fix (Comment style _ cs _)) ty)) = ppComment style cs <$> ppEventType ty -ppEventType (EventParams params) = +ppEventType (Fix (EventParams params)) = text "typedef void" <> ppFunctionParamList params ppEventType x = error $ groom x -ppTypeParams :: Show a => [Node a (Lexeme Text)] -> Doc +ppTypeParams :: [Node (Lexeme Text)] -> Doc ppTypeParams [] = empty ppTypeParams xs = char '<' <> ppCommaSep pp xs <> char '>' where - pp (TyVar x) = ppLexeme x - pp x = error $ groom x + pp (Fix (TyVar x)) = ppLexeme x + pp x = error $ groom x -ppCompoundStmt :: Show a => [Node a (Lexeme Text)] -> Doc +ppCompoundStmt :: [Node (Lexeme Text)] -> Doc ppCompoundStmt body = nest 2 ( char '{' <$> ppStmtList body ) <$> char '}' -ppStmtList :: Show a => [Node a (Lexeme Text)] -> Doc +ppStmtList :: [Node (Lexeme Text)] -> Doc ppStmtList = ppLineSep ppDecl ppIfStmt - :: Show a - => Node a (Lexeme Text) - -> [Node a (Lexeme Text)] - -> Maybe (Node a (Lexeme Text)) + :: Node (Lexeme Text) + -> [Node (Lexeme Text)] + -> Maybe (Node (Lexeme Text)) -> Doc ppIfStmt cond t Nothing = nest 2 ( @@ -274,11 +273,10 @@ ppIfStmt cond t (Just e) = ) <$> nest 2 (char '}' <> text " else " <> ppDecl e) ppForStmt - :: Show a - => Node a (Lexeme Text) - -> Node a (Lexeme Text) - -> Node a (Lexeme Text) - -> [Node a (Lexeme Text)] + :: Node (Lexeme Text) + -> Node (Lexeme Text) + -> Node (Lexeme Text) + -> [Node (Lexeme Text)] -> Doc ppForStmt i c n body = nest 2 ( @@ -291,9 +289,8 @@ ppForStmt i c n body = ) <$> char '}' ppWhileStmt - :: Show a - => Node a (Lexeme Text) - -> [Node a (Lexeme Text)] + :: Node (Lexeme Text) + -> [Node (Lexeme Text)] -> Doc ppWhileStmt c body = nest 2 ( @@ -304,9 +301,8 @@ ppWhileStmt c body = ) <$> char '}' ppDoWhileStmt - :: Show a - => [Node a (Lexeme Text)] - -> Node a (Lexeme Text) + :: [Node (Lexeme Text)] + -> Node (Lexeme Text) -> Doc ppDoWhileStmt body c = nest 2 ( @@ -316,9 +312,8 @@ ppDoWhileStmt body c = ) <$> text "} while (" <> ppExpr c <> char ')' ppSwitchStmt - :: Show a - => Node a (Lexeme Text) - -> [Node a (Lexeme Text)] + :: Node (Lexeme Text) + -> [Node (Lexeme Text)] -> Doc ppSwitchStmt c body = nest 2 ( @@ -328,8 +323,8 @@ ppSwitchStmt c body = ppStmtList body ) <$> char '}' -ppExpr :: Show a => Node a (Lexeme Text) -> Doc -ppExpr expr = case expr of +ppExpr :: Node (Lexeme Text) -> Doc +ppExpr expr = case unFix expr of -- Expressions VarExpr var -> ppLexeme var LiteralExpr _ l -> ppLexeme l @@ -354,39 +349,42 @@ ppExpr expr = case expr of x -> error $ groom x ppTernaryExpr - :: Show a => Node a (Lexeme Text) -> Node a (Lexeme Text) -> Node a (Lexeme Text) -> Doc + :: Node (Lexeme Text) + -> Node (Lexeme Text) + -> Node (Lexeme Text) + -> Doc ppTernaryExpr c t e = ppExpr c <+> char '?' <+> ppExpr t <+> char ':' <+> ppExpr e -ppLicenseDecl :: Show a => Lexeme Text -> [Node a (Lexeme Text)] -> Doc +ppLicenseDecl :: Lexeme Text -> [Node (Lexeme Text)] -> Doc ppLicenseDecl l cs = ppCommentStyle Regular <+> ppLexeme l <$> ppLineSep ppCopyrightDecl cs -ppCopyrightDecl :: Show a => Node a (Lexeme Text) -> Doc -ppCopyrightDecl (CopyrightDecl from (Just to) owner) = +ppCopyrightDecl :: Node (Lexeme Text) -> Doc +ppCopyrightDecl (Fix (CopyrightDecl from (Just to) owner)) = ppLexeme from <> char '-' <> ppLexeme to <+> ppCommentBody owner -ppCopyrightDecl (CopyrightDecl from Nothing owner) = +ppCopyrightDecl (Fix (CopyrightDecl from Nothing owner)) = ppLexeme from <+> ppCommentBody owner ppCopyrightDecl x = error $ groom x -ppCommentExpr :: Show a => Node a (Lexeme Text) -> Node a (Lexeme Text) -> Doc -ppCommentExpr (Comment style _ body _) e = +ppCommentExpr :: Node (Lexeme Text) -> Node (Lexeme Text) -> Doc +ppCommentExpr (Fix (Comment style _ body _)) e = ppCommentStyle style <+> ppCommentBody body <+> text "*/" <+> ppExpr e ppCommentExpr c _ = error $ groom c -ppStmt :: Show a => Node a (Lexeme Text) -> Doc +ppStmt :: Node (Lexeme Text) -> Doc ppStmt = ppDecl -ppDeclList :: Show a => [Node a (Lexeme Text)] -> Doc +ppDeclList :: [Node (Lexeme Text)] -> Doc ppDeclList = ppLineSep ppDecl -ppDecl :: Show a => Node a (Lexeme Text) -> Doc -ppDecl decl = case decl of - PreprocElif cond decls (PreprocElse []) -> +ppDecl :: Node (Lexeme Text) -> Doc +ppDecl decl = case unFix decl of + PreprocElif cond decls (Fix (PreprocElse [])) -> text "#elif" <+> ppExpr cond <$> ppDeclList decls <$> text "#endif" @@ -395,7 +393,7 @@ ppDecl decl = case decl of ppDeclList decls <$> ppDeclList [elseBranch] <$> text "#endif" - PreprocIf cond decls (PreprocElse []) -> + PreprocIf cond decls (Fix (PreprocElse [])) -> nest (-100) (text "#if") <+> ppExpr cond <$> ppDeclList decls <$> text "#endif" @@ -404,7 +402,7 @@ ppDecl decl = case decl of ppDeclList decls <$> ppDeclList [elseBranch] <$> text "#endif" - PreprocIfdef name decls (PreprocElse []) -> + PreprocIfdef name decls (Fix (PreprocElse [])) -> indent (-2) (text "#ifndef" <+> ppLexeme name <$> ppDeclList decls) <$> text "#endif" @@ -413,7 +411,7 @@ ppDecl decl = case decl of ppDeclList decls <$> ppDeclList [elseBranch] <$> text "#endif" - PreprocIfndef name decls (PreprocElse []) -> + PreprocIfndef name decls (Fix (PreprocElse [])) -> text "#ifndef" <+> ppLexeme name <$> ppDeclList decls <$> text "#endif" @@ -497,19 +495,19 @@ ppDecl decl = case decl of text "struct" <+> ppLexeme name <+> char '{' <$> ppMemberDeclList members ) <$> text "};" - Typedef (Union name members) tyname -> + Typedef (Fix (Union name members)) tyname -> nest 2 ( text "typedef union" <+> ppLexeme name <+> char '{' <$> ppMemberDeclList members ) <$> char '}' <+> ppLexeme tyname <> char ';' - Typedef (Struct name members) tyname -> + Typedef (Fix (Struct name members)) tyname -> nest 2 ( text "typedef struct" <+> ppLexeme name <+> char '{' <$> ppMemberDeclList members ) <$> char '}' <+> ppLexeme tyname <> char ';' Typedef ty name -> text "typedef" <+> ppType ty <+> ppLexeme name <> char ';' - TypedefFunction (FunctionPrototype ty name params) -> + TypedefFunction (Fix (FunctionPrototype ty name params)) -> text "typedef" <+> ppFunctionPrototype ty name params <> char ';' @@ -519,11 +517,11 @@ ppDecl decl = case decl of MemberDecl ty dspec (Just size) -> ppType ty <+> ppDeclSpec dspec <+> char ':' <+> ppLexeme size <> char ';' - FunctionDecl scope (FunctionPrototype ty name params) err -> + FunctionDecl scope (Fix (FunctionPrototype ty name params)) err -> ppScope scope <> ppFunctionPrototype ty name params <> ppWithError err - FunctionDefn scope (FunctionPrototype ty name params) (CompoundStmt body) -> + FunctionDefn scope (Fix (FunctionPrototype ty name params)) (Fix (CompoundStmt body)) -> ppScope scope <> ppFunctionPrototype ty name params <$> ppCompoundStmt body @@ -553,27 +551,27 @@ ppDecl decl = case decl of ) <$> char '}' -- Statements - Continue -> text "continue;" - Break -> text "break;" - Return Nothing -> text "return;" - Return (Just e) -> text "return" <+> ppExpr e <> char ';' - VarDecl ty declr -> ppType ty <+> ppDeclarator declr <> char ';' - IfStmt cond (CompoundStmt t) e -> ppIfStmt cond t e - ForStmt i c n (CompoundStmt body) -> ppForStmt i c n body - Default s -> text "default:" <+> ppStmt s - Label l s -> ppLexeme l <> char ':' <$> ppStmt s - Goto l -> text "goto " <> ppLexeme l <> char ';' - Case e s -> text "case " <> ppExpr e <> char ':' <+> ppStmt s - WhileStmt c (CompoundStmt body) -> ppWhileStmt c body - DoWhileStmt (CompoundStmt body) c -> ppDoWhileStmt body c - SwitchStmt c body -> ppSwitchStmt c body - CompoundStmt body -> char '{' <$> ppStmtList body <$> char '}' - VLA ty n sz -> ppVLA ty n sz - - x -> ppExpr x <> char ';' - - -ppVLA :: Show a => Node a (Lexeme Text) -> Lexeme Text -> Node a (Lexeme Text) -> Doc + Continue -> text "continue;" + Break -> text "break;" + Return Nothing -> text "return;" + Return (Just e) -> text "return" <+> ppExpr e <> char ';' + VarDecl ty declr -> ppType ty <+> ppDeclarator declr <> char ';' + IfStmt cond (Fix (CompoundStmt t)) e -> ppIfStmt cond t e + ForStmt i c n (Fix (CompoundStmt body)) -> ppForStmt i c n body + Default s -> text "default:" <+> ppStmt s + Label l s -> ppLexeme l <> char ':' <$> ppStmt s + Goto l -> text "goto " <> ppLexeme l <> char ';' + Case e s -> text "case " <> ppExpr e <> char ':' <+> ppStmt s + WhileStmt c (Fix (CompoundStmt body)) -> ppWhileStmt c body + DoWhileStmt (Fix (CompoundStmt body)) c -> ppDoWhileStmt body c + SwitchStmt c body -> ppSwitchStmt c body + CompoundStmt body -> char '{' <$> ppStmtList body <$> char '}' + VLA ty n sz -> ppVLA ty n sz + + x -> ppExpr (Fix x) <> char ';' + + +ppVLA :: Node (Lexeme Text) -> Lexeme Text -> Node (Lexeme Text) -> Doc ppVLA ty n sz = text "VLA(" <> ppType ty @@ -583,5 +581,5 @@ ppVLA ty n sz = <> ppExpr sz <> text ");" -ppTranslationUnit :: Show a => [Node a (Lexeme Text)] -> Doc +ppTranslationUnit :: [Node (Lexeme Text)] -> Doc ppTranslationUnit decls = ppDeclList decls <> linebreak diff --git a/src/Language/Cimple/Program.hs b/src/Language/Cimple/Program.hs index 3b09174..c2feb6d 100644 --- a/src/Language/Cimple/Program.hs +++ b/src/Language/Cimple/Program.hs @@ -10,7 +10,7 @@ module Language.Cimple.Program import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Text (Text) -import Language.Cimple.AST (Node (..)) +import Language.Cimple.AST (Node) import Language.Cimple.Graph (Graph) import qualified Language.Cimple.Graph as Graph import Language.Cimple.Lexer (Lexeme (..)) @@ -20,7 +20,7 @@ import Language.Cimple.TranslationUnit (TranslationUnit) data Program text = Program - { progAsts :: Map FilePath [Node () (Lexeme text)] + { progAsts :: Map FilePath [Node (Lexeme text)] , progIncludes :: Graph () FilePath } diff --git a/src/Language/Cimple/SemCheck/Includes.hs b/src/Language/Cimple/SemCheck/Includes.hs index 31e18af..03d1a7e 100644 --- a/src/Language/Cimple/SemCheck/Includes.hs +++ b/src/Language/Cimple/SemCheck/Includes.hs @@ -6,9 +6,10 @@ module Language.Cimple.SemCheck.Includes import Control.Monad.State.Lazy (State) import qualified Control.Monad.State.Lazy as State +import Data.Fix (Fix (..)) import Data.Text (Text) import qualified Data.Text as Text -import Language.Cimple.AST (Node (..)) +import Language.Cimple.AST (NodeF (..)) import Language.Cimple.Lexer (Lexeme (..)) import Language.Cimple.Tokens (LexemeClass (..)) import Language.Cimple.TranslationUnit (TranslationUnit) @@ -36,14 +37,14 @@ relativeTo dir file = go (splitPath dir) (splitPath file) go d f = joinPath (d ++ f) -normaliseIncludes' :: FilePath -> IdentityActions (State [FilePath]) () Text +normaliseIncludes' :: FilePath -> IdentityActions (State [FilePath]) Text normaliseIncludes' dir = identityActions { doNode = \_ node act -> case node of - PreprocInclude (L spos LitString include) -> do + Fix (PreprocInclude (L spos LitString include)) -> do let includePath = relativeTo dir $ tread include State.modify (includePath :) - return $ PreprocInclude (L spos LitString (tshow includePath)) + return $ Fix $ PreprocInclude (L spos LitString (tshow includePath)) _ -> act } diff --git a/src/Language/Cimple/TranslationUnit.hs b/src/Language/Cimple/TranslationUnit.hs index e1a87a2..9daf774 100644 --- a/src/Language/Cimple/TranslationUnit.hs +++ b/src/Language/Cimple/TranslationUnit.hs @@ -6,4 +6,4 @@ module Language.Cimple.TranslationUnit import Language.Cimple.AST (Node) import Language.Cimple.Lexer (Lexeme) -type TranslationUnit text = (FilePath, [Node () (Lexeme text)]) +type TranslationUnit text = (FilePath, [Node (Lexeme text)]) diff --git a/src/Language/Cimple/TraverseAst.hs b/src/Language/Cimple/TraverseAst.hs index 2e4304b..dcf0b07 100644 --- a/src/Language/Cimple/TraverseAst.hs +++ b/src/Language/Cimple/TraverseAst.hs @@ -14,56 +14,53 @@ module Language.Cimple.TraverseAst , doNodes, doNode , doLexemes, doLexeme , doText - , doAttr , astActions - , AttrActions, attrActions , TextActions, textActions , IdentityActions, identityActions ) where -import Language.Cimple.AST (Node (..)) +import Data.Fix (Fix (..)) +import Language.Cimple.AST (Node, NodeF (..)) import Language.Cimple.Lexer (Lexeme (..)) -class TraverseAst iattr oattr itext otext a where - type Mapped iattr oattr itext otext a +class TraverseAst itext otext a where + type Mapped itext otext a mapFileAst :: Applicative f - => AstActions f iattr oattr itext otext + => AstActions f itext otext -> FilePath -> a - -> f (Mapped iattr oattr itext otext a) + -> f (Mapped itext otext a) traverseAst - :: (TraverseAst iattr oattr itext otext a, Applicative f) - => AstActions f iattr oattr itext otext -> a - -> f (Mapped iattr oattr itext otext a) + :: (TraverseAst itext otext a, Applicative f) + => AstActions f itext otext -> a + -> f (Mapped itext otext a) traverseAst = flip mapFileAst "" -data AstActions f iattr oattr itext otext = AstActions - { doFiles :: [(FilePath, [Node iattr (Lexeme itext)])] -> f [(FilePath, [Node oattr (Lexeme otext)])] -> f [(FilePath, [Node oattr (Lexeme otext)])] - , doFile :: (FilePath, [Node iattr (Lexeme itext)]) -> f (FilePath, [Node oattr (Lexeme otext)]) -> f (FilePath, [Node oattr (Lexeme otext)]) - , doNodes :: FilePath -> [Node iattr (Lexeme itext)] -> f [Node oattr (Lexeme otext)] -> f [Node oattr (Lexeme otext)] - , doNode :: FilePath -> Node iattr (Lexeme itext) -> f (Node oattr (Lexeme otext)) -> f (Node oattr (Lexeme otext)) - , doLexemes :: FilePath -> [Lexeme itext] -> f [Lexeme otext] -> f [Lexeme otext] - , doLexeme :: FilePath -> Lexeme itext -> f (Lexeme otext) -> f (Lexeme otext) - , doText :: FilePath -> itext -> f otext - , doAttr :: FilePath -> iattr -> f oattr +data AstActions f itext otext = AstActions + { doFiles :: [(FilePath, [Node (Lexeme itext)])] -> f [(FilePath, [Node (Lexeme otext)])] -> f [(FilePath, [Node (Lexeme otext)])] + , doFile :: (FilePath, [Node (Lexeme itext)]) -> f (FilePath, [Node (Lexeme otext)]) -> f (FilePath, [Node (Lexeme otext)]) + , doNodes :: FilePath -> [Node (Lexeme itext)] -> f [Node (Lexeme otext)] -> f [Node (Lexeme otext)] + , doNode :: FilePath -> Node (Lexeme itext) -> f (Node (Lexeme otext)) -> f (Node (Lexeme otext)) + , doLexemes :: FilePath -> [Lexeme itext] -> f [Lexeme otext] -> f [Lexeme otext] + , doLexeme :: FilePath -> Lexeme itext -> f (Lexeme otext) -> f (Lexeme otext) + , doText :: FilePath -> itext -> f otext } -instance TraverseAst iattr oattr itext otext a - => TraverseAst iattr oattr itext otext (Maybe a) where - type Mapped iattr oattr itext otext (Maybe a) - = Maybe (Mapped iattr oattr itext otext a) +instance TraverseAst itext otext a + => TraverseAst itext otext (Maybe a) where + type Mapped itext otext (Maybe a) + = Maybe (Mapped itext otext a) mapFileAst _ _ Nothing = pure Nothing mapFileAst actions currentFile (Just x) = Just <$> mapFileAst actions currentFile x astActions :: Applicative f - => (iattr -> f oattr) - -> (itext -> f otext) - -> AstActions f iattr oattr itext otext -astActions fa ft = AstActions + => (itext -> f otext) + -> AstActions f itext otext +astActions ft = AstActions { doFiles = const id , doFile = const id , doNodes = const $ const id @@ -71,247 +68,240 @@ astActions fa ft = AstActions , doLexeme = const $ const id , doLexemes = const $ const id , doText = const ft - , doAttr = const fa } -type AttrActions f iattr oattr text = AstActions f iattr oattr text text -attrActions :: Applicative f => (iattr -> f oattr) -> AttrActions f iattr oattr text -attrActions = flip astActions pure +type TextActions f itext otext = AstActions f itext otext +textActions :: Applicative f => (itext -> f otext) -> TextActions f itext otext +textActions = astActions -type TextActions f attr itext otext = AstActions f attr attr itext otext -textActions :: Applicative f => (itext -> f otext) -> TextActions f attr itext otext -textActions = astActions pure +type IdentityActions f text = AstActions f text text +identityActions :: Applicative f => AstActions f text text +identityActions = astActions pure -type IdentityActions f attr text = AstActions f attr attr text text -identityActions :: Applicative f => AstActions f attr attr text text -identityActions = astActions pure pure - -instance TraverseAst iattr oattr itext otext (Lexeme itext) where - type Mapped iattr oattr itext otext (Lexeme itext) - = Lexeme otext +instance TraverseAst itext otext (Lexeme itext) where + type Mapped itext otext (Lexeme itext) + = Lexeme otext mapFileAst :: forall f . Applicative f - => AstActions f iattr oattr itext otext -> FilePath -> Lexeme itext -> f (Lexeme otext) + => AstActions f itext otext -> FilePath -> Lexeme itext -> f (Lexeme otext) mapFileAst AstActions{..} currentFile = doLexeme currentFile <*> \(L p c s) -> L p c <$> doText currentFile s -instance TraverseAst iattr oattr itext otext [Lexeme itext] where - type Mapped iattr oattr itext otext [Lexeme itext] - = [Lexeme otext] +instance TraverseAst itext otext [Lexeme itext] where + type Mapped itext otext [Lexeme itext] + = [Lexeme otext] mapFileAst actions@AstActions{..} currentFile = doLexemes currentFile <*> traverse (mapFileAst actions currentFile) -instance TraverseAst iattr oattr itext otext (Node iattr (Lexeme itext)) where - type Mapped iattr oattr itext otext (Node iattr (Lexeme itext)) - = Node oattr (Lexeme otext) +instance TraverseAst itext otext (Node (Lexeme itext)) where + type Mapped itext otext (Node (Lexeme itext)) + = Node (Lexeme otext) mapFileAst :: forall f . Applicative f - => AstActions f iattr oattr itext otext + => AstActions f itext otext -> FilePath - -> Node iattr (Lexeme itext) - -> f (Node oattr (Lexeme otext)) - mapFileAst actions@AstActions{..} currentFile = doNode currentFile <*> \case - Attr attr node -> - Attr <$> doAttr currentFile attr <*> recurse node + -> Node (Lexeme itext) + -> f (Node (Lexeme otext)) + mapFileAst actions@AstActions{..} currentFile = doNode currentFile <*> \node -> case unFix node of PreprocInclude path -> - PreprocInclude <$> recurse path + Fix <$> (PreprocInclude <$> recurse path) PreprocDefine name -> - PreprocDefine <$> recurse name + Fix <$> (PreprocDefine <$> recurse name) PreprocDefineConst name value -> - PreprocDefineConst <$> recurse name <*> recurse value + Fix <$> (PreprocDefineConst <$> recurse name <*> recurse value) PreprocDefineMacro name params body -> - PreprocDefineMacro <$> recurse name <*> recurse params <*> recurse body + Fix <$> (PreprocDefineMacro <$> recurse name <*> recurse params <*> recurse body) PreprocIf cond thenDecls elseBranch -> - PreprocIf <$> recurse cond <*> recurse thenDecls <*> recurse elseBranch + Fix <$> (PreprocIf <$> recurse cond <*> recurse thenDecls <*> recurse elseBranch) PreprocIfdef name thenDecls elseBranch -> - PreprocIfdef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch + Fix <$> (PreprocIfdef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch) PreprocIfndef name thenDecls elseBranch -> - PreprocIfndef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch + Fix <$> (PreprocIfndef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch) PreprocElse decls -> - PreprocElse <$> recurse decls + Fix <$> (PreprocElse <$> recurse decls) PreprocElif cond decls elseBranch -> - PreprocElif <$> recurse cond <*> recurse decls <*> recurse elseBranch + Fix <$> (PreprocElif <$> recurse cond <*> recurse decls <*> recurse elseBranch) PreprocUndef name -> - PreprocUndef <$> recurse name + Fix <$> (PreprocUndef <$> recurse name) PreprocDefined name -> - PreprocDefined <$> recurse name + Fix <$> (PreprocDefined <$> recurse name) PreprocScopedDefine define stmts undef -> - PreprocScopedDefine <$> recurse define <*> recurse stmts <*> recurse undef + Fix <$> (PreprocScopedDefine <$> recurse define <*> recurse stmts <*> recurse undef) MacroBodyStmt stmts -> - MacroBodyStmt <$> recurse stmts + Fix <$> (MacroBodyStmt <$> recurse stmts) MacroBodyFunCall expr -> - MacroBodyFunCall <$> recurse expr + Fix <$> (MacroBodyFunCall <$> recurse expr) MacroParam name -> - MacroParam <$> recurse name + Fix <$> (MacroParam <$> recurse name) StaticAssert cond msg -> - StaticAssert <$> recurse cond <*> recurse msg + Fix <$> (StaticAssert <$> recurse cond <*> recurse msg) LicenseDecl license copyrights -> - LicenseDecl <$> recurse license <*> recurse copyrights + Fix <$> (LicenseDecl <$> recurse license <*> recurse copyrights) CopyrightDecl from to owner -> - CopyrightDecl <$> recurse from <*> recurse to <*> recurse owner + Fix <$> (CopyrightDecl <$> recurse from <*> recurse to <*> recurse owner) Comment doc start contents end -> - Comment doc <$> recurse start <*> recurse contents <*> recurse end + Fix <$> (Comment doc <$> recurse start <*> recurse contents <*> recurse end) CommentBlock comment -> - CommentBlock <$> recurse comment - Commented comment node -> - Commented <$> recurse comment <*> recurse node + Fix <$> (CommentBlock <$> recurse comment) + Commented comment subject -> + Fix <$> (Commented <$> recurse comment <*> recurse subject) ExternC decls -> - ExternC <$> recurse decls + Fix <$> (ExternC <$> recurse decls) CompoundStmt stmts -> - CompoundStmt <$> recurse stmts + Fix <$> (CompoundStmt <$> recurse stmts) Break -> - pure Break + Fix <$> (pure Break) Goto label -> - Goto <$> recurse label + Fix <$> (Goto <$> recurse label) Continue -> - pure Continue + Fix <$> (pure Continue) Return value -> - Return <$> recurse value + Fix <$> (Return <$> recurse value) SwitchStmt value cases -> - SwitchStmt <$> recurse value <*> recurse cases + Fix <$> (SwitchStmt <$> recurse value <*> recurse cases) IfStmt cond thenStmts elseStmt -> - IfStmt <$> recurse cond <*> recurse thenStmts <*> recurse elseStmt + Fix <$> (IfStmt <$> recurse cond <*> recurse thenStmts <*> recurse elseStmt) ForStmt initStmt cond next stmts -> - ForStmt <$> recurse initStmt <*> recurse cond <*> recurse next <*> recurse stmts + Fix <$> (ForStmt <$> recurse initStmt <*> recurse cond <*> recurse next <*> recurse stmts) WhileStmt cond stmts -> - WhileStmt <$> recurse cond <*> recurse stmts + Fix <$> (WhileStmt <$> recurse cond <*> recurse stmts) DoWhileStmt stmts cond -> - DoWhileStmt <$> recurse stmts <*> recurse cond + Fix <$> (DoWhileStmt <$> recurse stmts <*> recurse cond) Case value stmt -> - Case <$> recurse value <*> recurse stmt + Fix <$> (Case <$> recurse value <*> recurse stmt) Default stmt -> - Default <$> recurse stmt + Fix <$> (Default <$> recurse stmt) Label label stmt -> - Label <$> recurse label <*> recurse stmt + Fix <$> (Label <$> recurse label <*> recurse stmt) VLA ty name size -> - VLA <$> recurse ty <*> recurse name <*> recurse size + Fix <$> (VLA <$> recurse ty <*> recurse name <*> recurse size) VarDecl ty decl -> - VarDecl <$> recurse ty <*> recurse decl + Fix <$> (VarDecl <$> recurse ty <*> recurse decl) Declarator spec value -> - Declarator <$> recurse spec <*> recurse value + Fix <$> (Declarator <$> recurse spec <*> recurse value) DeclSpecVar name -> - DeclSpecVar <$> recurse name + Fix <$> (DeclSpecVar <$> recurse name) DeclSpecArray spec size -> - DeclSpecArray <$> recurse spec <*> recurse size + Fix <$> (DeclSpecArray <$> recurse spec <*> recurse size) InitialiserList values -> - InitialiserList <$> recurse values + Fix <$> (InitialiserList <$> recurse values) UnaryExpr op expr -> - UnaryExpr op <$> recurse expr + Fix <$> (UnaryExpr op <$> recurse expr) BinaryExpr lhs op rhs -> - BinaryExpr <$> recurse lhs <*> pure op <*> recurse rhs + Fix <$> (BinaryExpr <$> recurse lhs <*> pure op <*> recurse rhs) TernaryExpr cond thenExpr elseExpr -> - TernaryExpr <$> recurse cond <*> recurse thenExpr <*> recurse elseExpr + Fix <$> (TernaryExpr <$> recurse cond <*> recurse thenExpr <*> recurse elseExpr) AssignExpr lhs op rhs -> - AssignExpr <$> recurse lhs <*> pure op <*> recurse rhs + Fix <$> (AssignExpr <$> recurse lhs <*> pure op <*> recurse rhs) ParenExpr expr -> - ParenExpr <$> recurse expr + Fix <$> (ParenExpr <$> recurse expr) CastExpr ty expr -> - CastExpr <$> recurse ty <*> recurse expr + Fix <$> (CastExpr <$> recurse ty <*> recurse expr) CompoundExpr ty expr -> - CompoundExpr <$> recurse ty <*> recurse expr + Fix <$> (CompoundExpr <$> recurse ty <*> recurse expr) SizeofExpr expr -> - SizeofExpr <$> recurse expr + Fix <$> (SizeofExpr <$> recurse expr) SizeofType ty -> - SizeofType <$> recurse ty + Fix <$> (SizeofType <$> recurse ty) LiteralExpr ty value -> - LiteralExpr ty <$> recurse value + Fix <$> (LiteralExpr ty <$> recurse value) VarExpr name -> - VarExpr <$> recurse name + Fix <$> (VarExpr <$> recurse name) MemberAccess name field -> - MemberAccess <$> recurse name <*> recurse field + Fix <$> (MemberAccess <$> recurse name <*> recurse field) PointerAccess name field -> - PointerAccess <$> recurse name <*> recurse field + Fix <$> (PointerAccess <$> recurse name <*> recurse field) ArrayAccess arr idx -> - ArrayAccess <$> recurse arr <*> recurse idx + Fix <$> (ArrayAccess <$> recurse arr <*> recurse idx) FunctionCall callee args -> - FunctionCall <$> recurse callee <*> recurse args + Fix <$> (FunctionCall <$> recurse callee <*> recurse args) CommentExpr comment expr -> - CommentExpr <$> recurse comment <*> recurse expr + Fix <$> (CommentExpr <$> recurse comment <*> recurse expr) EnumClass name members -> - EnumClass <$> recurse name <*> recurse members + Fix <$> (EnumClass <$> recurse name <*> recurse members) EnumConsts name members -> - EnumConsts <$> recurse name <*> recurse members + Fix <$> (EnumConsts <$> recurse name <*> recurse members) EnumDecl name members tyName -> - EnumDecl <$> recurse name <*> recurse members <*> recurse tyName + Fix <$> (EnumDecl <$> recurse name <*> recurse members <*> recurse tyName) Enumerator name value -> - Enumerator <$> recurse name <*> recurse value + Fix <$> (Enumerator <$> recurse name <*> recurse value) Typedef ty name -> - Typedef <$> recurse ty <*> recurse name + Fix <$> (Typedef <$> recurse ty <*> recurse name) TypedefFunction ty -> - TypedefFunction <$> recurse ty + Fix <$> (TypedefFunction <$> recurse ty) Namespace scope name members -> - Namespace scope <$> recurse name <*> recurse members + Fix <$> (Namespace scope <$> recurse name <*> recurse members) Class scope name tyvars members -> - Class scope <$> recurse name <*> recurse tyvars <*> recurse members + Fix <$> (Class scope <$> recurse name <*> recurse tyvars <*> recurse members) ClassForward name tyvars -> - ClassForward <$> recurse name <*> recurse tyvars + Fix <$> (ClassForward <$> recurse name <*> recurse tyvars) Struct name members -> - Struct <$> recurse name <*> recurse members + Fix <$> (Struct <$> recurse name <*> recurse members) Union name members -> - Union <$> recurse name <*> recurse members + Fix <$> (Union <$> recurse name <*> recurse members) MemberDecl ty decl width -> - MemberDecl <$> recurse ty <*> recurse decl <*> recurse width + Fix <$> (MemberDecl <$> recurse ty <*> recurse decl <*> recurse width) TyConst ty -> - TyConst <$> recurse ty + Fix <$> (TyConst <$> recurse ty) TyPointer ty -> - TyPointer <$> recurse ty + Fix <$> (TyPointer <$> recurse ty) TyStruct name -> - TyStruct <$> recurse name + Fix <$> (TyStruct <$> recurse name) TyFunc name -> - TyFunc <$> recurse name + Fix <$> (TyFunc <$> recurse name) TyVar name -> - TyVar <$> recurse name + Fix <$> (TyVar <$> recurse name) TyStd name -> - TyStd <$> recurse name + Fix <$> (TyStd <$> recurse name) TyUserDefined name -> - TyUserDefined <$> recurse name + Fix <$> (TyUserDefined <$> recurse name) FunctionDecl scope proto errors -> - FunctionDecl scope <$> recurse proto <*> recurse errors + Fix <$> (FunctionDecl scope <$> recurse proto <*> recurse errors) FunctionDefn scope proto body -> - FunctionDefn scope <$> recurse proto <*> recurse body + Fix <$> (FunctionDefn scope <$> recurse proto <*> recurse body) FunctionPrototype ty name params -> - FunctionPrototype <$> recurse ty <*> recurse name <*> recurse params + Fix <$> (FunctionPrototype <$> recurse ty <*> recurse name <*> recurse params) FunctionParam ty decl -> - FunctionParam <$> recurse ty <*> recurse decl + Fix <$> (FunctionParam <$> recurse ty <*> recurse decl) Event name params -> - Event <$> recurse name <*> recurse params + Fix <$> (Event <$> recurse name <*> recurse params) EventParams params -> - EventParams <$> recurse params + Fix <$> (EventParams <$> recurse params) Property ty decl accessors -> - Property <$> recurse ty <*> recurse decl <*> recurse accessors + Fix <$> (Property <$> recurse ty <*> recurse decl <*> recurse accessors) Accessor name params errors -> - Accessor <$> recurse name <*> recurse params <*> recurse errors + Fix <$> (Accessor <$> recurse name <*> recurse params <*> recurse errors) ErrorDecl name errors -> - ErrorDecl <$> recurse name <*> recurse errors + Fix <$> (ErrorDecl <$> recurse name <*> recurse errors) ErrorList errors -> - ErrorList <$> recurse errors + Fix <$> (ErrorList <$> recurse errors) ErrorFor name -> - ErrorFor <$> recurse name + Fix <$> (ErrorFor <$> recurse name) Ellipsis -> - pure Ellipsis + Fix <$> (pure Ellipsis) ConstDecl ty name -> - ConstDecl <$> recurse ty <*> recurse name + Fix <$> (ConstDecl <$> recurse ty <*> recurse name) ConstDefn scope ty name value -> - ConstDefn scope <$> recurse ty <*> recurse name <*> recurse value + Fix <$> (ConstDefn scope <$> recurse ty <*> recurse name <*> recurse value) where - recurse :: TraverseAst iattr oattr itext otext a => a -> f (Mapped iattr oattr itext otext a) + recurse :: TraverseAst itext otext a => a -> f (Mapped itext otext a) recurse = mapFileAst actions currentFile -instance TraverseAst iattr oattr itext otext [Node iattr (Lexeme itext)] where - type Mapped iattr oattr itext otext [Node iattr (Lexeme itext)] - = [Node oattr (Lexeme otext)] +instance TraverseAst itext otext [Node (Lexeme itext)] where + type Mapped itext otext [Node (Lexeme itext)] + = [Node (Lexeme otext)] mapFileAst actions@AstActions{..} currentFile = doNodes currentFile <*> traverse (mapFileAst actions currentFile) -instance TraverseAst iattr oattr itext otext (FilePath, [Node iattr (Lexeme itext)]) where - type Mapped iattr oattr itext otext (FilePath, [Node iattr (Lexeme itext)]) - = (FilePath, [Node oattr (Lexeme otext)]) +instance TraverseAst itext otext (FilePath, [Node (Lexeme itext)]) where + type Mapped itext otext (FilePath, [Node (Lexeme itext)]) + = (FilePath, [Node (Lexeme otext)]) mapFileAst actions@AstActions{..} _ tu@(currentFile, _) = doFile <*> traverse (mapFileAst actions currentFile) $ tu -instance TraverseAst iattr oattr itext otext [(FilePath, [Node iattr (Lexeme itext)])] where - type Mapped iattr oattr itext otext [(FilePath, [Node iattr (Lexeme itext)])] - = [(FilePath, [Node oattr (Lexeme otext)])] +instance TraverseAst itext otext [(FilePath, [Node (Lexeme itext)])] where + type Mapped itext otext [(FilePath, [Node (Lexeme itext)])] + = [(FilePath, [Node (Lexeme otext)])] mapFileAst actions@AstActions{..} currentFile = doFiles <*> traverse (mapFileAst actions currentFile) diff --git a/src/Language/Cimple/TreeParser.y b/src/Language/Cimple/TreeParser.y index 9f396b5..4d7db1d 100644 --- a/src/Language/Cimple/TreeParser.y +++ b/src/Language/Cimple/TreeParser.y @@ -6,8 +6,9 @@ module Language.Cimple.TreeParser , toEither ) where +import Data.Fix (Fix (..)) import Data.Text (Text) -import Language.Cimple.AST (CommentStyle (..), Node (..)) +import Language.Cimple.AST (CommentStyle (..), Node, NodeF (..)) import Language.Cimple.Lexer (Lexeme) } @@ -20,115 +21,115 @@ import Language.Cimple.Lexer (Lexeme) %monad {TreeParser} %tokentype {TextNode} %token - ifndefDefine { PreprocIfndef _ body (PreprocElse []) | isDefine body } - ifdefDefine { PreprocIfdef _ body (PreprocElse []) | isDefine body } - ifDefine { PreprocIf _ body (PreprocElse []) | isDefine body } + ifndefDefine { Fix (PreprocIfndef _ body (Fix (PreprocElse []))) | isDefine body } + ifdefDefine { Fix (PreprocIfdef _ body (Fix (PreprocElse []))) | isDefine body } + ifDefine { Fix (PreprocIf _ body (Fix (PreprocElse []))) | isDefine body } - ifndefInclude { PreprocIfndef{} | isPreproc tk && hasInclude tk } - ifdefInclude { PreprocIfdef{} | isPreproc tk && hasInclude tk } - ifInclude { PreprocIf{} | isPreproc tk && hasInclude tk } + ifndefInclude { Fix (PreprocIfndef{}) | isPreproc tk && hasInclude tk } + ifdefInclude { Fix (PreprocIfdef{}) | isPreproc tk && hasInclude tk } + ifInclude { Fix (PreprocIf{}) | isPreproc tk && hasInclude tk } - docComment { Comment Doxygen _ _ _ } + docComment { Fix (Comment Doxygen _ _ _) } -- Preprocessor - preprocInclude { PreprocInclude{} } - preprocDefine { PreprocDefine{} } - preprocDefineConst { PreprocDefineConst{} } - preprocDefineMacro { PreprocDefineMacro{} } - preprocIf { PreprocIf{} } - preprocIfdef { PreprocIfdef{} } - preprocIfndef { PreprocIfndef{} } - preprocElse { PreprocElse{} } - preprocElif { PreprocElif{} } - preprocUndef { PreprocUndef{} } - preprocDefined { PreprocDefined{} } - preprocScopedDefine { PreprocScopedDefine{} } - macroBodyStmt { MacroBodyStmt{} } - macroBodyFunCall { MacroBodyFunCall{} } - macroParam { MacroParam{} } - staticAssert { StaticAssert{} } + preprocInclude { Fix (PreprocInclude{}) } + preprocDefine { Fix (PreprocDefine{}) } + preprocDefineConst { Fix (PreprocDefineConst{}) } + preprocDefineMacro { Fix (PreprocDefineMacro{}) } + preprocIf { Fix (PreprocIf{}) } + preprocIfdef { Fix (PreprocIfdef{}) } + preprocIfndef { Fix (PreprocIfndef{}) } + preprocElse { Fix (PreprocElse{}) } + preprocElif { Fix (PreprocElif{}) } + preprocUndef { Fix (PreprocUndef{}) } + preprocDefined { Fix (PreprocDefined{}) } + preprocScopedDefine { Fix (PreprocScopedDefine{}) } + macroBodyStmt { Fix (MacroBodyStmt{}) } + macroBodyFunCall { Fix (MacroBodyFunCall{}) } + macroParam { Fix (MacroParam{}) } + staticAssert { Fix (StaticAssert{}) } -- Comments - licenseDecl { LicenseDecl{} } - copyrightDecl { CopyrightDecl{} } - comment { Comment{} } - commentBlock { CommentBlock{} } - commented { Commented{} } + licenseDecl { Fix (LicenseDecl{}) } + copyrightDecl { Fix (CopyrightDecl{}) } + comment { Fix (Comment{}) } + commentBlock { Fix (CommentBlock{}) } + commented { Fix (Commented{}) } -- Namespace-like blocks - externC { ExternC{} } - class { Class{} } - namespace { Namespace{} } + externC { Fix (ExternC{}) } + class { Fix (Class{}) } + namespace { Fix (Namespace{}) } -- Statements - compoundStmt { CompoundStmt{} } - break { Break } - goto { Goto{} } - continue { Continue } - return { Return{} } - switchStmt { SwitchStmt{} } - ifStmt { IfStmt{} } - forStmt { ForStmt{} } - whileStmt { WhileStmt{} } - doWhileStmt { DoWhileStmt{} } - case { Case{} } - default { Default{} } - label { Label{} } + compoundStmt { Fix (CompoundStmt{}) } + break { Fix (Break) } + goto { Fix (Goto{}) } + continue { Fix (Continue) } + return { Fix (Return{}) } + switchStmt { Fix (SwitchStmt{}) } + ifStmt { Fix (IfStmt{}) } + forStmt { Fix (ForStmt{}) } + whileStmt { Fix (WhileStmt{}) } + doWhileStmt { Fix (DoWhileStmt{}) } + case { Fix (Case{}) } + default { Fix (Default{}) } + label { Fix (Label{}) } -- Variable declarations - vLA { VLA{} } - varDecl { VarDecl{} } - declarator { Declarator{} } - declSpecVar { DeclSpecVar{} } - declSpecArray { DeclSpecArray{} } + vLA { Fix (VLA{}) } + varDecl { Fix (VarDecl{}) } + declarator { Fix (Declarator{}) } + declSpecVar { Fix (DeclSpecVar{}) } + declSpecArray { Fix (DeclSpecArray{}) } -- Expressions - initialiserList { InitialiserList{} } - unaryExpr { UnaryExpr{} } - binaryExpr { BinaryExpr{} } - ternaryExpr { TernaryExpr{} } - assignExpr { AssignExpr{} } - parenExpr { ParenExpr{} } - castExpr { CastExpr{} } - compoundExpr { CompoundExpr{} } - sizeofExpr { SizeofExpr{} } - sizeofType { SizeofType{} } - literalExpr { LiteralExpr{} } - varExpr { VarExpr{} } - memberAccess { MemberAccess{} } - pointerAccess { PointerAccess{} } - arrayAccess { ArrayAccess{} } - functionCall { FunctionCall{} } - commentExpr { CommentExpr{} } + initialiserList { Fix (InitialiserList{}) } + unaryExpr { Fix (UnaryExpr{}) } + binaryExpr { Fix (BinaryExpr{}) } + ternaryExpr { Fix (TernaryExpr{}) } + assignExpr { Fix (AssignExpr{}) } + parenExpr { Fix (ParenExpr{}) } + castExpr { Fix (CastExpr{}) } + compoundExpr { Fix (CompoundExpr{}) } + sizeofExpr { Fix (SizeofExpr{}) } + sizeofType { Fix (SizeofType{}) } + literalExpr { Fix (LiteralExpr{}) } + varExpr { Fix (VarExpr{}) } + memberAccess { Fix (MemberAccess{}) } + pointerAccess { Fix (PointerAccess{}) } + arrayAccess { Fix (ArrayAccess{}) } + functionCall { Fix (FunctionCall{}) } + commentExpr { Fix (CommentExpr{}) } -- Type definitions - enumClass { EnumClass{} } - enumConsts { EnumConsts{} } - enumDecl { EnumDecl{} } - enumerator { Enumerator{} } - classForward { ClassForward{} } - typedef { Typedef{} } - typedefFunction { TypedefFunction{} } - struct { Struct{} } - union { Union{} } - memberDecl { MemberDecl{} } - tyConst { TyConst{} } - tyPointer { TyPointer{} } - tyStruct { TyStruct{} } - tyFunc { TyFunc{} } - tyStd { TyStd{} } - tyVar { TyVar{} } - tyUserDefined { TyUserDefined{} } + enumClass { Fix (EnumClass{}) } + enumConsts { Fix (EnumConsts{}) } + enumDecl { Fix (EnumDecl{}) } + enumerator { Fix (Enumerator{}) } + classForward { Fix (ClassForward{}) } + typedef { Fix (Typedef{}) } + typedefFunction { Fix (TypedefFunction{}) } + struct { Fix (Struct{}) } + union { Fix (Union{}) } + memberDecl { Fix (MemberDecl{}) } + tyConst { Fix (TyConst{}) } + tyPointer { Fix (TyPointer{}) } + tyStruct { Fix (TyStruct{}) } + tyFunc { Fix (TyFunc{}) } + tyStd { Fix (TyStd{}) } + tyVar { Fix (TyVar{}) } + tyUserDefined { Fix (TyUserDefined{}) } -- Functions - functionDecl { FunctionDecl{} } - functionDefn { FunctionDefn{} } - functionPrototype { FunctionPrototype{} } - functionParam { FunctionParam{} } - event { Event{} } - eventParams { EventParams{} } - property { Property{} } - accessor { Accessor{} } - errorDecl { ErrorDecl{} } - errorList { ErrorList{} } - errorFor { ErrorFor{} } - ellipsis { Ellipsis } + functionDecl { Fix (FunctionDecl{}) } + functionDefn { Fix (FunctionDefn{}) } + functionPrototype { Fix (FunctionPrototype{}) } + functionParam { Fix (FunctionParam{}) } + event { Fix (Event{}) } + eventParams { Fix (EventParams{}) } + property { Fix (Property{}) } + accessor { Fix (Accessor{}) } + errorDecl { Fix (ErrorDecl{}) } + errorList { Fix (ErrorList{}) } + errorFor { Fix (ErrorFor{}) } + ellipsis { Fix (Ellipsis) } -- Constants - constDecl { ConstDecl{} } - constDefn { ConstDefn{} } + constDecl { Fix (ConstDecl{}) } + constDefn { Fix (ConstDefn{}) } %% @@ -188,7 +189,7 @@ Decl :: { TextNode } Decl : comment { $1 } | CommentableDecl { $1 } -| docComment CommentableDecl { Commented $1 $2 } +| docComment CommentableDecl { Fix $ Commented $1 $2 } CommentableDecl :: { TextNode } CommentableDecl @@ -213,7 +214,7 @@ CommentableDecl { type TextLexeme = Lexeme Text -type TextNode = Node () TextLexeme +type TextNode = Node TextLexeme newtype TreeParser a = TreeParser { toEither :: Either String a } deriving (Functor, Applicative, Monad) @@ -223,41 +224,41 @@ instance MonadFail TreeParser where isDefine :: [TextNode] -> Bool -isDefine (PreprocUndef{}:d) = isDefine d -isDefine [PreprocDefine{}] = True -isDefine [PreprocDefineConst{}] = True -isDefine _ = False +isDefine (Fix PreprocUndef{}:d) = isDefine d +isDefine [Fix PreprocDefine{}] = True +isDefine [Fix PreprocDefineConst{}] = True +isDefine _ = False isPreproc :: TextNode -> Bool -isPreproc PreprocInclude{} = True -isPreproc PreprocUndef{} = True -isPreproc PreprocDefine{} = True -isPreproc PreprocDefineConst{} = True -isPreproc (PreprocIf _ td ed) = all isPreproc td && isPreproc ed -isPreproc (PreprocIfdef _ td ed) = all isPreproc td && isPreproc ed -isPreproc (PreprocIfndef _ td ed) = all isPreproc td && isPreproc ed -isPreproc (PreprocElse ed) = all isPreproc ed -isPreproc _ = False +isPreproc (Fix PreprocInclude{}) = True +isPreproc (Fix PreprocUndef{}) = True +isPreproc (Fix PreprocDefine{}) = True +isPreproc (Fix PreprocDefineConst{}) = True +isPreproc (Fix (PreprocIf _ td ed)) = all isPreproc td && isPreproc ed +isPreproc (Fix (PreprocIfdef _ td ed)) = all isPreproc td && isPreproc ed +isPreproc (Fix (PreprocIfndef _ td ed)) = all isPreproc td && isPreproc ed +isPreproc (Fix (PreprocElse ed)) = all isPreproc ed +isPreproc _ = False hasInclude :: TextNode -> Bool -hasInclude PreprocInclude{} = True -hasInclude (PreprocIf _ td ed) = any hasInclude td || hasInclude ed -hasInclude (PreprocIfdef _ td ed) = any hasInclude td || hasInclude ed -hasInclude (PreprocIfndef _ td ed) = any hasInclude td || hasInclude ed -hasInclude (PreprocElse ed) = any hasInclude ed -hasInclude _ = False +hasInclude (Fix PreprocInclude{}) = True +hasInclude (Fix (PreprocIf _ td ed)) = any hasInclude td || hasInclude ed +hasInclude (Fix (PreprocIfdef _ td ed)) = any hasInclude td || hasInclude ed +hasInclude (Fix (PreprocIfndef _ td ed)) = any hasInclude td || hasInclude ed +hasInclude (Fix (PreprocElse ed)) = any hasInclude ed +hasInclude _ = False recurse :: ([TextNode] -> TreeParser [TextNode]) -> TextNode -> TreeParser TextNode -recurse f (ExternC ds) = ExternC <$> f ds -recurse f (PreprocIf c t e) = PreprocIf c <$> f t <*> recurse f e -recurse f (PreprocIfdef c t e) = PreprocIfdef c <$> f t <*> recurse f e -recurse f (PreprocIfndef c t e) = PreprocIfndef c <$> f t <*> recurse f e -recurse f (PreprocIfndef c t e) = PreprocIfndef c <$> f t <*> recurse f e -recurse f (PreprocElif c t e) = PreprocElif c <$> f t <*> recurse f e -recurse f (PreprocElse []) = return $ PreprocElse [] -recurse f (PreprocElse e) = PreprocElse <$> f e -recurse _ ns = fail $ show ns +recurse f (Fix (ExternC ds)) = Fix <$> ExternC <$> f ds +--recurse f (Fix (PreprocIf c t e)) = Fix <$> PreprocIf c <$> f t <*> recurse f e +--recurse f (Fix (PreprocIfdef c t e)) = Fix <$> PreprocIfdef c <$> f t <*> recurse f e +--recurse f (Fix (PreprocIfndef c t e)) = Fix <$> PreprocIfndef c <$> f t <*> recurse f e +--recurse f (Fix (PreprocIfndef c t e)) = Fix <$> PreprocIfndef c <$> f t <*> recurse f e +--recurse f (Fix (PreprocElif c t e)) = Fix <$> PreprocElif c <$> f t <*> recurse f e +--recurse f (Fix (PreprocElse [])) = return $ Fix $ PreprocElse [] +--recurse f (Fix (PreprocElse e)) = Fix <$> PreprocElse <$> f e +recurse _ ns = fail $ show ns parseError :: ([TextNode], [String]) -> TreeParser a diff --git a/test/Language/CimpleSpec.hs b/test/Language/CimpleSpec.hs index efb8fae..a7e8bfe 100644 --- a/test/Language/CimpleSpec.hs +++ b/test/Language/CimpleSpec.hs @@ -1,105 +1,94 @@ {-# LANGUAGE OverloadedStrings #-} module Language.CimpleSpec where -import Data.Text (Text) -import qualified Data.Text as Text +import Data.Fix (Fix (..)) import Test.Hspec (Spec, describe, it, shouldBe) import Language.Cimple (AlexPosn (..), CommentStyle (..), Lexeme (..), LexemeClass (..), - LiteralType (..), Node (..), Scope (..), - TextActions, textActions, traverseAst) + LiteralType (..), NodeF (..), Scope (..)) import Language.Cimple.IO (parseText) spec :: Spec spec = do - describe "TraverseAst" $ do - it "should map the same way as mapM" $ do - let Right ast = parseText "int a(void) { return 3; }" - let actions :: TextActions Maybe () Text String - actions = textActions (Just . Text.unpack) - mapM (mapM (mapM (Just . Text.unpack))) ast - `shouldBe` - traverseAst actions ast - describe "C parsing" $ do it "should parse a simple function" $ do let ast = parseText "int a(void) { return 3; }" ast `shouldBe` Right - [ FunctionDefn + [ Fix (FunctionDefn Global - (FunctionPrototype - (TyStd (L (AlexPn 0 1 1) IdStdType "int")) + (Fix (FunctionPrototype + (Fix (TyStd (L (AlexPn 0 1 1) IdStdType "int"))) (L (AlexPn 4 1 5) IdVar "a") - [TyStd (L (AlexPn 6 1 7) KwVoid "void")] - ) - (CompoundStmt [ Return + [Fix (TyStd (L (AlexPn 6 1 7) KwVoid "void"))] + )) + (Fix (CompoundStmt [ Fix (Return (Just - (LiteralExpr + (Fix (LiteralExpr Int (L (AlexPn 21 1 22) LitInteger "3") - ) - ) - ]) + )) + )) + ]))) ] it "should parse a type declaration" $ do let ast = parseText "typedef struct Foo { int x; } Foo;" ast `shouldBe` Right - [ Typedef - (Struct + [ Fix (Typedef + (Fix (Struct (L (AlexPn 15 1 16) IdSueType "Foo") - [ MemberDecl - (TyStd (L (AlexPn 21 1 22) IdStdType "int")) - (DeclSpecVar (L (AlexPn 25 1 26) IdVar "x")) - Nothing + [ Fix (MemberDecl + (Fix (TyStd (L (AlexPn 21 1 22) IdStdType "int"))) + (Fix (DeclSpecVar (L (AlexPn 25 1 26) IdVar "x"))) + Nothing) ] - ) - (L (AlexPn 30 1 31) IdSueType "Foo") + )) + (L (AlexPn 30 1 31) IdSueType "Foo")) ] it "should parse a struct with bit fields" $ do let ast = parseText "typedef struct Foo { int x : 123; } Foo;" ast `shouldBe` Right - [ Typedef - (Struct + [ Fix (Typedef + (Fix (Struct (L (AlexPn 15 1 16) IdSueType "Foo") - [ MemberDecl - (TyStd (L (AlexPn 21 1 22) IdStdType "int")) - (DeclSpecVar (L (AlexPn 25 1 26) IdVar "x")) - (Just (L (AlexPn 29 1 30) LitInteger "123")) + [ Fix (MemberDecl + (Fix (TyStd (L (AlexPn 21 1 22) IdStdType "int"))) + (Fix (DeclSpecVar (L (AlexPn 25 1 26) IdVar "x"))) + (Just (L (AlexPn 29 1 30) LitInteger "123"))) ] - ) - (L (AlexPn 36 1 37) IdSueType "Foo") + )) + (L (AlexPn 36 1 37) IdSueType "Foo")) ] it "should parse a comment" $ do let ast = parseText "/* hello */" ast `shouldBe` Right - [ Comment Regular + [ Fix (Comment Regular (L (AlexPn 0 1 1) CmtStart "/*") [L (AlexPn 3 1 4) CmtWord "hello"] - (L (AlexPn 9 1 10) CmtEnd "*/") + (L (AlexPn 9 1 10) CmtEnd "*/")) ] it "supports single declarators" $ do let ast = parseText "int main() { int a; }" ast `shouldBe` Right - [ FunctionDefn + [ Fix (FunctionDefn Global - (FunctionPrototype - (TyStd (L (AlexPn 0 1 1) IdStdType "int")) + (Fix (FunctionPrototype + (Fix (TyStd (L (AlexPn 0 1 1) IdStdType "int"))) (L (AlexPn 4 1 5) IdVar "main") [] - ) - (CompoundStmt [ VarDecl - (TyStd (L (AlexPn 13 1 14) IdStdType "int")) - (Declarator - (DeclSpecVar (L (AlexPn 17 1 18) IdVar "a")) + )) + (Fix (CompoundStmt [ Fix (VarDecl + (Fix (TyStd (L (AlexPn 13 1 14) IdStdType "int"))) + (Fix (Declarator + (Fix (DeclSpecVar (L (AlexPn 17 1 18) IdVar "a"))) Nothing - ) - ]) + ))) + ]))) ] it "does not support multiple declarators per declaration" $ do