From 9de4a3c99cda734eb74672758124350640d20562 Mon Sep 17 00:00:00 2001 From: Zachary Snow Date: Wed, 30 Jun 2021 19:13:44 -0400 Subject: [PATCH] simplify type and decl traversals --- src/Convert/Jump.hs | 11 +++-- src/Convert/Struct.hs | 14 +++--- src/Convert/Traverse.hs | 102 ++++++++++++++-------------------------- 3 files changed, 49 insertions(+), 78 deletions(-) diff --git a/src/Convert/Jump.hs b/src/Convert/Jump.hs index a20d2f8..d4242aa 100644 --- a/src/Convert/Jump.hs +++ b/src/Convert/Jump.hs @@ -85,11 +85,12 @@ addJumpStateDeclTF decls stmts = else (decls, map (traverseNestedStmts removeJumpState) stmts) where - dummyModuleItem = Initial $ Block Seq "" decls stmts - declares = elem jumpState $ execWriter $ - collectDeclsM collectVarM dummyModuleItem - uses = elem jumpState $ execWriter $ - collectExprsM (collectNestedExprsM collectExprIdentM) dummyModuleItem + dummyStmt = Block Seq "" decls stmts + writesJumpState f = elem jumpState $ execWriter $ + collectNestedStmtsM f dummyStmt + declares = writesJumpState $ collectStmtDeclsM collectVarM + uses = writesJumpState $ + collectStmtExprsM $ collectNestedExprsM collectExprIdentM collectVarM :: Decl -> Writer [String] () collectVarM (Variable Local _ ident _ _) = tell [ident] collectVarM _ = return () diff --git a/src/Convert/Struct.hs b/src/Convert/Struct.hs index d5c7945..23ac1b4 100644 --- a/src/Convert/Struct.hs +++ b/src/Convert/Struct.hs @@ -27,8 +27,6 @@ convert = map $ traverseDescriptions convertDescription convertDescription :: Description -> Description convertDescription (description @ (Part _ _ Module _ _ _ _)) = - traverseModuleItems - (traverseTypes' ExcludeParamTypes $ traverseNestedTypes convertType) $ partScoper traverseDeclM traverseModuleItemM traverseGenItemM traverseStmtM description convertDescription other = other @@ -100,7 +98,7 @@ convertStruct' isStruct sg fields = convertType :: Type -> Type convertType t1 = case convertStruct t1 of - Nothing -> t1 + Nothing -> traverseSinglyNestedTypes convertType t1 Just (t2, _) -> tf2 (rs1 ++ rs2) where (tf2, rs2) = typeRanges t2 where (_, rs1) = typeRanges t1 @@ -114,11 +112,13 @@ traverseDeclM decl = do when (isRangeable t) $ scopeType (tf $ a ++ rs) >>= insertElem x let e' = convertExpr t e - return $ Variable d t x a e' + let t' = convertType t + return $ Variable d t' x a e' Param s t x e -> do scopeType t >>= insertElem x let e' = convertExpr t e - return $ Param s t x e' + let t' = convertType t + return $ Param s t' x e' ParamType{} -> return decl CommentDecl{} -> return decl traverseDeclExprsM traverseExprM decl' @@ -153,7 +153,9 @@ traverseStmtM' = traverseStmtAsgnsM traverseAsgnM traverseExprM :: Expr -> Scoper Type Expr -traverseExprM = embedScopes convertSubExpr >=> return . snd +traverseExprM = + (embedScopes convertSubExpr >=> return . snd) . + (traverseNestedExprs $ traverseExprTypes convertType) traverseLHSM :: LHS -> Scoper Type LHS traverseLHSM = convertLHS >=> return . snd diff --git a/src/Convert/Traverse.hs b/src/Convert/Traverse.hs index bb3b9bc..4b11dde 100644 --- a/src/Convert/Traverse.hs +++ b/src/Convert/Traverse.hs @@ -8,7 +8,6 @@ module Convert.Traverse ( MapperM , Mapper , CollectorM -, TypeStrategy (..) , unmonad , collectify , traverseDescriptionsM @@ -37,6 +36,9 @@ module Convert.Traverse , traverseDeclsM , traverseDecls , collectDeclsM +, traverseStmtDeclsM +, traverseStmtDecls +, collectStmtDeclsM , traverseSinglyNestedTypesM , traverseSinglyNestedTypes , collectSinglyNestedTypesM @@ -58,9 +60,6 @@ module Convert.Traverse , traverseDeclTypesM , traverseDeclTypes , collectDeclTypesM -, traverseTypesM' -, traverseTypes' -, collectTypesM' , traverseTypesM , traverseTypes , collectTypesM @@ -78,6 +77,7 @@ module Convert.Traverse , traverseNestedModuleItemsM , traverseNestedModuleItems , collectNestedModuleItemsM +, traverseNestedStmtsM , traverseNestedStmts , collectNestedStmtsM , traverseNestedExprsM @@ -111,11 +111,6 @@ type MapperM m t = t -> m t type Mapper t = t -> t type CollectorM m t = t -> m () -data TypeStrategy - = IncludeParamTypes - | ExcludeParamTypes - deriving Eq - unmonad :: (MapperM Identity a -> MapperM Identity b) -> Mapper a -> Mapper b unmonad traverser mapper = runIdentity . traverser (return . mapper) @@ -201,14 +196,15 @@ traverseStmts = unmonad traverseStmtsM collectStmtsM :: Monad m => CollectorM m Stmt -> CollectorM m ModuleItem collectStmtsM = collectify traverseStmtsM --- private utility for turning a thing which maps over a single lever of --- statements into one that maps over the nested statements first, then the --- higher levels up traverseNestedStmtsM :: Monad m => MapperM m Stmt -> MapperM m Stmt traverseNestedStmtsM mapper = fullMapper where fullMapper = mapper >=> traverseSinglyNestedStmtsM fullMapper --- variant of the above which only traverses one level down +traverseNestedStmts :: Mapper Stmt -> Mapper Stmt +traverseNestedStmts = unmonad traverseNestedStmtsM +collectNestedStmtsM :: Monad m => CollectorM m Stmt -> CollectorM m Stmt +collectNestedStmtsM = collectify traverseNestedStmtsM + traverseSinglyNestedStmtsM :: Monad m => MapperM m Stmt -> MapperM m Stmt traverseSinglyNestedStmtsM fullMapper = cs where @@ -783,29 +779,30 @@ collectSinglyNestedLHSsM :: Monad m => CollectorM m LHS -> CollectorM m LHS collectSinglyNestedLHSsM = collectify traverseSinglyNestedLHSsM traverseDeclsM :: Monad m => MapperM m Decl -> MapperM m ModuleItem -traverseDeclsM mapper item = do - item' <- miMapper item - traverseStmtsM stmtMapper item' +traverseDeclsM mapper = miMapper where miMapper (MIPackageItem (Decl decl)) = mapper decl >>= return . MIPackageItem . Decl - miMapper (MIPackageItem (Function l t x decls stmts)) = do - decls' <- mapM mapper decls - return $ MIPackageItem $ Function l t x decls' stmts - miMapper (MIPackageItem (Task l x decls stmts)) = do - decls' <- mapM mapper decls - return $ MIPackageItem $ Task l x decls' stmts miMapper other = return other - stmtMapper (Block kw name decls stmts) = do - decls' <- mapM mapper decls - return $ Block kw name decls' stmts - stmtMapper other = return other traverseDecls :: Mapper Decl -> Mapper ModuleItem traverseDecls = unmonad traverseDeclsM collectDeclsM :: Monad m => CollectorM m Decl -> CollectorM m ModuleItem collectDeclsM = collectify traverseDeclsM +traverseStmtDeclsM :: Monad m => MapperM m Decl -> MapperM m Stmt +traverseStmtDeclsM mapper = stmtMapper + where + stmtMapper (Block kw name decls stmts) = do + decls' <- mapM mapper decls + return $ Block kw name decls' stmts + stmtMapper other = return other + +traverseStmtDecls :: Mapper Decl -> Mapper Stmt +traverseStmtDecls = unmonad traverseStmtDeclsM +collectStmtDeclsM :: Monad m => CollectorM m Decl -> CollectorM m Stmt +collectStmtDeclsM = collectify traverseStmtDeclsM + traverseSinglyNestedTypesM :: Monad m => MapperM m Type -> MapperM m Type traverseSinglyNestedTypesM mapper = tm where @@ -971,45 +968,21 @@ traverseDeclTypes = unmonad traverseDeclTypesM collectDeclTypesM :: Monad m => CollectorM m Type -> CollectorM m Decl collectDeclTypesM = collectify traverseDeclTypesM -traverseTypesM' :: Monad m => TypeStrategy -> MapperM m Type -> MapperM m ModuleItem -traverseTypesM' strategy mapper = - miMapper >=> - traverseDeclsM declMapper >=> - traverseExprsM (traverseNestedExprsM exprMapper) - where - exprMapper = traverseExprTypesM mapper - declMapper = - if strategy == IncludeParamTypes - then traverseDeclTypesM mapper - else \decl -> case decl of - ParamType{} -> return decl - _ -> traverseDeclTypesM mapper decl - miMapper (MIPackageItem (Function l t x d s)) = - mapper t >>= \t' -> return $ MIPackageItem $ Function l t' x d s - miMapper (MIPackageItem (other @ (Task _ _ _ _))) = - return $ MIPackageItem other - miMapper (Instance m params x rs p) = do - params' <- mapM mapParam params - return $ Instance m params' x rs p - where - mapParam (i, Left t) = - if strategy == IncludeParamTypes - then mapper t >>= \t' -> return (i, Left t') - else return (i, Left t) - mapParam (i, Right e) = return $ (i, Right e) - miMapper other = return other - -traverseTypes' :: TypeStrategy -> Mapper Type -> Mapper ModuleItem -traverseTypes' strategy = unmonad $ traverseTypesM' strategy -collectTypesM' :: Monad m => TypeStrategy -> CollectorM m Type -> CollectorM m ModuleItem -collectTypesM' strategy = collectify $ traverseTypesM' strategy - traverseTypesM :: Monad m => MapperM m Type -> MapperM m ModuleItem -traverseTypesM = traverseTypesM' IncludeParamTypes +traverseTypesM typeMapper = + traverseNodesM exprMapper declMapper typeMapper lhsMapper stmtMapper + where + exprMapper = traverseNestedExprsM (traverseExprTypesM typeMapper) + lhsMapper = traverseNestedLHSsM (traverseLHSExprsM exprMapper) + stmtMapper = traverseNestedStmtsM $ + traverseStmtDeclsM declMapper >=> traverseStmtExprsM exprMapper + declMapper = + traverseDeclExprsM exprMapper >=> traverseDeclTypesM typeMapper + traverseTypes :: Mapper Type -> Mapper ModuleItem -traverseTypes = traverseTypes' IncludeParamTypes +traverseTypes = unmonad traverseTypesM collectTypesM :: Monad m => CollectorM m Type -> CollectorM m ModuleItem -collectTypesM = collectTypesM' IncludeParamTypes +collectTypesM = collectify traverseTypesM traverseGenItemsM :: Monad m => MapperM m GenItem -> MapperM m ModuleItem traverseGenItemsM mapper = moduleItemMapper @@ -1124,11 +1097,6 @@ traverseNestedModuleItems = unmonad traverseNestedModuleItemsM collectNestedModuleItemsM :: Monad m => CollectorM m ModuleItem -> CollectorM m ModuleItem collectNestedModuleItemsM = collectify traverseNestedModuleItemsM -traverseNestedStmts :: Mapper Stmt -> Mapper Stmt -traverseNestedStmts = unmonad traverseNestedStmtsM -collectNestedStmtsM :: Monad m => CollectorM m Stmt -> CollectorM m Stmt -collectNestedStmtsM = collectify traverseNestedStmtsM - -- In many conversions, we want to resolve items locally first, and then fall -- back to looking at other source files, if necessary. This helper captures -- this behavior, allowing a conversion to fall back to arbitrary global