cimple 0.0.5 → 0.0.6

raw patch · 17 files changed

+989/−1194 lines, 17 filesdep +data-fixdep +recursion-schemesdep +transformers-compatPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: data-fix, recursion-schemes, transformers-compat

API changes (from Hackage documentation)

Files

• cimple.cabal +8/−2
• src/Language/Cimple.hs +2/−2
• src/Language/Cimple/AST.hs +87/−92
• src/Language/Cimple/Diagnostics.hs +17/−15
• src/Language/Cimple/Flatten.hs +62/−0
• src/Language/Cimple/IO.hs +7/−7
• src/Language/Cimple/Lexer.x +0/−8
• src/Language/Cimple/Parser.y +162/−221
• src/Language/Cimple/Pretty.hs +314/−453
• src/Language/Cimple/Program.hs +2/−2
• src/Language/Cimple/SemCheck/Includes.hs +5/−4
• src/Language/Cimple/Tokens.hs +0/−8
• src/Language/Cimple/TranslationUnit.hs +1/−1
• src/Language/Cimple/TraverseAst.hs +159/−186
• src/Language/Cimple/TreeParser.y +117/−129
• test/Language/Cimple/PrettySpec.hs +5/−12
• test/Language/CimpleSpec.hs +41/−52

@@ -1,12 +1,12 @@ name:                 cimple-version:              0.0.5+version:              0.0.6 synopsis:             Simple C-like programming language homepage:             https://toktok.github.io/ license:              GPL-3 license-file:         LICENSE author:               Iphigenia Df <iphydf@gmail.com> maintainer:           Iphigenia Df <iphydf@gmail.com>-copyright:            Copyright (c) 2016-2020, Iphigenia Df+copyright:            Copyright (c) 2016-2022, Iphigenia Df category:             Data stability:            Experimental cabal-version:        >= 1.10@@ -33,6 +33,7 @@     , Language.Cimple.Program   other-modules:       Language.Cimple.AST+    , Language.Cimple.Flatten     , Language.Cimple.Graph     , Language.Cimple.Lexer     , Language.Cimple.Parser@@ -48,10 +49,13 @@     , array     , bytestring     , containers+    , data-fix     , filepath     , groom     , mtl+    , recursion-schemes     , text+    , transformers-compat  executable cimplefmt   default-language: Haskell2010@@ -121,5 +125,7 @@       base < 5     , ansi-wl-pprint     , cimple+    , data-fix     , hspec     , text+    , transformers-compat

@@ -13,7 +13,7 @@ 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 :: X.IdentityActions (State a) () Text+defaultActions :: AstActions state defaultActions = X.identityActions

@@ -1,127 +1,122 @@-{-# 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 [Node attr lexeme] lexeme+    | Comment CommentStyle lexeme [lexeme] lexeme     | CommentBlock lexeme-    | CommentWord 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]     -- 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)+    | EnumConsts (Maybe lexeme) [a]+    | EnumDecl lexeme [a] lexeme+    | Enumerator lexeme (Maybe 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]-    | ErrorFor lexeme+    | FunctionDecl Scope a+    | FunctionDefn Scope a a+    | FunctionPrototype a lexeme [a]+    | FunctionParam a a     | 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     | AopMul@@ -134,7 +129,7 @@     | AopMod     | AopLsh     | AopRsh-    deriving (Show, Eq, Generic)+    deriving (Show, Read, Eq, Generic)  instance FromJSON AssignOp instance ToJSON AssignOp@@ -158,7 +153,7 @@     | BopGt     | BopGe     | BopRsh-    deriving (Show, Eq, Generic)+    deriving (Show, Read, Eq, Generic)  instance FromJSON BinaryOp instance ToJSON BinaryOp@@ -171,7 +166,7 @@     | UopDeref     | UopIncr     | UopDecr-    deriving (Show, Eq, Generic)+    deriving (Show, Read, Eq, Generic)  instance FromJSON UnaryOp instance ToJSON UnaryOp@@ -182,7 +177,7 @@     | Bool     | String     | ConstId-    deriving (Show, Eq, Generic)+    deriving (Show, Read, Eq, Generic)  instance FromJSON LiteralType instance ToJSON LiteralType@@ -190,7 +185,7 @@ data Scope     = Global     | Static-    deriving (Show, Eq, Generic)+    deriving (Show, Read, Eq, Generic)  instance FromJSON Scope instance ToJSON Scope@@ -199,7 +194,7 @@     = Regular     | Doxygen     | Block-    deriving (Show, Eq, Generic)+    deriving (Show, Read, Eq, Generic)  instance FromJSON CommentStyle instance ToJSON CommentStyle

@@ -6,22 +6,26 @@   , HasDiagnostics (..)   , warn   , sloc-  , at   ) where  import           Control.Monad.State.Lazy (State) import qualified Control.Monad.State.Lazy as State+import           Data.Fix                 (foldFix) import           Data.Text                (Text) import qualified Data.Text                as Text import           Language.Cimple.AST      (Node)-import           Language.Cimple.Lexer    (AlexPosn (..), Lexeme (..),-                                           lexemeLine)-import           Language.Cimple.Tokens   (LexemeClass (..))+import qualified Language.Cimple.Flatten  as Flatten+import           Language.Cimple.Lexer    (Lexeme (..), lexemeLine)  type DiagnosticsT diags a = State diags a type Diagnostics a = DiagnosticsT [Text] a +warn+    :: (HasLocation at, HasDiagnostics diags)+    => FilePath -> at -> Text -> DiagnosticsT diags ()+warn file l w = State.modify (addDiagnostic $ sloc file l <> ": " <> w) + class HasDiagnostics a where     addDiagnostic :: Text -> a -> a @@ -29,16 +33,14 @@     addDiagnostic = (:)  -warn :: HasDiagnostics diags => FilePath -> Lexeme Text -> Text -> DiagnosticsT diags ()-warn file l w = State.modify (addDiagnostic $ sloc file l <> ": " <> w)---sloc :: FilePath -> Lexeme text -> Text-sloc file l = Text.pack file <> ":" <> Text.pack (show (lexemeLine l))+class HasLocation a where+    sloc :: FilePath -> a -> Text +instance HasLocation (Lexeme text) where+    sloc file l = Text.pack file <> ":" <> Text.pack (show (lexemeLine l)) -at :: Node a (Lexeme Text) -> Lexeme Text-at n =-    case foldMap (:[]) n of-        []  -> L (AlexPn 0 0 0) Error "unknown source location"-        l:_ -> l+instance HasLocation lexeme => HasLocation (Node lexeme) where+    sloc file n =+        case foldFix Flatten.lexemes n of+            []  -> Text.pack file <> ":0:0"+            l:_ -> sloc file l

@@ -0,0 +1,62 @@+{-# LANGUAGE DefaultSignatures     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StrictData            #-}+{-# LANGUAGE TypeOperators         #-}+module Language.Cimple.Flatten (lexemes) where++import           Data.Maybe          (maybeToList)+import           GHC.Generics+import           Language.Cimple.AST (AssignOp, BinaryOp, CommentStyle,+                                      LiteralType, NodeF (..), Scope, UnaryOp)++class Concats t a where+    concats :: t -> [a]++    default concats :: (Generic t, GenConcats (Rep t) a) => t -> [a]+    concats = gconcats . from++class GenConcats f a where+    gconcats :: f p -> [a]++instance GenConcats U1 a where+    gconcats U1 = []++instance (GenConcats f a, GenConcats g a) => GenConcats (f :+: g) a where+    gconcats (L1 x) = gconcats x+    gconcats (R1 x) = gconcats x++instance (GenConcats f a, GenConcats g a) => GenConcats (f :*: g) a where+    gconcats (x :*: y) = gconcats x ++ gconcats y++instance GenConcats f a => GenConcats (M1 i t f) a where+    gconcats (M1 x) = gconcats x++class GenConcatsFlatten t a where+    gconcatsFlatten :: t -> [a]++instance GenConcatsFlatten UnaryOp      a where gconcatsFlatten = const []+instance GenConcatsFlatten BinaryOp     a where gconcatsFlatten = const []+instance GenConcatsFlatten AssignOp     a where gconcatsFlatten = const []+instance GenConcatsFlatten Scope        a where gconcatsFlatten = const []+instance GenConcatsFlatten CommentStyle a where gconcatsFlatten = const []+instance GenConcatsFlatten LiteralType  a where gconcatsFlatten = const []++instance GenConcatsFlatten b a => GenConcatsFlatten (Maybe b) a where+    gconcatsFlatten = gconcatsFlatten . maybeToList++instance {-# OVERLAPPING #-} GenConcatsFlatten a a where+    gconcatsFlatten = pure++instance {-# OVERLAPPABLE #-} GenConcatsFlatten b a => GenConcatsFlatten [b] a where+    gconcatsFlatten = concatMap gconcatsFlatten++instance GenConcatsFlatten t a => GenConcats (Rec0 t) a where+    gconcats (K1 x) = gconcatsFlatten x++-- Uses the default signature, which delegates to the generic stuff+instance Concats (NodeF a [a]) a++lexemes :: NodeF lexeme [lexeme] -> [lexeme]+lexemes = concats

@@ -14,24 +14,24 @@ 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) import qualified Language.Cimple.Program         as Program import           Language.Cimple.TranslationUnit (TranslationUnit)-import           Language.Cimple.TraverseAst     (TextActions, mapAst,-                                                  textActions)+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 (mapAst cacheActions stringAst) Map.empty+    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

