Small cleanup operation

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