diff --git a/cimple.cabal b/cimple.cabal --- a/cimple.cabal +++ b/cimple.cabal @@ -1,5 +1,5 @@ name: cimple -version: 0.0.11 +version: 0.0.12 synopsis: Simple C-like programming language homepage: https://toktok.github.io/ license: GPL-3 @@ -37,6 +37,7 @@ , Language.Cimple.Flatten , Language.Cimple.Graph , Language.Cimple.Lexer + , Language.Cimple.MapAst , Language.Cimple.Parser , Language.Cimple.SemCheck.Includes , Language.Cimple.Tokens @@ -53,6 +54,7 @@ , data-fix , filepath , groom + , monad-parallel , mtl , recursion-schemes , text diff --git a/src/Language/Cimple.hs b/src/Language/Cimple.hs --- a/src/Language/Cimple.hs +++ b/src/Language/Cimple.hs @@ -5,16 +5,16 @@ , removeSloc ) where -import Control.Monad.State.Strict (State) -import qualified Control.Monad.State.Strict as State -import Data.Text (Text) +import Control.Monad.State.Strict (State) +import qualified Control.Monad.State.Strict as State +import Data.Text (Text) -import Language.Cimple.Annot as X -import Language.Cimple.Ast as X -import Language.Cimple.Lexer as X -import Language.Cimple.Parser as X -import Language.Cimple.Tokens as X -import Language.Cimple.TraverseAst as X +import Language.Cimple.Annot as X +import Language.Cimple.Ast as X +import Language.Cimple.Lexer as X +import Language.Cimple.MapAst as X +import Language.Cimple.Parser as X +import Language.Cimple.Tokens as X type DefaultActions a = X.IdentityActions (State a) Text @@ -23,5 +23,5 @@ removeSloc :: Node (Lexeme Text) -> Node (Lexeme Text) removeSloc = - flip State.evalState () . traverseAst defaultActions + flip State.evalState () . mapAst defaultActions { doLexeme = \_ (L _ c t) _ -> pure $ L (AlexPn 0 0 0) c t } diff --git a/src/Language/Cimple/IO.hs b/src/Language/Cimple/IO.hs --- a/src/Language/Cimple/IO.hs +++ b/src/Language/Cimple/IO.hs @@ -8,6 +8,7 @@ ) where import Control.Monad ((>=>)) +import qualified Control.Monad.Parallel as P import Control.Monad.State.Strict (State, evalState, get, put) import qualified Data.ByteString as BS import Data.Map.Strict (Map) @@ -17,12 +18,12 @@ import qualified Data.Text.Encoding as Text import Language.Cimple.Ast (Node) import Language.Cimple.Lexer (Lexeme, runAlex) +import Language.Cimple.MapAst (TextActions, mapAst, + textActions) 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, textActions, - traverseAst) import qualified Language.Cimple.TreeParser as TreeParser type StringNode = Node (Lexeme String) @@ -30,7 +31,7 @@ toTextAst :: [StringNode] -> [TextNode] toTextAst stringAst = - evalState (traverseAst cacheActions stringAst) Map.empty + evalState (mapAst cacheActions stringAst) Map.empty where cacheActions :: TextActions (State (Map String Text)) String Text cacheActions = textActions $ \s -> do @@ -65,7 +66,7 @@ parseFiles' :: [FilePath] -> IO (Either String [TranslationUnit Text]) -parseFiles' sources = sequenceA <$> traverse parseFile sources +parseFiles' sources = sequenceA <$> P.mapM parseFile sources parseFiles :: [FilePath] -> IO (Either String [TranslationUnit Text]) diff --git a/src/Language/Cimple/MapAst.hs b/src/Language/Cimple/MapAst.hs new file mode 100644 --- /dev/null +++ b/src/Language/Cimple/MapAst.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Strict #-} +{-# LANGUAGE StrictData #-} +{-# LANGUAGE TypeFamilies #-} +module Language.Cimple.MapAst + ( mapAst + + , doFiles, doFile + , doNodes, doNode + , doLexemes, doLexeme + , doText + + , astActions + , TextActions, textActions + , IdentityActions, identityActions + ) where + +import Data.Fix (Fix (..)) +import Language.Cimple.Ast (Node, NodeF (..)) +import Language.Cimple.Lexer (Lexeme (..)) + +class MapAst itext otext a where + type Mapped itext otext a + mapFileAst + :: Applicative f + => AstActions f itext otext + -> FilePath + -> a + -> f (Mapped itext otext a) + +mapAst + :: (MapAst itext otext a, Applicative f) + => AstActions f itext otext -> a + -> f (Mapped itext otext a) +mapAst = flip mapFileAst "" + +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 MapAst itext otext a + => MapAst 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 + => (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 + } + +type TextActions f itext otext = AstActions f itext otext +textActions :: Applicative f => (itext -> f otext) -> TextActions f itext otext +textActions = astActions + +type IdentityActions f text = AstActions f text text +identityActions :: Applicative f => AstActions f text text +identityActions = astActions pure + + +instance MapAst 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 MapAst itext otext [Lexeme itext] where + type Mapped itext otext [Lexeme itext] + = [Lexeme otext] + mapFileAst actions@AstActions{..} currentFile = doLexemes currentFile <*> + traverse (mapFileAst actions currentFile) + +instance MapAst 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 -> + Fix <$> (PreprocInclude <$> recurse path) + PreprocDefine name -> + Fix <$> (PreprocDefine <$> recurse name) + PreprocDefineConst name value -> + Fix <$> (PreprocDefineConst <$> recurse name <*> recurse value) + PreprocDefineMacro name params body -> + Fix <$> (PreprocDefineMacro <$> recurse name <*> recurse params <*> recurse body) + PreprocIf cond thenDecls elseBranch -> + Fix <$> (PreprocIf <$> recurse cond <*> recurse thenDecls <*> recurse elseBranch) + PreprocIfdef name thenDecls elseBranch -> + Fix <$> (PreprocIfdef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch) + PreprocIfndef name thenDecls elseBranch -> + Fix <$> (PreprocIfndef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch) + PreprocElse decls -> + Fix <$> (PreprocElse <$> recurse decls) + PreprocElif cond decls elseBranch -> + Fix <$> (PreprocElif <$> recurse cond <*> recurse decls <*> recurse elseBranch) + PreprocUndef name -> + Fix <$> (PreprocUndef <$> recurse name) + PreprocDefined name -> + Fix <$> (PreprocDefined <$> recurse name) + PreprocScopedDefine define stmts undef -> + Fix <$> (PreprocScopedDefine <$> recurse define <*> recurse stmts <*> recurse undef) + MacroBodyStmt stmts -> + Fix <$> (MacroBodyStmt <$> recurse stmts) + MacroBodyFunCall expr -> + Fix <$> (MacroBodyFunCall <$> recurse expr) + MacroParam name -> + Fix <$> (MacroParam <$> recurse name) + StaticAssert cond msg -> + Fix <$> (StaticAssert <$> recurse cond <*> recurse msg) + LicenseDecl license copyrights -> + Fix <$> (LicenseDecl <$> recurse license <*> recurse copyrights) + CopyrightDecl from to owner -> + Fix <$> (CopyrightDecl <$> recurse from <*> recurse to <*> recurse owner) + Comment doc start contents end -> + Fix <$> (Comment doc <$> recurse start <*> recurse contents <*> recurse end) + CommentBlock comment -> + Fix <$> (CommentBlock <$> recurse comment) + Commented comment subject -> + Fix <$> (Commented <$> recurse comment <*> recurse subject) + ExternC decls -> + Fix <$> (ExternC <$> recurse decls) + CompoundStmt stmts -> + Fix <$> (CompoundStmt <$> recurse stmts) + Break -> + pure $ Fix Break + Goto label -> + Fix <$> (Goto <$> recurse label) + Continue -> + pure $ Fix Continue + Return value -> + Fix <$> (Return <$> recurse value) + SwitchStmt value cases -> + Fix <$> (SwitchStmt <$> recurse value <*> recurse cases) + IfStmt cond thenStmts elseStmt -> + Fix <$> (IfStmt <$> recurse cond <*> recurse thenStmts <*> recurse elseStmt) + ForStmt initStmt cond next stmts -> + Fix <$> (ForStmt <$> recurse initStmt <*> recurse cond <*> recurse next <*> recurse stmts) + WhileStmt cond stmts -> + Fix <$> (WhileStmt <$> recurse cond <*> recurse stmts) + DoWhileStmt stmts cond -> + Fix <$> (DoWhileStmt <$> recurse stmts <*> recurse cond) + Case value stmt -> + Fix <$> (Case <$> recurse value <*> recurse stmt) + Default stmt -> + Fix <$> (Default <$> recurse stmt) + Label label stmt -> + Fix <$> (Label <$> recurse label <*> recurse stmt) + VLA ty name size -> + Fix <$> (VLA <$> recurse ty <*> recurse name <*> recurse size) + VarDeclStmt decl ini -> + Fix <$> (VarDeclStmt <$> recurse decl <*> recurse ini) + VarDecl ty name arrs -> + Fix <$> (VarDecl <$> recurse ty <*> recurse name <*> recurse arrs) + DeclSpecArray size -> + Fix <$> (DeclSpecArray <$> recurse size) + InitialiserList values -> + Fix <$> (InitialiserList <$> recurse values) + UnaryExpr op expr -> + Fix <$> (UnaryExpr op <$> recurse expr) + BinaryExpr lhs op rhs -> + Fix <$> (BinaryExpr <$> recurse lhs <*> pure op <*> recurse rhs) + TernaryExpr cond thenExpr elseExpr -> + Fix <$> (TernaryExpr <$> recurse cond <*> recurse thenExpr <*> recurse elseExpr) + AssignExpr lhs op rhs -> + Fix <$> (AssignExpr <$> recurse lhs <*> pure op <*> recurse rhs) + ParenExpr expr -> + Fix <$> (ParenExpr <$> recurse expr) + CastExpr ty expr -> + Fix <$> (CastExpr <$> recurse ty <*> recurse expr) + CompoundExpr ty expr -> + Fix <$> (CompoundExpr <$> recurse ty <*> recurse expr) + SizeofExpr expr -> + Fix <$> (SizeofExpr <$> recurse expr) + SizeofType ty -> + Fix <$> (SizeofType <$> recurse ty) + LiteralExpr ty value -> + Fix <$> (LiteralExpr ty <$> recurse value) + VarExpr name -> + Fix <$> (VarExpr <$> recurse name) + MemberAccess name field -> + Fix <$> (MemberAccess <$> recurse name <*> recurse field) + PointerAccess name field -> + Fix <$> (PointerAccess <$> recurse name <*> recurse field) + ArrayAccess arr idx -> + Fix <$> (ArrayAccess <$> recurse arr <*> recurse idx) + FunctionCall callee args -> + Fix <$> (FunctionCall <$> recurse callee <*> recurse args) + CommentExpr comment expr -> + Fix <$> (CommentExpr <$> recurse comment <*> recurse expr) + EnumConsts name members -> + Fix <$> (EnumConsts <$> recurse name <*> recurse members) + EnumDecl name members tyName -> + Fix <$> (EnumDecl <$> recurse name <*> recurse members <*> recurse tyName) + Enumerator name value -> + Fix <$> (Enumerator <$> recurse name <*> recurse value) + Typedef ty name -> + Fix <$> (Typedef <$> recurse ty <*> recurse name) + TypedefFunction ty -> + Fix <$> (TypedefFunction <$> recurse ty) + Struct name members -> + Fix <$> (Struct <$> recurse name <*> recurse members) + Union name members -> + Fix <$> (Union <$> recurse name <*> recurse members) + MemberDecl decl bits -> + Fix <$> (MemberDecl <$> recurse decl <*> recurse bits) + TyConst ty -> + Fix <$> (TyConst <$> recurse ty) + TyPointer ty -> + Fix <$> (TyPointer <$> recurse ty) + TyStruct name -> + Fix <$> (TyStruct <$> recurse name) + TyFunc name -> + Fix <$> (TyFunc <$> recurse name) + TyStd name -> + Fix <$> (TyStd <$> recurse name) + TyUserDefined name -> + Fix <$> (TyUserDefined <$> recurse name) + FunctionDecl scope proto -> + Fix <$> (FunctionDecl scope <$> recurse proto) + FunctionDefn scope proto body -> + Fix <$> (FunctionDefn scope <$> recurse proto <*> recurse body) + FunctionPrototype ty name params -> + Fix <$> (FunctionPrototype <$> recurse ty <*> recurse name <*> recurse params) + Ellipsis -> + pure $ Fix Ellipsis + ConstDecl ty name -> + Fix <$> (ConstDecl <$> recurse ty <*> recurse name) + ConstDefn scope ty name value -> + Fix <$> (ConstDefn scope <$> recurse ty <*> recurse name <*> recurse value) + + where + recurse :: MapAst itext otext a => a -> f (Mapped itext otext a) + recurse = mapFileAst actions currentFile + +instance MapAst 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 MapAst 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 MapAst itext otext [(FilePath, [Node (Lexeme itext)])] where + type Mapped itext otext [(FilePath, [Node (Lexeme itext)])] + = [(FilePath, [Node (Lexeme otext)])] + mapFileAst actions@AstActions{..} currentFile = doFiles <*> + traverse (mapFileAst actions currentFile) diff --git a/src/Language/Cimple/SemCheck/Includes.hs b/src/Language/Cimple/SemCheck/Includes.hs --- a/src/Language/Cimple/SemCheck/Includes.hs +++ b/src/Language/Cimple/SemCheck/Includes.hs @@ -12,10 +12,10 @@ import qualified Data.Text as Text import Language.Cimple.Ast (NodeF (..)) import Language.Cimple.Lexer (Lexeme (..)) +import Language.Cimple.MapAst (IdentityActions, doNode, + identityActions, mapAst) import Language.Cimple.Tokens (LexemeClass (..)) import Language.Cimple.TranslationUnit (TranslationUnit) -import Language.Cimple.TraverseAst (IdentityActions, doNode, - identityActions, traverseAst) import System.FilePath (joinPath, splitPath, takeDirectory) @@ -59,4 +59,4 @@ normaliseIncludes (file, ast) = ((file, ast'), includes) where - (ast', includes) = State.runState (traverseAst (normaliseIncludes' (takeDirectory file)) ast) [] + (ast', includes) = State.runState (mapAst (normaliseIncludes' (takeDirectory file)) ast) [] diff --git a/src/Language/Cimple/TraverseAst.hs b/src/Language/Cimple/TraverseAst.hs --- a/src/Language/Cimple/TraverseAst.hs +++ b/src/Language/Cimple/TraverseAst.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -14,265 +15,372 @@ , doLexemes, doLexeme , doText - , astActions - , TextActions, textActions - , IdentityActions, identityActions + , astActions, AstActions ) where import Data.Fix (Fix (..)) +import Data.Foldable (traverse_) import Language.Cimple.Ast (Node, NodeF (..)) import Language.Cimple.Lexer (Lexeme (..)) -class TraverseAst itext otext a where - type Mapped itext otext a - mapFileAst +class TraverseAst text a where + traverseFileAst :: Applicative f - => AstActions f itext otext + => AstActions f text -> FilePath -> a - -> f (Mapped itext otext a) + -> f () traverseAst - :: (TraverseAst itext otext a, Applicative f) - => AstActions f itext otext -> a - -> f (Mapped itext otext a) -traverseAst = flip mapFileAst "" + :: (TraverseAst text a, Applicative f) + => AstActions f text -> a + -> f () +traverseAst = flip traverseFileAst "" -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 +data AstActions f text = AstActions + { doFiles :: [(FilePath, [Node (Lexeme text)])] -> f () -> f () + , doFile :: (FilePath, [Node (Lexeme text)]) -> f () -> f () + , doNodes :: FilePath -> [Node (Lexeme text)] -> f () -> f () + , doNode :: FilePath -> Node (Lexeme text) -> f () -> f () + , doLexemes :: FilePath -> [Lexeme text] -> f () -> f () + , doLexeme :: FilePath -> Lexeme text -> f () -> f () + , doText :: FilePath -> text -> f () } -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 +instance TraverseAst text a + => TraverseAst text (Maybe a) where + traverseFileAst _ _ _ = pure () astActions :: Applicative f - => (itext -> f otext) - -> AstActions f itext otext -astActions ft = AstActions + => AstActions f text +astActions = 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 + , doText = const $ const $ 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 text = AstActions f text text -identityActions :: Applicative f => AstActions f text text -identityActions = astActions pure - - -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 text (Lexeme text) where + traverseFileAst :: forall f . Applicative f + => AstActions f text -> FilePath -> Lexeme text -> f () + traverseFileAst AstActions{..} currentFile = doLexeme currentFile <*> + \(L _ _ s) -> doText currentFile s -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 text [Lexeme text] where + traverseFileAst actions@AstActions{..} currentFile = doLexemes currentFile <*> + traverse_ (traverseFileAst actions currentFile) -instance TraverseAst itext otext (Node (Lexeme itext)) where - type Mapped itext otext (Node (Lexeme itext)) - = Node (Lexeme otext) - mapFileAst +instance TraverseAst text (Node (Lexeme text)) where + traverseFileAst :: forall f . Applicative f - => AstActions f itext otext + => AstActions f text -> FilePath - -> Node (Lexeme itext) - -> f (Node (Lexeme otext)) - mapFileAst actions@AstActions{..} currentFile = doNode currentFile <*> \node -> case unFix node of - PreprocInclude path -> - Fix <$> (PreprocInclude <$> recurse path) - PreprocDefine name -> - Fix <$> (PreprocDefine <$> recurse name) - PreprocDefineConst name value -> - Fix <$> (PreprocDefineConst <$> recurse name <*> recurse value) - PreprocDefineMacro name params body -> - Fix <$> (PreprocDefineMacro <$> recurse name <*> recurse params <*> recurse body) - PreprocIf cond thenDecls elseBranch -> - Fix <$> (PreprocIf <$> recurse cond <*> recurse thenDecls <*> recurse elseBranch) - PreprocIfdef name thenDecls elseBranch -> - Fix <$> (PreprocIfdef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch) - PreprocIfndef name thenDecls elseBranch -> - Fix <$> (PreprocIfndef <$> recurse name <*> recurse thenDecls <*> recurse elseBranch) - PreprocElse decls -> - Fix <$> (PreprocElse <$> recurse decls) - PreprocElif cond decls elseBranch -> - Fix <$> (PreprocElif <$> recurse cond <*> recurse decls <*> recurse elseBranch) - PreprocUndef name -> - Fix <$> (PreprocUndef <$> recurse name) - PreprocDefined name -> - Fix <$> (PreprocDefined <$> recurse name) - PreprocScopedDefine define stmts undef -> - Fix <$> (PreprocScopedDefine <$> recurse define <*> recurse stmts <*> recurse undef) - MacroBodyStmt stmts -> - Fix <$> (MacroBodyStmt <$> recurse stmts) - MacroBodyFunCall expr -> - Fix <$> (MacroBodyFunCall <$> recurse expr) - MacroParam name -> - Fix <$> (MacroParam <$> recurse name) - StaticAssert cond msg -> - Fix <$> (StaticAssert <$> recurse cond <*> recurse msg) - LicenseDecl license copyrights -> - Fix <$> (LicenseDecl <$> recurse license <*> recurse copyrights) - CopyrightDecl from to owner -> - Fix <$> (CopyrightDecl <$> recurse from <*> recurse to <*> recurse owner) - Comment doc start contents end -> - Fix <$> (Comment doc <$> recurse start <*> recurse contents <*> recurse end) - CommentBlock comment -> - Fix <$> (CommentBlock <$> recurse comment) - Commented comment subject -> - Fix <$> (Commented <$> recurse comment <*> recurse subject) - ExternC decls -> - Fix <$> (ExternC <$> recurse decls) - CompoundStmt stmts -> - Fix <$> (CompoundStmt <$> recurse stmts) + -> Node (Lexeme text) + -> f () + traverseFileAst actions@AstActions{..} currentFile = doNode currentFile <*> \node -> case unFix node of + PreprocInclude path -> do + _ <- recurse path + pure () + PreprocDefine name -> do + _ <- recurse name + pure () + PreprocDefineConst name value -> do + _ <- recurse name + _ <- recurse value + pure () + PreprocDefineMacro name params body -> do + _ <- recurse name + _ <- recurse params + _ <- recurse body + pure () + PreprocIf cond thenDecls elseBranch -> do + _ <- recurse cond + _ <- recurse thenDecls + _ <- recurse elseBranch + pure () + PreprocIfdef name thenDecls elseBranch -> do + _ <- recurse name + _ <- recurse thenDecls + _ <- recurse elseBranch + pure () + PreprocIfndef name thenDecls elseBranch -> do + _ <- recurse name + _ <- recurse thenDecls + _ <- recurse elseBranch + pure () + PreprocElse decls -> do + _ <- recurse decls + pure () + PreprocElif cond decls elseBranch -> do + _ <- recurse cond + _ <- recurse decls + _ <- recurse elseBranch + pure () + PreprocUndef name -> do + _ <- recurse name + pure () + PreprocDefined name -> do + _ <- recurse name + pure () + PreprocScopedDefine define stmts undef -> do + _ <- recurse define + _ <- recurse stmts + _ <- recurse undef + pure () + MacroBodyStmt stmts -> do + _ <- recurse stmts + pure () + MacroBodyFunCall expr -> do + _ <- recurse expr + pure () + MacroParam name -> do + _ <- recurse name + pure () + StaticAssert cond msg -> do + _ <- recurse cond + _ <- recurse msg + pure () + LicenseDecl license copyrights -> do + _ <- recurse license + _ <- recurse copyrights + pure () + CopyrightDecl from to owner -> do + _ <- recurse from + _ <- recurse to + _ <- recurse owner + pure () + Comment _doc start contents end -> do + _ <- recurse start + _ <- recurse contents + _ <- recurse end + pure () + CommentBlock comment -> do + _ <- recurse comment + pure () + Commented comment subject -> do + _ <- recurse comment + _ <- recurse subject + pure () + ExternC decls -> do + _ <- recurse decls + pure () + CompoundStmt stmts -> do + _ <- recurse stmts + pure () Break -> - pure $ Fix Break - Goto label -> - Fix <$> (Goto <$> recurse label) + pure () + Goto label -> do + _ <- recurse label + pure () Continue -> - pure $ Fix Continue - Return value -> - Fix <$> (Return <$> recurse value) - SwitchStmt value cases -> - Fix <$> (SwitchStmt <$> recurse value <*> recurse cases) - IfStmt cond thenStmts elseStmt -> - Fix <$> (IfStmt <$> recurse cond <*> recurse thenStmts <*> recurse elseStmt) - ForStmt initStmt cond next stmts -> - Fix <$> (ForStmt <$> recurse initStmt <*> recurse cond <*> recurse next <*> recurse stmts) - WhileStmt cond stmts -> - Fix <$> (WhileStmt <$> recurse cond <*> recurse stmts) - DoWhileStmt stmts cond -> - Fix <$> (DoWhileStmt <$> recurse stmts <*> recurse cond) - Case value stmt -> - Fix <$> (Case <$> recurse value <*> recurse stmt) - Default stmt -> - Fix <$> (Default <$> recurse stmt) - Label label stmt -> - Fix <$> (Label <$> recurse label <*> recurse stmt) - VLA ty name size -> - Fix <$> (VLA <$> recurse ty <*> recurse name <*> recurse size) - VarDeclStmt decl ini -> - Fix <$> (VarDeclStmt <$> recurse decl <*> recurse ini) - VarDecl ty name arrs -> - Fix <$> (VarDecl <$> recurse ty <*> recurse name <*> recurse arrs) - DeclSpecArray size -> - Fix <$> (DeclSpecArray <$> recurse size) - InitialiserList values -> - Fix <$> (InitialiserList <$> recurse values) - UnaryExpr op expr -> - Fix <$> (UnaryExpr op <$> recurse expr) - BinaryExpr lhs op rhs -> - Fix <$> (BinaryExpr <$> recurse lhs <*> pure op <*> recurse rhs) - TernaryExpr cond thenExpr elseExpr -> - Fix <$> (TernaryExpr <$> recurse cond <*> recurse thenExpr <*> recurse elseExpr) - AssignExpr lhs op rhs -> - Fix <$> (AssignExpr <$> recurse lhs <*> pure op <*> recurse rhs) - ParenExpr expr -> - Fix <$> (ParenExpr <$> recurse expr) - CastExpr ty expr -> - Fix <$> (CastExpr <$> recurse ty <*> recurse expr) - CompoundExpr ty expr -> - Fix <$> (CompoundExpr <$> recurse ty <*> recurse expr) - SizeofExpr expr -> - Fix <$> (SizeofExpr <$> recurse expr) - SizeofType ty -> - Fix <$> (SizeofType <$> recurse ty) - LiteralExpr ty value -> - Fix <$> (LiteralExpr ty <$> recurse value) - VarExpr name -> - Fix <$> (VarExpr <$> recurse name) - MemberAccess name field -> - Fix <$> (MemberAccess <$> recurse name <*> recurse field) - PointerAccess name field -> - Fix <$> (PointerAccess <$> recurse name <*> recurse field) - ArrayAccess arr idx -> - Fix <$> (ArrayAccess <$> recurse arr <*> recurse idx) - FunctionCall callee args -> - Fix <$> (FunctionCall <$> recurse callee <*> recurse args) - CommentExpr comment expr -> - Fix <$> (CommentExpr <$> recurse comment <*> recurse expr) - EnumConsts name members -> - Fix <$> (EnumConsts <$> recurse name <*> recurse members) - EnumDecl name members tyName -> - Fix <$> (EnumDecl <$> recurse name <*> recurse members <*> recurse tyName) - Enumerator name value -> - Fix <$> (Enumerator <$> recurse name <*> recurse value) - Typedef ty name -> - Fix <$> (Typedef <$> recurse ty <*> recurse name) - TypedefFunction ty -> - Fix <$> (TypedefFunction <$> recurse ty) - Struct name members -> - Fix <$> (Struct <$> recurse name <*> recurse members) - Union name members -> - Fix <$> (Union <$> recurse name <*> recurse members) - MemberDecl decl bits -> - Fix <$> (MemberDecl <$> recurse decl <*> recurse bits) - TyConst ty -> - Fix <$> (TyConst <$> recurse ty) - TyPointer ty -> - Fix <$> (TyPointer <$> recurse ty) - TyStruct name -> - Fix <$> (TyStruct <$> recurse name) - TyFunc name -> - Fix <$> (TyFunc <$> recurse name) - TyStd name -> - Fix <$> (TyStd <$> recurse name) - TyUserDefined name -> - Fix <$> (TyUserDefined <$> recurse name) - FunctionDecl scope proto -> - Fix <$> (FunctionDecl scope <$> recurse proto) - FunctionDefn scope proto body -> - Fix <$> (FunctionDefn scope <$> recurse proto <*> recurse body) - FunctionPrototype ty name params -> - Fix <$> (FunctionPrototype <$> recurse ty <*> recurse name <*> recurse params) + pure () + Return value -> do + _ <- recurse value + pure () + SwitchStmt value cases -> do + _ <- recurse value + _ <- recurse cases + pure () + IfStmt cond thenStmts elseStmt -> do + _ <- recurse cond + _ <- recurse thenStmts + _ <- recurse elseStmt + pure () + ForStmt initStmt cond next stmts -> do + _ <- recurse initStmt + _ <- recurse cond + _ <- recurse next + _ <- recurse stmts + pure () + WhileStmt cond stmts -> do + _ <- recurse cond + _ <- recurse stmts + pure () + DoWhileStmt stmts cond -> do + _ <- recurse stmts + _ <- recurse cond + pure () + Case value stmt -> do + _ <- recurse value + _ <- recurse stmt + pure () + Default stmt -> do + _ <- recurse stmt + pure () + Label label stmt -> do + _ <- recurse label + _ <- recurse stmt + pure () + VLA ty name size -> do + _ <- recurse ty + _ <- recurse name + _ <- recurse size + pure () + VarDeclStmt decl ini -> do + _ <- recurse decl + _ <- recurse ini + pure () + VarDecl ty name arrs -> do + _ <- recurse ty + _ <- recurse name + _ <- recurse arrs + pure () + DeclSpecArray size -> do + _ <- recurse size + pure () + InitialiserList values -> do + _ <- recurse values + pure () + UnaryExpr _op expr -> do + _ <- recurse expr + pure () + BinaryExpr lhs _op rhs -> do + _ <- recurse lhs + _ <- recurse rhs + pure () + TernaryExpr cond thenExpr elseExpr -> do + _ <- recurse cond + _ <- recurse thenExpr + _ <- recurse elseExpr + pure () + AssignExpr lhs _op rhs -> do + _ <- recurse lhs + _ <- recurse rhs + pure () + ParenExpr expr -> do + _ <- recurse expr + pure () + CastExpr ty expr -> do + _ <- recurse ty + _ <- recurse expr + pure () + CompoundExpr ty expr -> do + _ <- recurse ty + _ <- recurse expr + pure () + SizeofExpr expr -> do + _ <- recurse expr + pure () + SizeofType ty -> do + _ <- recurse ty + pure () + LiteralExpr _ty value -> do + _ <- recurse value + pure () + VarExpr name -> do + _ <- recurse name + pure () + MemberAccess name field -> do + _ <- recurse name + _ <- recurse field + pure () + PointerAccess name field -> do + _ <- recurse name + _ <- recurse field + pure () + ArrayAccess arr idx -> do + _ <- recurse arr + _ <- recurse idx + pure () + FunctionCall callee args -> do + _ <- recurse callee + _ <- recurse args + pure () + CommentExpr comment expr -> do + _ <- recurse comment + _ <- recurse expr + pure () + EnumConsts name members -> do + _ <- recurse name + _ <- recurse members + pure () + EnumDecl name members tyName -> do + _ <- recurse name + _ <- recurse members + _ <- recurse tyName + pure () + Enumerator name value -> do + _ <- recurse name + _ <- recurse value + pure () + Typedef ty name -> do + _ <- recurse ty + _ <- recurse name + pure () + TypedefFunction ty -> do + _ <- recurse ty + pure () + Struct name members -> do + _ <- recurse name + _ <- recurse members + pure () + Union name members -> do + _ <- recurse name + _ <- recurse members + pure () + MemberDecl decl bits -> do + _ <- recurse decl + _ <- recurse bits + pure () + TyConst ty -> do + _ <- recurse ty + pure () + TyPointer ty -> do + _ <- recurse ty + pure () + TyStruct name -> do + _ <- recurse name + pure () + TyFunc name -> do + _ <- recurse name + pure () + TyStd name -> do + _ <- recurse name + pure () + TyUserDefined name -> do + _ <- recurse name + pure () + FunctionDecl _scope proto -> do + _ <- recurse proto + pure () + FunctionDefn _scope proto body -> do + _ <- recurse proto + _ <- recurse body + pure () + FunctionPrototype ty name params -> do + _ <- recurse ty + _ <- recurse name + _ <- recurse params + pure () Ellipsis -> - pure $ Fix Ellipsis - ConstDecl ty name -> - Fix <$> (ConstDecl <$> recurse ty <*> recurse name) - ConstDefn scope ty name value -> - Fix <$> (ConstDefn scope <$> recurse ty <*> recurse name <*> recurse value) + pure () + ConstDecl ty name -> do + _ <- recurse ty + _ <- recurse name + pure () + ConstDefn _scope ty name value -> do + _ <- recurse ty + _ <- recurse name + _ <- recurse value + pure () where - recurse :: TraverseAst itext otext a => a -> f (Mapped itext otext a) - recurse = mapFileAst actions currentFile + recurse :: TraverseAst text a => a -> f () + recurse = traverseFileAst actions currentFile -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 text [Node (Lexeme text)] where + traverseFileAst actions@AstActions{..} currentFile = doNodes currentFile <*> + traverse_ (traverseFileAst actions currentFile) -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 text (FilePath, [Node (Lexeme text)]) where + traverseFileAst actions@AstActions{..} _ tu@(currentFile, _) = doFile <*> + traverse_ (traverseFileAst 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{..} currentFile = doFiles <*> - traverse (mapFileAst actions currentFile) +instance TraverseAst text [(FilePath, [Node (Lexeme text)])] where + traverseFileAst actions@AstActions{..} currentFile = doFiles <*> + traverse_ (traverseFileAst actions currentFile)