@@ -114,35 +114,28 @@ <0>		"#define"				{ mkL PpDefine `andBegin` ppSC } <0>		"#undef"				{ mkL PpUndef } <0>		"#include"				{ mkL PpInclude }-<0,ppSC>	"bitmask"				{ mkL KwBitmask } <0,ppSC>	"break"					{ mkL KwBreak } <0,ppSC>	"case"					{ mkL KwCase }-<0,ppSC>	"class"					{ mkL KwClass } <0,ppSC>	"const"					{ mkL KwConst } <0,ppSC>	"continue"				{ mkL KwContinue } <0,ppSC>	"default"				{ mkL KwDefault } <0,ppSC>	"do"					{ mkL KwDo } <0,ppSC>	"else"					{ mkL KwElse } <0,ppSC>	"enum"					{ mkL KwEnum }-<0,ppSC>	"error"					{ mkL KwError }-<0,ppSC>	"event"					{ mkL KwEvent } <0,ppSC>	"extern"				{ mkL KwExtern } <0,ppSC>	"for"					{ mkL KwFor } <0,ppSC>	"goto"					{ mkL KwGoto } <0,ppSC>	"if"					{ mkL KwIf }-<0,ppSC>	"namespace"				{ mkL KwNamespace } <0,ppSC>	"return"				{ mkL KwReturn } <0,ppSC>	"sizeof"				{ mkL KwSizeof } <0,ppSC>	"static"				{ mkL KwStatic } <0,ppSC>	"static_assert"				{ mkL KwStaticAssert } <0,ppSC>	"struct"				{ mkL KwStruct } <0,ppSC>	"switch"				{ mkL KwSwitch }-<0,ppSC>	"this"					{ mkL KwThis } <0,ppSC>	"typedef"				{ mkL KwTypedef } <0,ppSC>	"union"					{ mkL KwUnion } <0,ppSC>	"void"					{ mkL KwVoid } <0,ppSC>	"while"					{ mkL KwWhile }-<0,ppSC>	"with"					{ mkL KwWith } <0,ppSC>	"bool"					{ mkL IdStdType } <0,ppSC>	"char"					{ mkL IdStdType } <0,ppSC>	"double"				{ mkL IdStdType }@@ -159,7 +152,6 @@ <0,ppSC>	"va_list"				{ mkL IdStdType } <0,ppSC>	"false"					{ mkL LitFalse } <0,ppSC>	"true"					{ mkL LitTrue }-<0,ppSC>	"`"[a-z]+				{ mkL IdTyVar } <0,ppSC>	"__func__"				{ mkL IdVar } <0,ppSC>	"__"[a-zA-Z]+"__"?			{ mkL IdConst } <0,ppSC>	[A-Z][A-Z0-9_]{1,2}			{ mkL IdSueType }

