diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs index 44c89cd55d3f242f0929107246e09656561d88ac..dcd3defb276e4e3f731a1753ec402ea151888ae2 100644 --- a/rtree-c/src/ReduceC.hs +++ b/rtree-c/src/ReduceC.hs @@ -26,21 +26,52 @@ module ReduceC ( prettyIdent, ) where -import Control.Applicative -import Control.Monad +import Control.Applicative (Alternative (empty, (<|>))) +import Control.Monad ( + MonadPlus (mzero), + foldM, + forM, + forM_, + guard, + join, + mapAndUnzipM, + unless, + void, + when, + ) import qualified Control.Monad.IRTree as IRTree -import Control.Monad.Reduce -import Control.Monad.State -import Control.Monad.Trans.Maybe -import Data.Function -import Data.Functor +import Control.Monad.Reduce ( + MonadReduce (split), + collect, + exceptIf, + liftMaybe, + ) +import Control.Monad.State ( + MonadState (get, state), + MonadTrans (lift), + State, + StateT (runStateT), + evalState, + evalStateT, + gets, + modify', + runState, + ) +import Control.Monad.Trans.Maybe (MaybeT (runMaybeT)) +import Data.Function ((&)) +import Data.Functor (($>), (<&>)) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Map.Strict as Map -import Data.Maybe +import Data.Maybe ( + catMaybes, + fromMaybe, + isJust, + isNothing, + mapMaybe, + ) import qualified Data.Set as Set import Data.Vector.Internal.Check (HasCallStack) -import Debug.Pretty.Simple import qualified Language.C as C import qualified Language.C.Data.Ident as C import qualified Language.C.Data.Node as C @@ -53,11 +84,11 @@ defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.C defaultReduceC a = reduceCTranslUnit a defaultContext {-# SPECIALIZE defaultReduceC :: C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-} -reduceCTranslUnit - :: (MonadReduce Lab m) - => C.CTranslationUnit C.NodeInfo - -> Context - -> m (C.CTranslationUnit C.NodeInfo) +reduceCTranslUnit :: + (MonadReduce Lab m) => + C.CTranslationUnit C.NodeInfo -> + Context -> + m (C.CTranslationUnit C.NodeInfo) reduceCTranslUnit (C.CTranslUnit es ni) ctx = do let _functions = foldMap (findFunctions (: [])) es @@ -153,24 +184,24 @@ keepAll = SpecifierFilter{sfKeepStatic = True} {- | Update the CDeclarationSpecifier's to match the context. Specifically, update the typedefs and the structs. Alos return a base type. -} -updateCDeclarationSpecifiers - :: ( MonadState Context m - , MonadPlus m - ) - => SpecifierFilter - -> [C.CDeclarationSpecifier C.NodeInfo] - -> m (Voidable, [C.CDeclarationSpecifier C.NodeInfo]) +updateCDeclarationSpecifiers :: + ( MonadState Context m + , MonadPlus m + ) => + SpecifierFilter -> + [C.CDeclarationSpecifier C.NodeInfo] -> + m (Voidable, [C.CDeclarationSpecifier C.NodeInfo]) updateCDeclarationSpecifiers sf spec = do ctx <- get spec' <- concat <$> mapM (updateSpec ctx) spec bt <- baseType ctx spec' pure (bt, spec') where - baseType - :: (MonadPlus m) - => Context - -> [C.CDeclarationSpecifier C.NodeInfo] - -> m Voidable + baseType :: + (MonadPlus m) => + Context -> + [C.CDeclarationSpecifier C.NodeInfo] -> + m Voidable baseType ctx = liftMaybe . exactlyOne @@ -305,23 +336,23 @@ updateCDeclarationSpecifiers sf spec = do a' -> notSupportedYet' a' pure $ catMaybes declrs' -updateCDerivedDeclarators - :: forall m - . ( MonadState Context m - , MonadPlus m - ) - => Voidable - -> [Bool] - -> [C.CDerivedDeclarator C.NodeInfo] - -> m (Voidable, [C.CDerivedDeclarator C.NodeInfo]) +updateCDerivedDeclarators :: + forall m. + ( MonadState Context m + , MonadPlus m + ) => + Voidable -> + [Bool] -> + [C.CDerivedDeclarator C.NodeInfo] -> + m (Voidable, [C.CDerivedDeclarator C.NodeInfo]) updateCDerivedDeclarators bt ff dd = do foldM applyDD (bt, []) (reverse dd) where - applyDD - :: (r ~ (Voidable, [C.CDerivedDeclarator C.NodeInfo])) - => r - -> C.CDerivedDeclarator C.NodeInfo - -> m r + applyDD :: + (r ~ (Voidable, [C.CDerivedDeclarator C.NodeInfo])) => + r -> + C.CDerivedDeclarator C.NodeInfo -> + m r applyDD (t, dd') d = case d of C.CPtrDeclr _ _ -> do pure (NonVoid . TPointer $ t, d : dd') @@ -335,10 +366,10 @@ updateCDerivedDeclarators bt ff dd = do pure (t', C.CFunDeclr (C.CFunParamsNew params'' varadic) arr ni : dd') b -> notSupportedYet b ni - findParams - :: Bool - -> [C.CDeclaration C.NodeInfo] - -> State Context (Params, [C.CDeclaration C.NodeInfo]) + findParams :: + Bool -> + [C.CDeclaration C.NodeInfo] -> + State Context (Params, [C.CDeclaration C.NodeInfo]) findParams varadic decls = case decls of [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> pure (VoidParams, decls) @@ -374,10 +405,10 @@ updateCDerivedDeclarators bt ff dd = do Nothing -> (Nothing, []) pure (Params ts varadic, concat decls') -reduceCExternalDeclaration - :: (HasCallStack, MonadReduce Lab m) - => C.CExternalDeclaration C.NodeInfo - -> StateT Context m (Maybe (C.CExternalDeclaration C.NodeInfo)) +reduceCExternalDeclaration :: + (HasCallStack, MonadReduce Lab m) => + C.CExternalDeclaration C.NodeInfo -> + StateT Context m (Maybe (C.CExternalDeclaration C.NodeInfo)) reduceCExternalDeclaration r = case r of C.CFDefExt (C.CFunDef spec declr [] stmt ni) -> runMaybeT do ctx <- get @@ -499,13 +530,13 @@ isStaticFromSpecs = any \case {- | This checks the current declaration and reduces any new struct found here. Returns true if the specifier is requried. -} -reduceStructDeclaration - :: ( MonadReduce Lab m - , MonadState Context m - , MonadPlus m - ) - => [C.CDeclarationSpecifier C.NodeInfo] - -> m Bool +reduceStructDeclaration :: + ( MonadReduce Lab m + , MonadState Context m + , MonadPlus m + ) => + [C.CDeclarationSpecifier C.NodeInfo] -> + m Bool reduceStructDeclaration = fmap or . mapM \case C.CTypeSpec (C.CEnumType (C.CEnum mid mf _ _) ni) -> do @@ -583,14 +614,14 @@ reduceStructDeclaration = ) a@(C.CStaticAssert{}) -> notSupportedYet' a -reduceCDeclarationItem - :: ( MonadReduce Lab m - , MonadState Context m - , MonadPlus m - ) - => Voidable - -> C.CDeclarationItem C.NodeInfo - -> m (C.CDeclarationItem C.NodeInfo) +reduceCDeclarationItem :: + ( MonadReduce Lab m + , MonadState Context m + , MonadPlus m + ) => + Voidable -> + C.CDeclarationItem C.NodeInfo -> + m (C.CDeclarationItem C.NodeInfo) reduceCDeclarationItem bt = \case di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni) einit Nothing) -> do ctx <- get @@ -622,12 +653,12 @@ reduceCDeclarationItem bt = \case pure di a -> notSupportedYet a C.undefNode -reduceCInitializer - :: (MonadReduce Lab m) - => Type - -> C.CInitializer C.NodeInfo - -> Context - -> m (C.CInitializer C.NodeInfo, Maybe C.CExpr) +reduceCInitializer :: + (MonadReduce Lab m) => + Type -> + C.CInitializer C.NodeInfo -> + Context -> + m (C.CInitializer C.NodeInfo, Maybe C.CExpr) reduceCInitializer t einit ctx = case einit of C.CInitExpr e ni2 -> do e' <- fromMaybe (pure zeroExpr) $ reduceCExpr e (exactly t) ctx @@ -655,11 +686,11 @@ reduceCInitializer t einit ctx = case einit of pure items pure (C.CInitList (C.CInitializerList items') ni2, Nothing) -reduceCCompoundBlockItem - :: (MonadReduce Lab m, HasCallStack) - => StmtContext - -> C.CCompoundBlockItem C.NodeInfo - -> StateT Context m [C.CCompoundBlockItem C.NodeInfo] +reduceCCompoundBlockItem :: + (MonadReduce Lab m, HasCallStack) => + StmtContext -> + C.CCompoundBlockItem C.NodeInfo -> + StateT Context m [C.CCompoundBlockItem C.NodeInfo] reduceCCompoundBlockItem lab r = do case r of C.CBlockStmt smt -> do @@ -701,24 +732,24 @@ markDeleted = mapM_ \case modify' (addInlineExpr ix IEDelete) _a -> pure () -reduceCStatementOrEmptyBlock - :: (MonadReduce Lab m, HasCallStack) - => C.CStatement C.NodeInfo - -> StmtContext - -> Context - -> m (C.CStatement C.NodeInfo) +reduceCStatementOrEmptyBlock :: + (MonadReduce Lab m, HasCallStack) => + C.CStatement C.NodeInfo -> + StmtContext -> + Context -> + m (C.CStatement C.NodeInfo) reduceCStatementOrEmptyBlock stmt ids ctx = do fromMaybe emptyBlock <$> runMaybeT ( wrapCCompound <$> reduceCStatement stmt ids ctx ) -reduceCStatementOrEmptyExpr - :: (MonadReduce Lab m, HasCallStack) - => C.CStatement C.NodeInfo - -> StmtContext - -> Context - -> m (C.CStatement C.NodeInfo) +reduceCStatementOrEmptyExpr :: + (MonadReduce Lab m, HasCallStack) => + C.CStatement C.NodeInfo -> + StmtContext -> + Context -> + m (C.CStatement C.NodeInfo) reduceCStatementOrEmptyExpr stmt ids ctx = do fromMaybe (C.CExpr Nothing C.undefNode) <$> runMaybeT (reduceCStatement stmt ids ctx) @@ -742,13 +773,13 @@ exactly :: Type -> EType exactly c = EType (ETExactly c) False -- | Reduce given a list of required labels reduce a c statement, possibly into nothingness. -reduceCStatement - :: forall m - . (MonadReduce Lab m, HasCallStack) - => C.CStatement C.NodeInfo - -> StmtContext - -> Context - -> MaybeT m (C.CStatement C.NodeInfo) +reduceCStatement :: + forall m. + (MonadReduce Lab m, HasCallStack) => + C.CStatement C.NodeInfo -> + StmtContext -> + Context -> + MaybeT m (C.CStatement C.NodeInfo) reduceCStatement smt labs ctx = case smt of C.CCompound is cbi ni -> do cbi' <- lift $ evalStateT (mapM (reduceCCompoundBlockItem labs) cbi) ctx @@ -1046,13 +1077,13 @@ inferType ctx = \case inferType ctx (List.last items) a -> notSupportedYet' a -reduceCExpr - :: forall m - . (MonadReduce Lab m, HasCallStack) - => C.CExpr - -> EType - -> Context - -> Maybe (m C.CExpr) +reduceCExpr :: + forall m. + (MonadReduce Lab m, HasCallStack) => + C.CExpr -> + EType -> + Context -> + Maybe (m C.CExpr) reduceCExpr expr t ctx = case expr of C.CBinary o elhs erhs ni -> do msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do @@ -1365,11 +1396,11 @@ data Function = Function } deriving (Show, Eq) -findFunctions - :: (Monoid m) - => (Function -> m) - -> C.CExternalDeclaration C.NodeInfo - -> m +findFunctions :: + (Monoid m) => + (Function -> m) -> + C.CExternalDeclaration C.NodeInfo -> + m findFunctions inject = \case C.CFDefExt (C.CFunDef spec declr [] _ ni) -> findFunctionsInDeclarator ni spec declr