diff --git a/rtree-c/src/ReduceC.hs b/rtree-c/src/ReduceC.hs
index 380106ea60ae04c90b62474f3e0149b71e783072..3a0b874ba448004a96ced3ec67fced905ef7b43b 100644
--- a/rtree-c/src/ReduceC.hs
+++ b/rtree-c/src/ReduceC.hs
@@ -431,6 +431,7 @@ reduceCExprOrZero expr ctx = do
split ("replace by zero", C.posOf expr) (pure zeroExpr) ex
Nothing -> do
pure zeroExpr
+{-# INLINE reduceCExprOrZero #-}
reduceCExpr :: (MonadReduce Lab m, HasCallStack) => C.CExpr -> Context -> Maybe (m C.CExpr)
reduceCExpr expr ctx = case expr of
@@ -560,27 +561,6 @@ inlineTypeDefsCDI di ctx = case di of
C.CDeclarationItem a b ni -> C.CDeclarationItem (inlineTypeDefsCDeclarator a ctx) b ni
a -> don'tHandle a
--- inlineTypeDefs :: forall d. (Data d) => d -> Context -> d
--- inlineTypeDefs r ctx
--- | hasReplacementTypeDef ctx r =
--- case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of
--- Just Refl -> inlineTypeDefsSpecs r ctx
--- Nothing ->
--- gmapT (`inlineTypeDefs` ctx) r
--- | otherwise = r
--- {-# NOINLINE inlineTypeDefs #-}
---
--- hasReplacementTypeDef :: forall a. (Data a) => Context -> a -> Bool
--- hasReplacementTypeDef ctx d = case cast d of
--- Just (C.CTypeSpec (C.CTypeDef idx _)) ->
--- case Map.lookup idx . typeDefs $ ctx of
--- Just ITKeep -> False
--- Just (ITInline _) -> True
--- Nothing -> error ("could not find typedef:" <> show idx)
--- Just _ -> False
--- Nothing -> gmapQl (||) False (hasReplacementTypeDef ctx) d
--- {-# NOINLINE hasReplacementTypeDef #-}
-
identifiers :: forall a. (Data a) => a -> [C.Ident]
identifiers d = appEndo (go d) []
where
@@ -589,19 +569,10 @@ identifiers d = appEndo (go d) []
Just l -> Endo (l :)
Nothing -> gmapQl (<>) mempty go d'
--- instance CReducible C.CExtDecl where
--- reduceC (C.CFunDef spc dec cdecls smt ni) = do
--- pure $ C.CFunDef spc dec cdecls smt ni
-
functionName :: C.CFunctionDef C.NodeInfo -> Maybe C.Ident
functionName = \case
C.CFunDef _ (C.CDeclr ix _ _ _ _) _ _ _ -> ix
--- isMain :: C.CFunctionDef C.NodeInfo -> Bool
--- isMain (C.CFunDef _ (C.CDeclr (Just i) _ _ _ _) _ _ _) =
--- C.identToString i == "main"
--- isMain _ow = False
-
don'tHandle :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> b
don'tHandle f = error (show (f $> ()))
@@ -610,259 +581,3 @@ don'tHandleWithPos f = error (show (f $> ()) <> " at " <> show (C.posOf f))
don'tHandleWithNodeInfo :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> C.NodeInfo -> b
don'tHandleWithNodeInfo f ni = error (show (f $> ()) <> " at " <> show (C.posOf ni))
-
--- instance CReducible C.CDeclaration where
--- reduce = \case
--- C.CDecl spc@(C.CStorageSpec (C.CTypedef _) : rst) decl ni -> do
--- decl' <-
--- decl & collectNonEmpty' \case
--- C.CDeclarationItem d Nothing Nothing -> do
--- let (x, _) = cDeclaratorIdentifiers d
--- case x of
--- Just x' ->
--- splitOn
--- (Val.is x')
--- ( do
--- modify (Map.insert x' (Type rst))
--- mzero
--- )
--- (pure $ C.CDeclarationItem d Nothing Nothing)
--- Nothing ->
--- pure $ C.CDeclarationItem d Nothing Nothing
--- a -> error (show a)
--- pure (C.CDecl spc decl' ni)
--- C.CDecl spc@[C.CTypeSpec (C.CTypeDef i ni')] decl ni -> do
--- x <- gets (Map.lookup i)
--- case x of
--- Just (Type rst) -> do
--- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers rst) decl
--- pure $ C.CDecl rst decl' ni
--- Nothing -> do
--- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--- pure $ C.CDecl spc decl' ni
--- C.CDecl spc decl ni -> do
--- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--- pure $ C.CDecl spc decl' ni
--- a -> error (show a)
--- where
--- reduceCDeclarationItem rq' = \case
--- C.CDeclarationItem d i e -> do
--- let (fn, reqs) = cDeclaratorIdentifiers d
--- case fn of
--- Just fn' ->
--- conditionalGivenThat (rq' <> reqs) (Val.is fn')
--- Nothing ->
--- mapM_ (givenThat . Val.is) (rq' <> reqs)
---
--- i' <- optional do
--- liftMaybe i >>= reduce @C.CInitializer
--- e' <- optional do
--- liftMaybe e >>= reduce @C.CExpression
---
--- pure (C.CDeclarationItem d i' e')
--- a -> error (show a)
-
--- import Control.Monad.Reduce
---
--- import qualified Data.Valuation as Val
---
--- import Control.Applicative
--- import Control.Monad.State
--- import Control.Monad.Trans.Maybe
--- import Data.Data
--- import Data.Function
--- import Data.Functor
--- import qualified Data.Map.Strict as Map
--- import Data.Maybe (catMaybes)
--- import qualified Language.C as C
-
--- type Lab = C.Ident
---
--- data LabInfo
--- = Type [C.CDeclarationSpecifier C.NodeInfo]
---
--- type CState = Map.Map Lab LabInfo
---
--- reduceC :: (MonadReduce Lab m, MonadState CState m) => C.CTranslUnit -> m C.CTranslUnit
--- reduceC (C.CTranslUnit es ni) = do
--- es' <- collect reduceCExternalDeclaration es
--- pure $ C.CTranslUnit es' ni
--- where
--- reduceCExternalDeclaration = \case
--- C.CFDefExt fun -> do
--- C.CFDefExt <$> reduce @C.CFunctionDef fun
--- C.CDeclExt decl ->
--- C.CDeclExt <$> reduce @C.CDeclaration decl
--- a -> error (show a)
---
--- identifiers :: forall a. (Data a) => a -> [Lab]
--- identifiers d = case cast d of
--- Just l -> [l]
--- Nothing -> concat $ gmapQ identifiers d
---
--- type Reducer m a = a -> m a
---
--- class CReducible c where
--- reduce :: (MonadReducePlus Lab m, MonadState CState m) => Reducer m (c C.NodeInfo)
---
--- cDeclaratorIdentifiers :: C.CDeclarator C.NodeInfo -> (Maybe Lab, [Lab])
--- cDeclaratorIdentifiers (C.CDeclr mi dd _ la _) =
--- (mi, identifiers dd <> identifiers la)
---
--- instance CReducible C.CFunctionDef where
--- reduce (C.CFunDef spc dec cdecls smt ni) = do
--- let (fn, ids) = cDeclaratorIdentifiers dec
--- let requirements = identifiers spc <> identifiers cdecls <> ids
--- case fn of
--- Just fn' ->
--- conditionalGivenThat requirements (Val.is fn')
--- Nothing ->
--- mapM_ (givenThat . Val.is) requirements
--- smt' <- reduce @C.CStatement smt
--- pure $ C.CFunDef spc dec cdecls smt' ni
---
--- instance CReducible C.CDeclaration where
--- reduce = \case
--- C.CDecl spc@(C.CStorageSpec (C.CTypedef _) : rst) decl ni -> do
--- decl' <-
--- decl & collectNonEmpty' \case
--- C.CDeclarationItem d Nothing Nothing -> do
--- let (x, _) = cDeclaratorIdentifiers d
--- case x of
--- Just x' ->
--- splitOn
--- (Val.is x')
--- ( do
--- modify (Map.insert x' (Type rst))
--- mzero
--- )
--- (pure $ C.CDeclarationItem d Nothing Nothing)
--- Nothing ->
--- pure $ C.CDeclarationItem d Nothing Nothing
--- a -> error (show a)
--- pure (C.CDecl spc decl' ni)
--- C.CDecl spc@[C.CTypeSpec (C.CTypeDef i ni')] decl ni -> do
--- x <- gets (Map.lookup i)
--- case x of
--- Just (Type rst) -> do
--- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers rst) decl
--- pure $ C.CDecl rst decl' ni
--- Nothing -> do
--- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--- pure $ C.CDecl spc decl' ni
--- C.CDecl spc decl ni -> do
--- decl' <- collectNonEmpty' (reduceCDeclarationItem $ identifiers spc) decl
--- pure $ C.CDecl spc decl' ni
--- a -> error (show a)
--- where
--- reduceCDeclarationItem rq' = \case
--- C.CDeclarationItem d i e -> do
--- let (fn, reqs) = cDeclaratorIdentifiers d
--- case fn of
--- Just fn' ->
--- conditionalGivenThat (rq' <> reqs) (Val.is fn')
--- Nothing ->
--- mapM_ (givenThat . Val.is) (rq' <> reqs)
---
--- i' <- optional do
--- liftMaybe i >>= reduce @C.CInitializer
--- e' <- optional do
--- liftMaybe e >>= reduce @C.CExpression
---
--- pure (C.CDeclarationItem d i' e')
--- a -> error (show a)
---
--- instance CReducible C.CInitializer where
--- reduce = \case
--- C.CInitExpr e ni -> reduce @C.CExpression e <&> \e' -> C.CInitExpr e' ni
--- C.CInitList (C.CInitializerList items) ni -> do
--- collectNonEmpty' rmCInitializerListItem items <&> \items' ->
--- C.CInitList (C.CInitializerList items') ni
--- where
--- rmCInitializerListItem (pds, is) = do
--- pds' <- collect rmCPartDesignator pds
--- is' <- reduce is
--- pure (pds', is')
---
--- rmCPartDesignator = \case
--- a -> error (show a)
---
--- instance CReducible C.CStatement where
--- reduce = \case
--- C.CCompound is cbi ni -> do
--- cbi' <- collect (reduce @C.CCompoundBlockItem) cbi
--- pure $ C.CCompound is cbi' ni
--- C.CExpr e ni -> do
--- e' <- optional do
--- e' <- liftMaybe e
--- reduce @C.CExpression e'
--- pure $ C.CExpr e' ni
--- C.CIf e s els ni -> do
--- s' <- reduce s
--- e' <- optional do
--- reduce @C.CExpression e
--- els' <- optional do
--- els' <- liftMaybe els
--- given >> reduce els'
--- case (e', els') of
--- (Nothing, Nothing) -> pure s'
--- (Just e'', Nothing) -> pure $ C.CIf e'' s' Nothing ni
--- (Nothing, Just x) -> pure $ C.CIf zeroExp s' (Just x) ni
--- (Just e'', Just x) -> pure $ C.CIf e'' s' (Just x) ni
--- C.CFor e1 e2 e3 s ni -> do
--- reduce s <| do
---
--- e1' <- reduce @C.CForInit e1
--- e2' <- optional $ liftMaybe e2 >>= reduce @C.CExpression
--- e3' <- optional $ liftMaybe e3 >>= reduce @C.CExpression
--- s' <- reduce s
--- pure $ C.CFor e1' e2' e3' s' ni
--- C.CReturn e ni -> do
--- e' <- traverse (fmap orZero reduce) e
--- pure $ C.CReturn e' ni
--- C.CBreak ni -> pure (C.CBreak ni)
--- C.CCont ni -> pure (C.CCont ni)
--- C.CLabel i s [] ni -> do
--- -- todo fix attrs
--- s' <- reduce s
--- withFallback s' do
--- givenThat (Val.is i)
--- pure $ C.CLabel i s' [] ni
--- C.CGoto i ni ->
--- withFallback (C.CExpr Nothing ni) do
--- givenThat (Val.is i)
--- pure $ C.CGoto i ni
--- C.CWhile e s dow ni -> do
--- e' <- orZero (reduce @C.CExpression e)
--- s' <- reduce s
--- pure $ C.CWhile e' s' dow ni
--- a -> error (show a)
---
--- instance CReducible C.CForInit where
--- reduce = \case
--- C.CForDecl decl -> withFallback (C.CForInitializing Nothing) do
--- C.CForDecl <$> reduce @C.CDeclaration decl
--- C.CForInitializing n -> do
--- C.CForInitializing <$> optional do
--- n' <- liftMaybe n
--- reduce @C.CExpression n'
---
---
--- zeroExp :: C.CExpression C.NodeInfo
--- zeroExp = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)
---
--- withFallback :: (Alternative m) => a -> m a -> m a
--- withFallback a ma = ma <|> pure a
---
--- orZero :: (Alternative m) => m (C.CExpression C.NodeInfo) -> m (C.CExpression C.NodeInfo)
--- orZero = withFallback zeroExp
---
--- instance CReducible C.CCompoundBlockItem where
--- reduce = \case
--- C.CBlockStmt s ->
--- C.CBlockStmt <$> do
--- given >> reduce @C.CStatement s
--- C.CBlockDecl d ->
--- C.CBlockDecl <$> do
--- reduce @C.CDeclaration d
--- a -> error (show a)