@@ -3,9 +3,11 @@     ( 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 (..))@@ -26,38 +28,30 @@     ID_FUNC_TYPE		{ L _ IdFuncType		_ }     ID_STD_TYPE			{ L _ IdStdType			_ }     ID_SUE_TYPE			{ L _ IdSueType			_ }-    ID_TYVAR			{ L _ IdTyVar			_ }     ID_VAR			{ L _ IdVar			_ }-    bitmask			{ L _ KwBitmask			_ }     break			{ L _ KwBreak			_ }     case			{ L _ KwCase			_ }-    class			{ L _ KwClass			_ }     const			{ L _ KwConst			_ }     continue			{ L _ KwContinue		_ }     default			{ L _ KwDefault			_ }     do				{ L _ KwDo			_ }     else			{ L _ KwElse			_ }     enum			{ L _ KwEnum			_ }-    'error'			{ L _ KwError			_ }-    event			{ L _ KwEvent			_ }     extern			{ L _ KwExtern			_ }     for				{ L _ KwFor			_ }     goto			{ L _ KwGoto			_ }     if				{ L _ KwIf			_ }-    namespace			{ L _ KwNamespace		_ }     return			{ L _ KwReturn			_ }     sizeof			{ L _ KwSizeof			_ }     static			{ L _ KwStatic			_ }     static_assert		{ L _ KwStaticAssert		_ }     struct			{ L _ KwStruct			_ }     switch			{ L _ KwSwitch			_ }-    this			{ L _ KwThis			_ }     typedef			{ L _ KwTypedef			_ }     union			{ L _ KwUnion			_ }     VLA				{ L _ KwVla			_ }     void			{ L _ KwVoid			_ }     while			{ L _ KwWhile			_ }-    with			{ L _ KwWith			_ }     LIT_CHAR			{ L _ LitChar			_ }     LIT_FALSE			{ L _ LitFalse			_ }     LIT_TRUE			{ L _ LitTrue			_ }@@ -158,7 +152,7 @@  LicenseDecl :: { StringNode } LicenseDecl-:	'/*' 'License' CMT_WORD '\n' CopyrightDecls '*/'	{ LicenseDecl $3 $5 }+:	'/*' 'License' CMT_WORD '\n' CopyrightDecls '*/'	{ Fix $ LicenseDecl $3 (reverse $5) }  CopyrightDecls :: { [StringNode] } CopyrightDecls@@ -167,7 +161,7 @@  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@@ -189,11 +183,8 @@ |	Comment							{ $1 } |	ConstDecl						{ $1 } |	EnumDecl						{ $1 }-|	ErrorDecl						{ $1 }-|	Event							{ $1 } |	ExternC							{ $1 } |	FunctionDecl						{ $1 }-|	Namespace						{ $1 } |	PreprocDefine						{ $1 } |	PreprocIfdef(ToplevelDecls)				{ $1 } |	PreprocIf(ToplevelDecls)				{ $1 }@@ -204,57 +195,25 @@  StaticAssert :: { StringNode } StaticAssert-:	static_assert '(' ConstExpr ',' LIT_STRING ')' ';'	{ StaticAssert $3 $5 }--Namespace :: { StringNode }-Namespace-:	NamespaceDeclarator					{ $1 Global }-|	static NamespaceDeclarator				{ $2 Static }--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) }--TypeParams :: { [StringNode] }-TypeParams-:								{ [] }-|	'<' ID_TYVAR '>'					{ [TyVar $2] }--Event :: { StringNode }-Event-:	event IdVar       '{' Comment EventType '}'		{ Event $2 (Commented $4 $5) }-|	event IdVar const '{' Comment EventType '}'		{ Event $2 (Commented $5 $6) }--EventType :: { StringNode }-EventType-:	typedef void EventParams ';'				{ $3 }--EventParams :: { StringNode }-EventParams-:	FunctionParamList					{ EventParams $1 }--ErrorDecl :: { StringNode }-ErrorDecl-:	'error' for IdVar EnumeratorList			{ ErrorDecl $3 $4 }+:	static_assert '(' ConstExpr ',' LIT_STRING ')' ';'	{ Fix $ StaticAssert $3 $5 }  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 :: { [StringNode] }+CommentTokens :: { [StringLexeme] } CommentTokens :	CommentToken						{ [$1] } |	CommentTokens CommentToken				{ $2 : $1 } -CommentToken :: { StringNode }+CommentToken :: { StringLexeme } CommentToken-:	CommentWord						{ CommentWord $1 }-|	'\n'							{ CommentWord $1 }-|	' * '							{ CommentWord $1 }+:	CommentWord						{ $1 }+|	'\n'							{ $1 }+|	' * '							{ $1 }  CommentWords :: { [StringLexeme] } CommentWords@@ -284,42 +243,42 @@ |	'='							{ $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 (reverse $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 +287,12 @@  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,10 +313,9 @@ Stmt :	PreprocIfdef(Stmts)					{ $1 } |	PreprocIf(Stmts)					{ $1 }-|	PreprocDefine Stmts PreprocUndef			{ PreprocScopedDefine $1 $2 $3 }-|	LabelStmt						{ $1 }+|	PreprocDefine Stmts PreprocUndef			{ Fix $ PreprocScopedDefine $1 $2 $3 } |	DeclStmt						{ $1 }-|	CompoundStmt						{ CompoundStmt $1 }+|	CompoundStmt						{ $1 } |	IfStmt							{ $1 } |	ForStmt							{ $1 } |	WhileStmt						{ $1 }@@ -365,23 +323,24 @@ |	AssignExpr ';'						{ $1 } |	ExprStmt ';'						{ $1 } |	FunctionCall ';'					{ $1 }-|	break ';'						{ Break }-|	goto ID_CONST ';'					{ Goto $2 }-|	continue ';'						{ Continue }-|	return ';'						{ Return Nothing }-|	return Expr ';'						{ Return (Just $2) }-|	switch '(' Expr ')' CompoundStmt			{ SwitchStmt $3 $5 }+|	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 (reverse $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 (CompoundStmt $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,54 +354,57 @@  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 } -LabelStmt :: { StringNode }-LabelStmt-:	case Expr ':' AfterLabelStmt				{ Case $2 $4 }-|	default ':' AfterLabelStmt				{ Default $3 }-|	ID_CONST ':' Stmt					{ Label $1 $3 }+SwitchCases :: { [StringNode] }+SwitchCases+:	SwitchCase						{ [$1] }+|	SwitchCases SwitchCase					{ $2 : $1 } -AfterLabelStmt :: { StringNode }-AfterLabelStmt-:	CompoundStmt						{ CompoundStmt $1 }-|	LabelStmt						{ $1 }-|	return Expr ';'						{ Return (Just $2) }+SwitchCase :: { StringNode }+SwitchCase+:	case Expr ':' SwitchCaseBody				{ Fix $ Case $2 $4 }+|	default ':' SwitchCaseBody				{ Fix $ Default $3 } +SwitchCaseBody :: { StringNode }+SwitchCaseBody+:	CompoundStmt						{ $1 }+|	SwitchCase						{ $1 }+|	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 :	ID_VAR							{ $1 } |	default							{ $1 }-|	'error'							{ $1 }  InitialiserList :: { [StringNode] } InitialiserList@@ -457,19 +419,19 @@ Initialiser :: { StringNode } Initialiser :	Expr							{ $1 }-|	InitialiserList						{ InitialiserList $1 }+|	InitialiserList						{ Fix $ InitialiserList $1 } -CompoundStmt :: { [StringNode] }+CompoundStmt :: { StringNode } CompoundStmt-:	'{' Stmts '}'						{ 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@@ -477,51 +439,51 @@  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@@ -534,11 +496,11 @@ -- 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@@ -556,12 +518,12 @@  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@@ -576,15 +538,13 @@ 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 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 }  EnumeratorList :: { [StringNode] } EnumeratorList@@ -597,9 +557,8 @@  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) } |	Comment							{ $1 }  EnumeratorName :: { Lexeme String }@@ -610,14 +569,12 @@ AggregateDecl :: { StringNode } AggregateDecl :	AggregateType ';'					{ $1 }-|	class ID_SUE_TYPE TypeParams ';'			{ ClassForward $2 $3 }-|	typedef AggregateType ID_SUE_TYPE ';'			{ Typedef $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 }+|	union ID_SUE_TYPE '{' MemberDeclList '}'		{ Fix $ Union $2 $4 }  MemberDeclList :: { [StringNode] } MemberDeclList@@ -630,42 +587,39 @@  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) } |	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 }+|	ID_FUNC_TYPE						{ Fix $ TyFunc $1 }+|	ID_STD_TYPE						{ Fix $ TyStd $1 }+|	ID_SUE_TYPE						{ Fix $ TyUserDefined $1 }  FunctionDecl :: { StringNode } FunctionDecl@@ -674,36 +628,19 @@  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) }--Accessors :: { [StringNode] }-Accessors-:	Accessor						{ [$1] }-|	Accessors Accessor					{ $2 : $1 }--Accessor :: { StringNode }-Accessor-:	IdVar FunctionParamList WithError			{ Accessor $1 $2 $3 }-|	Comment							{ $1 }--WithError :: { Maybe StringNode }-WithError-:	';'							{ Nothing }-|	with 'error' EnumeratorList				{ Just (ErrorList $3) }-|	with 'error' for IdVar ';'				{ Just (ErrorFor $4) }+:	FunctionPrototype(IdVar) ';'				{ \s -> Fix $ FunctionDecl s $1 }+|	FunctionPrototype(IdVar) CompoundStmt			{ \s -> Fix $ FunctionDefn s $1 $2 }  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@@ -712,18 +649,22 @@  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) =     alexError $ show line <> ":" <> show col <> ": Parse error near " <> show c <> ": "@@ -739,17 +680,17 @@     -> 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?)"  macroBodyStmt-    :: [StringNode]+    :: StringNode     -> 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)'"

@@ -1,99 +1,70 @@+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE TupleSections #-} module Language.Cimple.Pretty (ppTranslationUnit) where +import           Data.Fix                     (foldFix) 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+import           Text.PrettyPrint.ANSI.Leijen hiding (semi) +-- | Whether a node needs a semicolon at the end when it's a statement or+-- declaration.+data NeedsSemi+    = SemiNo+    | SemiYes++-- | Annotated Doc which is passed upwards through the fold. 'fst' is the+-- accumulated pretty-printed code. 'snd' states whether the current statement+-- should end in a semicolon ';'. E.g. function definitions don't, while+-- function declarations do.+type ADoc = (Doc, NeedsSemi)+bare, semi :: Doc -> ADoc+bare = (, SemiNo)+semi = (, SemiYes)++-- | Copy the 'NeedsSemi' from another 'ADoc' to a newly created doc.+cp :: ADoc -> Doc -> ADoc+cp (_, s) d = (d, s)+ ppText :: Text -> Doc ppText = text . Text.unpack  ppLexeme :: Lexeme Text -> Doc ppLexeme = ppText . lexemeText -ppCommaSep :: (a -> Doc) -> [a] -> Doc-ppCommaSep go = foldr (<>) empty . List.intersperse (text ", ") . map go--ppLineSep :: (a -> Doc) -> [a] -> Doc-ppLineSep go = foldr (<>) empty . List.intersperse linebreak . map go+ppSep :: Doc -> [ADoc] -> Doc+ppSep s = foldr (<>) empty . List.intersperse s . map fst -ppComment :: Show a => CommentStyle -> [Node a (Lexeme Text)] -> Doc-ppComment style cs =-    nest 1 (ppCommentStyle style <> ppCommentBody cs) <+> text "*/"+ppCommaSep :: [ADoc] -> Doc+ppCommaSep = ppSep (text ", ") -ppCommentStyle :: CommentStyle -> Doc-ppCommentStyle Block   = text "/***"-ppCommentStyle Doxygen = text "/**"-ppCommentStyle Regular = text "/*"+ppLineSep :: [ADoc] -> Doc+ppLineSep = ppSep linebreak -ppCommentWords :: [Lexeme Text] -> Doc-ppCommentWords = go+ppSemiSep :: [ADoc] -> Doc+ppSemiSep = ppEnd (char ';')   where-    go (L _ LitInteger t1 : L _ PctMinus m : L _ LitInteger t2 : xs) =-        space <> ppText t1 <> ppText m <> ppText t2 <> go xs-    go (L _ PctMinus m : L _ LitInteger t : xs) =-        space <> ppText m <> ppText t <> go xs--    go (l : L _ PctPeriod t : xs) = go [l] <> ppText t <> go xs-    go (l : L _ PctComma  t : xs) = go [l] <> ppText t <> go xs-    go (x                   : xs) = ppWord x <> go xs-    go []                         = empty--    ppWord (L _ CmtSpdxLicense   t) = space <> ppText t-    ppWord (L _ CmtSpdxCopyright t) = space <> ppText t-    ppWord (L _ CmtWord          t) = space <> ppText t-    ppWord (L _ CmtCode          t) = space <> ppText t-    ppWord (L _ CmtRef           t) = space <> ppText t-    ppWord (L _ CmtIndent        _) = char '*'-    ppWord (L _ PpNewline        _) = linebreak-    ppWord (L _ LitInteger       t) = space <> ppText t-    ppWord (L _ LitString        t) = space <> ppText t-    ppWord (L _ PctEMark         t) = space <> ppText t-    ppWord (L _ PctPlus          t) = space <> ppText t-    ppWord (L _ PctEq            t) = space <> ppText t-    ppWord (L _ PctMinus         t) = space <> ppText t-    ppWord (L _ PctPeriod        t) = space <> ppText t-    ppWord (L _ PctLParen        t) = space <> ppText t-    ppWord (L _ PctRParen        t) = space <> ppText t-    ppWord (L _ PctSemicolon     t) = space <> ppText t-    ppWord (L _ PctColon         t) = space <> ppText t-    ppWord (L _ PctQMark         t) = space <> ppText t-    ppWord (L _ PctSlash         t) = space <> ppText t-    ppWord (L _ PctGreater       t) = space <> ppText t-    ppWord (L _ PctLess          t) = space <> ppText t-    ppWord (L _ PctComma         t) = space <> ppText t-    ppWord x                        = error $ groom x+    ppEnd s = foldr (<>) empty . List.intersperse linebreak . map (addEnd s) -ppCommentBody :: Show a => [Node a (Lexeme Text)] -> Doc-ppCommentBody = ppCommentWords . map unCommentWord-  where-    unCommentWord (CommentWord l) = l-    unCommentWord x               = error $ groom x+    addEnd s (d, SemiYes) = d <> s+    addEnd _ (d, SemiNo)  = d  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+ppScope = \case+    Global -> empty+    Static -> text "static "  ppAssignOp :: AssignOp -> Doc-ppAssignOp op = case op of-    AopEq     -> text "="+ppAssignOp = \case+    AopEq     -> char '='     AopMul    -> text "*="     AopDiv    -> text "/="     AopPlus   -> text "+="@@ -106,7 +77,7 @@     AopRsh    -> text "<<="  ppBinaryOp :: BinaryOp -> Doc-ppBinaryOp op = case op of+ppBinaryOp = \case     BopNe     -> text "!="     BopEq     -> text "=="     BopOr     -> text "||"@@ -127,7 +98,7 @@     BopRsh    -> text ">>"  ppUnaryOp :: UnaryOp -> Doc-ppUnaryOp op = case op of+ppUnaryOp = \case     UopNot     -> char '!'     UopNeg     -> char '~'     UopMinus   -> char '-'@@ -136,458 +107,348 @@     UopIncr    -> text "++"     UopDecr    -> text "--" -ppInitialiserList :: Show a => [Node a (Lexeme Text)] -> Doc-ppInitialiserList l = char '{' <+> ppCommaSep ppExpr l <+> char '}'+ppCommentStyle :: CommentStyle -> Doc+ppCommentStyle = \case+    Block   -> text "/***"+    Doxygen -> text "/**"+    Regular -> text "/*" -ppDeclSpec :: Show a => Node a (Lexeme Text) -> Doc-ppDeclSpec (DeclSpecVar var        ) = ppLexeme var-ppDeclSpec (DeclSpecArray dspec dim) = ppDeclSpec dspec <> ppDim dim+ppCommentBody :: [Lexeme Text] -> Doc+ppCommentBody = go   where-    ppDim Nothing  = text "[]"-    ppDim (Just x) = char '[' <> ppExpr x <> char ']'-ppDeclSpec x = error $ groom x+    go (L _ LitInteger t1 : L _ PctMinus m : L _ LitInteger t2 : xs) =+        space <> ppText t1 <> ppText m <> ppText t2 <> go xs+    go (L _ PctMinus m : L _ LitInteger t : xs) =+        space <> ppText m <> ppText t <> go xs -ppDeclarator :: Show a => Node a (Lexeme Text) -> Doc-ppDeclarator (Declarator dspec Nothing) =-    ppDeclSpec dspec-ppDeclarator (Declarator dspec (Just initr)) =-    ppDeclSpec dspec <+> char '=' <+> ppExpr initr-ppDeclarator x = error $ groom x+    go (l : L _ PctPeriod t : xs) = go [l] <> ppText t <> go xs+    go (l : L _ PctComma  t : xs) = go [l] <> ppText t <> go xs+    go (x                   : xs) = ppWord x <> go xs+    go []                         = empty -ppFunctionParamList :: Show a => [Node a (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+    ppWord (L _ CmtSpdxLicense   t) = space <> ppText t+    ppWord (L _ CmtSpdxCopyright t) = space <> ppText t+    ppWord (L _ CmtWord          t) = space <> ppText t+    ppWord (L _ CmtCode          t) = space <> ppText t+    ppWord (L _ CmtRef           t) = space <> ppText t+    ppWord (L _ CmtIndent        _) = char '*'+    ppWord (L _ PpNewline        _) = linebreak+    ppWord (L _ LitInteger       t) = space <> ppText t+    ppWord (L _ LitString        t) = space <> ppText t+    ppWord (L _ PctEMark         t) = space <> ppText t+    ppWord (L _ PctPlus          t) = space <> ppText t+    ppWord (L _ PctEq            t) = space <> ppText t+    ppWord (L _ PctMinus         t) = space <> ppText t+    ppWord (L _ PctPeriod        t) = space <> ppText t+    ppWord (L _ PctLParen        t) = space <> ppText t+    ppWord (L _ PctRParen        t) = space <> ppText t+    ppWord (L _ PctSemicolon     t) = space <> ppText t+    ppWord (L _ PctColon         t) = space <> ppText t+    ppWord (L _ PctQMark         t) = space <> ppText t+    ppWord (L _ PctSlash         t) = space <> ppText t+    ppWord (L _ PctGreater       t) = space <> ppText t+    ppWord (L _ PctLess          t) = space <> ppText t+    ppWord (L _ PctComma         t) = space <> ppText t+    ppWord x                        = error $ "ppWord: " <> groom x +ppComment :: CommentStyle -> [Lexeme Text] -> Doc+ppComment style cs =+    nest 1 (ppCommentStyle style <> ppCommentBody cs) <+> text "*/"++ppInitialiserList :: [ADoc] -> Doc+ppInitialiserList l = char '{' <+> ppCommaSep l <+> char '}'++ppFunctionParamList :: [ADoc] -> Doc+ppFunctionParamList xs = char '(' <> ppCommaSep xs <> char ')'+ ppFunctionPrototype-    :: Show a-    => Node a (Lexeme Text)+    :: ADoc     -> Lexeme Text-    -> [Node a (Lexeme Text)]+    -> [ADoc]     -> Doc ppFunctionPrototype ty name params =-    ppType ty <+> ppLexeme name <> ppFunctionParamList params--ppWithError :: Show a => Maybe (Node a (Lexeme Text)) -> Doc-ppWithError Nothing = char ';'-ppWithError (Just (ErrorFor name)) =-    text " with error for" <+> ppLexeme name <> char ';'-ppWithError (Just (ErrorList errs)) =-    nest 2 (-        text " with error" <+> char '{' <$>-        ppEnumeratorList errs-    ) <$> char '}'-ppWithError x = error $ groom x+    fst ty <+> ppLexeme name <> ppFunctionParamList params -ppFunctionCall :: Show a => Node a (Lexeme Text) -> [Node a (Lexeme Text)] -> Doc+ppFunctionCall :: ADoc -> [ADoc] -> 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 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--ppMacroParamList :: Show a => [Node a (Lexeme Text)] -> Doc-ppMacroParamList xs = char '(' <> ppCommaSep ppMacroParam xs <> char ')'--ppNamespace :: ([a] -> Doc) -> Scope -> Lexeme Text -> [a] -> Doc-ppNamespace pp scope name members =-    nest 2 (-        ppScope scope <>-        text "namespace" <+> ppLexeme name <+> char '{' <$>-        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)) =-    ppLexeme name <+> char '=' <+> ppExpr value <> char ','-ppEnumerator (Namespace scope name members) =-    ppNamespace ppEnumeratorList scope name members-ppEnumerator x = error $ groom x--ppEnumeratorList :: Show a => [Node a (Lexeme Text)] -> Doc-ppEnumeratorList = ppLineSep ppEnumerator--ppMemberDecl :: Show a => Node a (Lexeme Text) -> Doc-ppMemberDecl = ppDecl--ppMemberDeclList :: Show a => [Node a (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) =-    ppLexeme name <> ppFunctionParamList params <> ppWithError errs-ppAccessor x = error $ groom x--ppAccessorList :: Show a => [Node a (Lexeme Text)] -> Doc-ppAccessorList = ppLineSep ppAccessor--ppEventType :: Show a => Node a (Lexeme Text) -> Doc-ppEventType (Commented (Comment style _ cs _) ty) =-    ppComment style cs <$> ppEventType ty-ppEventType (EventParams params) =-    text "typedef void" <> ppFunctionParamList params-ppEventType x = error $ groom x--ppTypeParams :: Show a => [Node a (Lexeme Text)] -> Doc-ppTypeParams [] = empty-ppTypeParams xs = char '<' <> ppCommaSep pp xs <> char '>'-  where-    pp (TyVar x) = ppLexeme x-    pp x         = error $ groom x--ppCompoundStmt :: Show a => [Node a (Lexeme Text)] -> Doc-ppCompoundStmt body =-    nest 2 (-        char '{' <$>-        ppStmtList body-    ) <$> char '}'+    fst callee <> char '(' <> ppCommaSep args <> char ')' -ppStmtList :: Show a => [Node a (Lexeme Text)] -> Doc-ppStmtList = ppLineSep ppDecl+ppMacroParamList :: [ADoc] -> Doc+ppMacroParamList xs = char '(' <> ppCommaSep xs <> char ')'  ppIfStmt-    :: Show a-    => Node a (Lexeme Text)-    -> [Node a (Lexeme Text)]-    -> Maybe (Node a (Lexeme Text))+    :: ADoc+    -> ADoc+    -> Maybe ADoc     -> Doc ppIfStmt cond t Nothing =-    nest 2 (-        text "if (" <> ppExpr cond <> text ") {" <$>-        ppStmtList t-    ) <$> char '}'+    text "if (" <> fst cond <> text ")" <+> fst t ppIfStmt cond t (Just e) =-    nest 2 (-        text "if (" <> ppExpr cond <> text ") {" <$>-        ppStmtList t-    ) <$> nest 2 (char '}' <> text " else " <> ppDecl e)+    text "if (" <> fst cond <> text ")" <+> fst t <+> text "else" <+> fst e  ppForStmt-    :: Show a-    => Node a (Lexeme Text)-    -> Node a (Lexeme Text)-    -> Node a (Lexeme Text)-    -> [Node a (Lexeme Text)]+    :: ADoc+    -> ADoc+    -> ADoc+    -> ADoc     -> Doc ppForStmt i c n body =-    nest 2 (-        text "for ("-        <> ppDecl i-        <+> ppExpr c <> char ';'-        <+> ppExpr n-        <> text ") {" <$>-        ppStmtList body-    ) <$> char '}'+    text "for ("+    <> fst i <> char ';'+    <+> fst c <> char ';'+    <+> fst n+    <> char ')' <+>+    fst body  ppWhileStmt-    :: Show a-    => Node a (Lexeme Text)-    -> [Node a (Lexeme Text)]+    :: ADoc+    -> ADoc     -> Doc ppWhileStmt c body =-    nest 2 (-        text "while ("-        <> ppExpr c-        <> text ") {" <$>-        ppStmtList body-    ) <$> char '}'+    text "while ("+    <> fst c+    <> char ')' <+>+    fst body  ppDoWhileStmt-    :: Show a-    => [Node a (Lexeme Text)]-    -> Node a (Lexeme Text)+    :: ADoc+    -> ADoc     -> Doc ppDoWhileStmt body c =-    nest 2 (-        text "do ("-        <> text ") {" <$>-        ppStmtList body-    ) <$> text "} while (" <> ppExpr c <> char ')'+    text "do ("+    <> text ") {" <$>+    fst body+    <+> text "while (" <> fst c <> char ')'  ppSwitchStmt-    :: Show a-    => Node a (Lexeme Text)-    -> [Node a (Lexeme Text)]+    :: ADoc+    -> [ADoc]     -> Doc ppSwitchStmt c body =     nest 2 (         text "switch ("-        <> ppExpr c+        <> fst c         <> text ") {" <$>-        ppStmtList body+        ppSemiSep body     ) <$> char '}' -ppExpr :: Show a => Node a (Lexeme Text) -> Doc-ppExpr expr = case expr of-    -- Expressions-    VarExpr var       -> ppLexeme var-    LiteralExpr _ l   -> ppLexeme l-    SizeofExpr arg    -> text "sizeof(" <> ppExpr arg <> char ')'-    SizeofType arg    -> text "sizeof(" <> ppType arg <> char ')'-    BinaryExpr  l o r -> ppExpr l <+> ppBinaryOp o <+> ppExpr r-    AssignExpr  l o r -> ppExpr l <+> ppAssignOp o <+> ppExpr r-    TernaryExpr c t e -> ppTernaryExpr c t e-    UnaryExpr o e     -> ppUnaryOp o <> ppExpr e-    ParenExpr e       -> char '(' <> ppExpr e <> char ')'-    FunctionCall c  a -> ppFunctionCall c a-    ArrayAccess  e  i -> ppExpr e <> char '[' <> ppExpr i <> char ']'-    CastExpr     ty e -> char '(' <> ppType ty <> char ')' <> ppExpr e-    CompoundExpr ty e -> char '(' <> ppType ty <> char ')' <+> char '{' <> ppExpr e <> char '}'-    PreprocDefined  n -> text "defined(" <> ppLexeme n <> char ')'-    InitialiserList l -> ppInitialiserList l-    PointerAccess e m -> ppExpr e <> text "->" <> ppLexeme m-    MemberAccess  e m -> ppExpr e <> text "." <> ppLexeme m-    CommentExpr   c e -> ppCommentExpr c e-    LicenseDecl l cs  -> ppLicenseDecl l cs+ppVLA :: ADoc -> Lexeme Text -> ADoc -> Doc+ppVLA ty n sz =+    text "VLA("+        <> fst ty+        <> text ", "+        <> ppLexeme n+        <> text ", "+        <> fst sz+        <> char ')' -    x                 -> error $ groom x+ppCompoundStmt :: [ADoc] -> Doc+ppCompoundStmt body =+    nest 2 (+        char '{' <$>+        ppSemiSep body+    ) <$> char '}'  ppTernaryExpr-    :: Show a => Node a (Lexeme Text) -> Node a (Lexeme Text) -> Node a (Lexeme Text) -> Doc+    :: ADoc+    -> ADoc+    -> ADoc+    -> Doc ppTernaryExpr c t e =-    ppExpr c <+> char '?' <+> ppExpr t <+> char ':' <+> ppExpr e+    fst c <+> char '?' <+> fst t <+> char ':' <+> fst e -ppLicenseDecl :: Show a => Lexeme Text -> [Node a (Lexeme Text)] -> Doc+ppLicenseDecl :: Lexeme Text -> [ADoc] -> 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) =-    ppLexeme from <> char '-' <> ppLexeme to <+>-    ppCommentWords owner-ppCopyrightDecl (CopyrightDecl from Nothing owner) =-    ppLexeme from <+>-    ppCommentWords owner-ppCopyrightDecl x =-    error $ groom x--ppCommentExpr :: Show a => Node a (Lexeme Text) -> Node a (Lexeme Text) -> Doc-ppCommentExpr (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 = ppDecl--ppDeclList :: Show a => [Node a (Lexeme Text)] -> Doc-ppDeclList = ppLineSep ppDecl--ppDecl :: Show a => Node a (Lexeme Text) -> Doc-ppDecl decl = case decl of-    PreprocElif cond decls (PreprocElse []) ->-        text "#elif" <+> ppExpr cond <$>-        ppDeclList decls <$>-        text "#endif"-    PreprocElif cond decls elseBranch ->-        text "#elif" <+> ppExpr cond <$>-        ppDeclList decls <$>-        ppDeclList [elseBranch] <$>-        text "#endif"-    PreprocIf cond decls (PreprocElse []) ->-        nest (-100) (text "#if") <+> ppExpr cond <$>-        ppDeclList decls <$>-        text "#endif"-    PreprocIf cond decls elseBranch ->-        text "#if" <+> ppExpr cond <$>-        ppDeclList decls <$>-        ppDeclList [elseBranch] <$>-        text "#endif"-    PreprocIfdef name decls (PreprocElse []) ->-        indent (-2) (text "#ifndef" <+> ppLexeme name <$>-        ppDeclList decls) <$>-        text "#endif"-    PreprocIfdef name decls elseBranch ->-        text "#ifdef" <+> ppLexeme name <$>-        ppDeclList decls <$>-        ppDeclList [elseBranch] <$>-        text "#endif"-    PreprocIfndef name decls (PreprocElse []) ->-        text "#ifndef" <+> ppLexeme name <$>-        ppDeclList decls <$>-        text "#endif"-    PreprocIfndef name decls elseBranch ->-        text "#ifndef" <+> ppLexeme name <$>-        ppDeclList decls <$>-        ppDeclList [elseBranch] <$>-        text "#endif"-    PreprocElse decls ->-        text "#else" <$>-        ppDeclList decls--    PreprocScopedDefine def stmts undef ->-        ppDecl def <$> ppStmtList stmts <$> ppDecl undef+    ppCommentStyle Regular <+> text "SPDX-License-Identifier: " <> ppLexeme l <$>+    ppLineSep cs <$>+    text " */" -    PreprocInclude hdr ->-        text "#include" <+> ppLexeme hdr-    PreprocDefine name ->-        text "#define" <+> ppLexeme name-    PreprocDefineConst name value ->-        text "#define" <+> ppLexeme name <+> ppExpr value-    PreprocDefineMacro name params body ->-        text "#define" <+> ppLexeme name <> ppMacroParamList params <+> ppMacroBody body-    PreprocUndef name ->-        text "#undef" <+> ppLexeme name+ppNode :: Node (Lexeme Text) -> ADoc+ppNode = foldFix go+  where+  go :: NodeF (Lexeme Text) ADoc -> ADoc+  go = \case+    StaticAssert cond msg -> semi $+        text "static_assert(" <+> fst cond <> char ',' <+> ppLexeme msg <> char ')' -    StaticAssert cond msg ->-        text "static_assert" <+> ppExpr cond <> char ',' <+> ppLexeme msg <> text ");"+    LicenseDecl l cs -> bare $ ppLicenseDecl l cs+    CopyrightDecl from (Just to) owner -> bare $+        text " * Copyright © " <>+        ppLexeme from <> char '-' <> ppLexeme to <>+        ppCommentBody owner+    CopyrightDecl from Nothing owner -> bare $+        text " * Copyright © " <>+        ppLexeme from <>+        ppCommentBody owner -    Comment style _ cs _ ->+    Comment style _ cs _ -> bare $         ppComment style cs-    CommentBlock cs ->+    CommentBlock cs -> bare $         ppLexeme cs-    Commented c d ->-        ppDecl c <$> ppDecl d+    Commented (c, _) (d, s) -> (, s) $+        c <$> d -    ClassForward name [] ->-        text "class" <+> ppLexeme name <> char ';'-    Class scope name tyvars decls ->-        ppScope scope <>-        nest 2 (-            text "class" <+> ppLexeme name <> ppTypeParams tyvars <+> char '{' <$>-            ppDeclList decls-        ) <$> text "};"+    VarExpr var       -> semi $ ppLexeme var+    LiteralExpr _ l   -> semi $ ppLexeme l+    SizeofExpr arg    -> semi $ text "sizeof(" <> fst arg <> char ')'+    SizeofType arg    -> semi $ text "sizeof(" <> fst arg <> char ')'+    BinaryExpr  l o r -> semi $ fst l <+> ppBinaryOp o <+> fst r+    AssignExpr  l o r -> semi $ fst l <+> ppAssignOp o <+> fst r+    TernaryExpr c t e -> semi $ ppTernaryExpr c t e+    UnaryExpr o e     -> semi $ ppUnaryOp o <> fst e+    ParenExpr e       -> semi $ char '(' <> fst e <> char ')'+    FunctionCall c  a -> semi $ ppFunctionCall c a+    ArrayAccess  e  i -> semi $ fst e <> char '[' <> fst i <> char ']'+    CastExpr     ty e -> semi $ char '(' <> fst ty <> char ')' <> fst e+    CompoundExpr ty e -> semi $ char '(' <> fst ty <> char ')' <+> char '{' <> fst e <> char '}'+    PreprocDefined  n -> bare $ text "defined(" <> ppLexeme n <> char ')'+    InitialiserList l -> semi $ ppInitialiserList l+    PointerAccess e m -> semi $ fst e <> text "->" <> ppLexeme m+    MemberAccess  e m -> semi $ fst e <> text "." <> ppLexeme m+    CommentExpr   c e -> semi $ fst c <+> fst e+    Ellipsis          -> semi $ text "..." -    EnumConsts Nothing enums ->-        nest 2 (-            text "enum" <+> char '{' <$>-            ppEnumeratorList enums-        ) <$> text "};"-    EnumConsts (Just name) enums ->-        nest 2 (-            text "enum" <+> ppLexeme name <+> char '{' <$>-            ppEnumeratorList enums-        ) <$> text "};"-    EnumClass name enums ->-        nest 2 (-            text "enum class" <+> ppLexeme name <+> char '{' <$>-            ppEnumeratorList enums-        ) <$> text "};"-    EnumDecl name enums ty ->-        nest 2 (-            text "typedef enum" <+> ppLexeme name <+> char '{' <$>-            ppEnumeratorList enums-        ) <$> text "} " <> ppLexeme ty <> char ';'+    Declarator dspec Nothing -> dspec+    Declarator dspec (Just initr) -> bare $ fst dspec <+> char '=' <+> fst initr -    Namespace scope name decls ->-        ppNamespace ppDeclList scope name decls+    DeclSpecVar var -> bare $ ppLexeme var+    DeclSpecArray dspec Nothing     -> bare $ fst dspec <> text "[]"+    DeclSpecArray dspec (Just dim)  -> bare $ fst dspec <> char '[' <> fst dim <> char ']' -    ExternC decls ->+    TyPointer     ty -> bare $ fst ty <> char '*'+    TyConst       ty -> bare $ fst ty <+> text "const"+    TyUserDefined l  -> bare $ ppLexeme l+    TyStd         l  -> bare $ ppLexeme l+    TyFunc        l  -> bare $ ppLexeme l+    TyStruct      l  -> bare $ text "struct" <+> ppLexeme l++    ExternC decls -> bare $         text "#ifndef __cplusplus" <$>         text "extern \"C\" {" <$>         text "#endif" <$>-        ppDeclList decls <$>+        ppSemiSep decls <$>         text "#ifndef __cplusplus" <$>         text "}" <$>         text "#endif" -    Struct name members ->-        nest 2 (-            text "struct" <+> ppLexeme name <+> char '{' <$>-            ppMemberDeclList members-        ) <$> text "};"-    Typedef (Union name members) tyname ->-        nest 2 (-            text "typedef union" <+> ppLexeme name <+> char '{' <$>-            ppMemberDeclList members-        ) <$> char '}' <+> ppLexeme tyname <> char ';'-    Typedef (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) ->-        text "typedef" <+>-        ppFunctionPrototype ty name params <>-        char ';'+    MacroParam l -> bare $ ppLexeme l -    MemberDecl ty dspec Nothing ->-        ppType ty <+> ppDeclSpec dspec <> char ';'-    MemberDecl ty dspec (Just size) ->-        ppType ty <+> ppDeclSpec dspec <+> char ':' <+> ppLexeme size <> char ';'+    MacroBodyFunCall e -> e+    MacroBodyStmt body -> bare $+        text "do" <+> fst body <+> text "while (0)" -    FunctionDecl scope (FunctionPrototype ty name params) err ->-        ppScope scope <>-        ppFunctionPrototype ty name params <>-        ppWithError err-    FunctionDefn scope (FunctionPrototype ty name params) body ->-        ppScope scope <>-        ppFunctionPrototype ty name params <$>-        ppCompoundStmt body+    PreprocScopedDefine def stmts undef -> bare $+        fst def <$> ppSemiSep stmts <$> fst undef -    ConstDecl ty name ->-        text "extern const" <+> ppType ty <+> ppLexeme name <> char ';'-    ConstDefn scope ty name value ->-        ppScope scope <>-        ppType ty <+> ppLexeme name <+> char '=' <+> ppExpr value <> char ';'+    PreprocInclude hdr -> bare $+        text "#include" <+> ppLexeme hdr+    PreprocDefine name -> bare $+        text "#define" <+> ppLexeme name+    PreprocDefineConst name value -> bare $+        text "#define" <+> ppLexeme name <+> fst value+    PreprocDefineMacro name params body -> bare $+        text "#define" <+> ppLexeme name <> ppMacroParamList params <+> fst body+    PreprocUndef name -> bare $+        text "#undef" <+> ppLexeme name -    Event name ty ->+    PreprocIf cond decls elseBranch -> bare $+        text "#if" <+> fst cond <$>+        ppSemiSep decls <>+        fst elseBranch <$>+        text "#endif"+    PreprocIfdef name decls elseBranch -> bare $+        text "#ifdef" <+> ppLexeme name <$>+        ppSemiSep decls <>+        fst elseBranch <$>+        text "#endif"+    PreprocIfndef name decls elseBranch -> bare $+        text "#ifndef" <+> ppLexeme name <$>+        ppSemiSep decls <>+        fst elseBranch <$>+        text "#endif"+    PreprocElse [] -> bare $ empty+    PreprocElse decls -> bare $+        linebreak <>+        text "#else" <$>+        ppSemiSep decls+    PreprocElif cond decls elseBranch -> bare $+        text "#elif" <+> fst cond <$>+        ppSemiSep decls <>+        fst elseBranch <$>+        text "#endif"++    FunctionParam ty dspec -> bare $ fst ty <+> fst dspec+    FunctionPrototype ty name params -> bare $+        ppFunctionPrototype ty name params+    FunctionDecl scope proto -> semi $+        ppScope scope <> fst proto+    FunctionDefn scope proto body -> bare $+        ppScope scope <> fst proto <+> fst body++    MemberDecl ty dspec Nothing -> semi $+        fst ty <+> fst dspec+    MemberDecl ty dspec (Just size) -> semi $+        fst ty <+> fst dspec <+> char ':' <+> ppLexeme size++    Struct name members -> semi $         nest 2 (-            text "event" <+> ppLexeme name <+> char '{' <$>-            ppEventType ty+            text "struct" <+> ppLexeme name <+> char '{' <$>+            ppSemiSep members         ) <$> char '}'--    Property ty dspec accessors ->+    Union name members -> semi $         nest 2 (-            ppType ty <+> ppDeclSpec dspec <+> char '{' <$>-            ppAccessorList accessors+            text "union" <+> ppLexeme name <+> char '{' <$>+            ppSemiSep members         ) <$> char '}'+    Typedef ty tyname -> semi $+        text "typedef" <+> fst ty <+> ppLexeme tyname+    TypedefFunction proto -> semi $+        text "typedef" <+> fst proto -    ErrorDecl name errs ->+    ConstDecl ty name -> semi $+        text "extern const" <+> fst ty <+> ppLexeme name+    ConstDefn scope ty name value -> semi $+        ppScope scope <> text "const" <+>+        fst ty <+> ppLexeme name <+> char '=' <+> fst value++    Enumerator name  Nothing -> bare $ ppLexeme name <> char ','+    Enumerator name (Just value) -> bare $+        ppLexeme name <+> char '=' <+> fst value <> char ','++    EnumConsts Nothing enums -> semi $         nest 2 (-            text "error for" <+> ppLexeme name <+> char '{' <$>-            ppEnumeratorList errs+            text "enum" <+> char '{' <$>+            ppLineSep enums         ) <$> char '}'+    EnumConsts (Just name) enums -> semi $+        nest 2 (+            text "enum" <+> ppLexeme name <+> char '{' <$>+            ppLineSep enums+        ) <$> char '}'+    EnumDecl name enums ty -> semi $+        nest 2 (+            text "typedef enum" <+> ppLexeme name <+> char '{' <$>+            ppLineSep enums+        ) <$> text "} " <> ppLexeme ty      -- 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 t e       -> ppIfStmt cond t e-    ForStmt i c n 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    body -> ppWhileStmt c body-    DoWhileStmt 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 ';'+    VarDecl ty declr   -> semi $ fst ty <+> fst declr+    Return Nothing     -> semi $ text "return"+    Return (Just e)    -> semi $ text "return" <+> fst e+    Continue           -> semi $ text "continue"+    Break              -> semi $ text "break"+    IfStmt cond t e    -> bare $ ppIfStmt cond t e+    ForStmt i c n body -> bare $ ppForStmt i c n body+    Default s          -> cp s $ text "default:" <+> fst s+    Label l s          -> bare $ ppLexeme l <> char ':' <$> fst s+    Goto l             -> semi $ text "goto " <> ppLexeme l+    Case e s           -> cp s $ text "case " <> fst e <> char ':' <+> fst s+    WhileStmt c body   -> bare $ ppWhileStmt c body+    DoWhileStmt body c -> semi $ ppDoWhileStmt body c+    SwitchStmt c body  -> bare $ ppSwitchStmt c body+    CompoundStmt body  -> bare $ ppCompoundStmt body+    VLA ty n sz        -> semi $ ppVLA ty n sz  -ppVLA :: Show a => Node a (Lexeme Text) -> Lexeme Text -> Node a (Lexeme Text) -> Doc-ppVLA ty n sz =-    text "VLA("-        <> ppType ty-        <> text ", "-        <> ppLexeme n-        <> text ", "-        <> ppExpr sz-        <> text ");"--ppTranslationUnit :: Show a => [Node a (Lexeme Text)] -> Doc-ppTranslationUnit decls = ppDeclList decls <> linebreak+ppTranslationUnit :: [Node (Lexeme Text)] -> Doc+ppTranslationUnit decls = ppSemiSep (map ppNode decls) <> linebreak

@@ -10,7 +10,7 @@ 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 @@   data Program text = Program-  { progAsts     :: Map FilePath [Node () (Lexeme text)]+  { progAsts     :: Map FilePath [Node (Lexeme text)]   , progIncludes :: Graph () FilePath   } 

@@ -6,9 +6,10 @@  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 @@     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     }

@@ -12,38 +12,30 @@     | IdFuncType     | IdStdType     | IdSueType-    | IdTyVar     | IdVar-    | KwBitmask     | KwBreak     | KwCase-    | KwClass     | KwConst     | KwContinue     | KwDefault     | KwDo     | KwElse     | KwEnum-    | KwError-    | KwEvent     | KwExtern     | KwFor     | KwGoto     | KwIf-    | KwNamespace     | KwReturn     | KwSizeof     | KwStatic     | KwStaticAssert     | KwStruct     | KwSwitch-    | KwThis     | KwTypedef     | KwUnion     | KwVla     | KwVoid     | KwWhile-    | KwWith     | LitFalse     | LitTrue     | LitChar

@@ -6,4 +6,4 @@ import           Language.Cimple.AST   (Node) import           Language.Cimple.Lexer (Lexeme) -type TranslationUnit text = (FilePath, [Node () (Lexeme text)])+type TranslationUnit text = (FilePath, [Node (Lexeme text)])

@@ -6,305 +6,278 @@ {-# LANGUAGE RecordWildCards       #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE StrictData            #-}+{-# LANGUAGE TypeFamilies          #-} module Language.Cimple.TraverseAst-    ( mapAst, traverseAst+    ( traverseAst      , doFiles, doFile     , 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 b where-    mapAst :: Applicative f => AstActions f iattr oattr itext otext -> a -> f b+class TraverseAst itext otext a where+    type Mapped itext otext a+    mapFileAst+        :: Applicative f+        => AstActions f itext otext+        -> FilePath+        -> a+        -> f (Mapped itext otext a)  traverseAst-    :: (TraverseAst iattr oattr itext otext a a, Applicative f)-    => AstActions f iattr oattr itext otext -> a -> f a-traverseAst = mapAst+    :: (TraverseAst itext otext    a, Applicative f)+    => AstActions f itext otext -> a+    -> f    (Mapped itext otext    a)+traverseAst = flip mapFileAst "<stdin>" -data AstActions f iattr oattr itext otext = AstActions-    { currentFile :: FilePath-    , 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         b-      => TraverseAst iattr oattr itext otext (Maybe a) (Maybe b) where-    mapAst _       Nothing  = pure Nothing-    mapAst actions (Just x) = Just <$> mapAst actions x+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-    { currentFile = "<stdin>"-    , doFiles     = const id+    => (itext -> f otext)+    -> AstActions f itext otext+astActions ft = AstActions+    { doFiles     = const id     , doFile      = const id     , doNodes     = const $ const id     , doNode      = const $ const id     , 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 attr itext otext = AstActions f attr attr itext otext-textActions :: Applicative f => (itext -> f otext) -> TextActions f attr itext otext-textActions = astActions pure+type TextActions f itext otext = AstActions f itext otext+textActions :: Applicative f => (itext -> f otext) -> TextActions f itext otext+textActions = astActions -type IdentityActions f attr text = AstActions f attr attr text text-identityActions :: Applicative f => AstActions f attr attr text text-identityActions = astActions pure pure+type IdentityActions f text = AstActions f text text+identityActions :: Applicative f => AstActions f text text+identityActions = astActions pure  -instance TraverseAst iattr oattr itext otext itext otext where-    mapAst AstActions{..} = doText currentFile--instance TraverseAst iattr oattr itext otext iattr oattr where-    mapAst AstActions{..} = doAttr currentFile--instance TraverseAst iattr oattr itext otext (Lexeme itext)-                                             (Lexeme otext) where-    mapAst :: forall f . Applicative f-           => AstActions f iattr oattr itext otext -> Lexeme itext -> f (Lexeme otext)-    mapAst actions@AstActions{..} = doLexeme currentFile <*>-        \(L p c s) -> L p c <$> recurse s-      where-        recurse :: TraverseAst iattr oattr itext otext a b => a -> f b-        recurse = mapAst actions+instance TraverseAst itext otext (Lexeme itext) where+    type Mapped itext otext (Lexeme itext)+                          =  Lexeme otext+    mapFileAst :: forall f . Applicative f+               => 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]-                                             [Lexeme otext] where-    mapAst actions@AstActions{..} = doLexemes currentFile <*>-        traverse (mapAst actions)+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))-                                             (Node oattr (Lexeme otext)) where-    mapAst :: forall f . Applicative f-           => AstActions f iattr oattr itext otext -> Node iattr (Lexeme itext) -> f (Node oattr (Lexeme otext))-    mapAst actions@AstActions{..} = doNode currentFile <*> \case-        Attr attr node ->-            Attr <$> recurse attr <*> recurse node+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 itext otext+        -> FilePath+        ->    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-        CommentWord word ->-            CommentWord <$> recurse word-        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-        EnumClass name members ->-            EnumClass <$> recurse name <*> recurse members+            Fix <$> (CommentExpr <$> recurse comment <*> recurse expr)         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-        Namespace scope name members ->-            Namespace scope <$> recurse name <*> recurse members-        Class scope name tyvars members ->-            Class scope <$> recurse name <*> recurse tyvars <*> recurse members-        ClassForward name tyvars ->-            ClassForward <$> recurse name <*> recurse tyvars+            Fix <$> (TypedefFunction <$> recurse ty)         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-        TyVar name ->-            TyVar <$> recurse name+            Fix <$> (TyFunc <$> recurse name)         TyStd name ->-            TyStd <$> recurse name+            Fix <$> (TyStd <$> recurse name)         TyUserDefined name ->-            TyUserDefined <$> recurse name-        FunctionDecl scope proto errors ->-            FunctionDecl scope <$> recurse proto <*> recurse errors+            Fix <$> (TyUserDefined <$> recurse name)+        FunctionDecl scope proto ->+            Fix <$> (FunctionDecl scope <$> recurse proto)         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-        Event name params ->-            Event <$> recurse name <*> recurse params-        EventParams params ->-            EventParams <$> recurse params-        Property ty decl accessors ->-            Property <$> recurse ty <*> recurse decl <*> recurse accessors-        Accessor name params errors ->-            Accessor <$> recurse name <*> recurse params <*> recurse errors-        ErrorDecl name errors ->-            ErrorDecl <$> recurse name <*> recurse errors-        ErrorList errors ->-            ErrorList <$> recurse errors-        ErrorFor name ->-            ErrorFor <$> recurse name+            Fix <$> (FunctionParam <$> recurse ty <*> recurse decl)         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 b => a -> f b-        recurse = mapAst actions+        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)]-                                             [Node oattr (Lexeme otext)] where-    mapAst actions@AstActions{..} = doNodes currentFile <*>-        traverse (mapAst actions)+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)])-                                             (FilePath, [Node oattr (Lexeme otext)]) where-    mapAst actions@AstActions{doFile} tu@(currentFile, _) = doFile <*>-        traverse (mapAst actions{currentFile}) $ tu+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)])]-                                             [(FilePath, [Node oattr (Lexeme otext)])] where-    mapAst actions@AstActions{..} = doFiles <*>-        traverse (mapAst actions)+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)

@@ -6,8 +6,9 @@     , 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,116 +21,103 @@ %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{} }-    commentWord		{ CommentWord{} }-    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{}) }     -- 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{} }+    enumConsts		{ Fix (EnumConsts{}) }+    enumDecl		{ Fix (EnumDecl{}) }+    enumerator		{ Fix (Enumerator{}) }+    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{}) }+    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{}) }+    ellipsis		{ Fix (Ellipsis) }     -- Constants-    constDecl		{ ConstDecl{} }-    constDefn		{ ConstDefn{} }+    constDecl		{ Fix (ConstDecl{}) }+    constDefn		{ Fix (ConstDefn{}) }  %% @@ -189,7 +177,7 @@ Decl :	comment							{ $1 } |	CommentableDecl						{ $1 }-|	docComment CommentableDecl				{ Commented $1 $2 }+|	docComment CommentableDecl				{ Fix $ Commented $1 $2 }  CommentableDecl :: { TextNode } CommentableDecl@@ -214,7 +202,7 @@  { type TextLexeme = Lexeme Text-type TextNode = Node () TextLexeme+type TextNode = Node TextLexeme  newtype TreeParser a = TreeParser { toEither :: Either String a }     deriving (Functor, Applicative, Monad)@@ -224,41 +212,41 @@   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 $ "TreeParser.recurse: " <> show ns   parseError :: ([TextNode], [String]) -> TreeParser a

@@ -35,8 +35,7 @@         it "pretty-prints a simple C function" $ do             let pp = pretty "int a(void) { return 3; }"             pp `shouldBe` unlines-                [ "int a(void)"-                , "{"+                [ "int a(void) {"                 , "  return 3;"                 , "}"                 ]@@ -53,8 +52,7 @@         it "pretty-prints a simple C function" $ do             let pp = compact "int a(void) { return 3; }"             pp `shouldBe` unlines-                [ "int a(void)"-                , "{"+                [ "int a(void) {"                 , "return 3;"                 , "}"                 ]@@ -93,18 +91,13 @@             compact "void foo(int const *a);"                 `shouldBe` "void foo(int const* a);\n" -        it "supports type-variables" $ do-            compact "void foo(`a a);" `shouldBe` "void foo(`a a);\n"-            compact "`a id(const `a a) { return a; }"-                `shouldBe` "`a id(`a const a)\n{\nreturn a;\n}\n"-         it "formats expressions and statements" $ do             compact "void foo() { return 1+2*3/4; }"-                `shouldBe` "void foo()\n{\nreturn 1 + 2 * 3 / 4;\n}\n"+                `shouldBe` "void foo() {\nreturn 1 + 2 * 3 / 4;\n}\n"             compact "void foo() { a = ~b << !c; }"-                `shouldBe` "void foo()\n{\na = ~b << !c;\n}\n"+                `shouldBe` "void foo() {\na = ~b << !c;\n}\n"             compact "void foo() { int a[] = {1,2,3}; }"-                `shouldBe` "void foo()\n{\nint a[] = { 1, 2, 3 };\n}\n"+                `shouldBe` "void foo() {\nint a[] = { 1, 2, 3 };\n}\n"          it "supports variadic functions" $ do             compact "void foo(int a, ...);"

@@ -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, mapAst, textActions)+                                     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`-                mapAst 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")]-                      )-                      [ 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 "/*")-                          [CommentWord (L (AlexPn 3 1 4) CmtWord "hello")]-                          (L (AlexPn 9 1 10) CmtEnd "*/")+                          [L (AlexPn 3 1 4) CmtWord "hello"]+                          (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")                           []-                      )-                      [ 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