{-# LANGUAGE BlockArguments #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoMonomorphismRestriction #-} module ReduceC ( defaultReduceC, reduceCTranslUnit, -- * Context Context (..), defaultContext, -- * Helpers prettyIdent, ) where import Control.Monad.Reduce import Data.Data import Data.Foldable import Data.Function import Data.Functor import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Set as Set import Data.Vector.Internal.Check (HasCallStack) import qualified Language.C as C import qualified Language.C.Data.Ident as C data Context = Context { keywords :: !(Set.Set Keyword) , typeDefs :: !(Map.Map C.Ident [C.CDeclarationSpecifier C.NodeInfo]) , inlineExprs :: !(Map.Map C.Ident C.CExpr) } data Keyword = KeepMain | DoNoops | NoSemantics | AllowEmptyDeclarations | DisallowVariableInlining deriving (Show, Read, Enum, Eq, Ord) type Lab = (String, C.Position) defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.CTranslUnit defaultReduceC a = reduceCTranslUnit a defaultContext addTypeDefs :: [C.Ident] -> [C.CDeclarationSpecifier C.NodeInfo] -> Context -> Context addTypeDefs ids cs Context{..} = Context { typeDefs = foldl' (\a i -> Map.insert i cs a) typeDefs ids , .. } addInlineExpr :: C.Ident -> C.CExpr -> Context -> Context addInlineExpr i e Context{..} = Context { inlineExprs = Map.insert i e inlineExprs , .. } addKeyword :: Keyword -> Context -> Context addKeyword k Context{..} = Context { keywords = Set.insert k keywords , .. } -- deleteKeyword :: Keyword -> Context -> Context -- deleteKeyword k Context{..} = -- Context -- { keywords = Set.delete k keywords -- , .. -- } defaultContext :: Context defaultContext = Context { keywords = Set.fromList [KeepMain] , typeDefs = Map.empty , inlineExprs = Map.empty } isIn :: Keyword -> Context -> Bool isIn k = Set.member k . keywords prettyIdent :: C.Identifier C.NodeInfo -> [Char] prettyIdent (C.Ident s _ a) = s ++ " at " ++ show (C.posOfNode a) reduceCTranslUnit :: (MonadReduce Lab m) => C.CTranslationUnit C.NodeInfo -> Context -> m (C.CTranslationUnit C.NodeInfo) reduceCTranslUnit (C.CTranslUnit es ni) ctx = do es' <- foldr reduceCExternalDeclaration (\_ -> pure []) es ctx pure $ C.CTranslUnit es' ni reduceCExternalDeclaration :: (MonadReduce Lab m) => C.CExternalDeclaration C.NodeInfo -> (Context -> m [C.CExternalDeclaration C.NodeInfo]) -> Context -> m [C.CExternalDeclaration C.NodeInfo] reduceCExternalDeclaration r cont ctx = do case inlineTypeDefs r ctx of C.CFDefExt fun | KeepMain `isIn` ctx && maybe False (("main" ==) . C.identToString) (functionName fun) -> do r' <- C.CFDefExt <$> reduceCFunDef fun ctx (r' :) <$> cont ctx | otherwise -> split ("remove function " <> maybe "" C.identToString (functionName fun), C.posOf r) (cont ctx) do r' <- C.CFDefExt <$> reduceCFunDef fun ctx (r' :) <$> case functionName fun of Just fid -> cont (addInlineExpr fid (C.CVar fid C.undefNode) ctx) Nothing -> cont ctx C.CDeclExt result -> case result of -- A typedef C.CDecl (C.CStorageSpec (C.CTypedef n) : rst) decl _ -> do let [ids] = identifiers decl split ("inline typedef " <> C.identToString ids, C.posOf r) (cont (addTypeDefs [ids] rst ctx)) ((r :) <$> cont (addTypeDefs [ids] [C.CTypeSpec (C.CTypeDef ids n)] ctx)) -- A const C.CDecl rec decl ni' -> do (decl', ctx') <- foldr reduceCDeclarationItem (pure ([], ctx)) decl case decl' of [] | AllowEmptyDeclarations `isIn` ctx' -> split ("remove empty declaration", C.posOf r) (cont ctx') do (C.CDeclExt (C.CDecl rec decl' ni') :) <$> cont ctx' | otherwise -> cont ctx' _ow -> (C.CDeclExt (C.CDecl rec decl' ni') :) <$> cont ctx' a -> don'tHandle a _r -> don'tHandle r reduceCFunDef :: (MonadReduce Lab m) => C.CFunctionDef C.NodeInfo -> Context -> m (C.CFunctionDef C.NodeInfo) reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do smt' <- reduceCStatementOrEmptyBlock smt ctx pure $ C.CFunDef spc dec cdecls smt' ni reduceCCompoundBlockItem :: (MonadReduce Lab m) => C.CCompoundBlockItem C.NodeInfo -> (Context -> m [C.CCompoundBlockItem C.NodeInfo]) -> Context -> m [C.CCompoundBlockItem C.NodeInfo] reduceCCompoundBlockItem r cont ctx = do case r of C.CBlockStmt smt -> do case reduceCStatement smt ctx of Just rsmt -> split ("remove statement", C.posOf r) (cont ctx) do smt' <- rsmt case smt' of C.CCompound [] ss _ -> do split ("expand compound statment", C.posOf r) ((ss <>) <$> cont ctx) do (C.CBlockStmt smt' :) <$> cont ctx _ow -> do (C.CBlockStmt smt' :) <$> cont ctx Nothing -> cont ctx C.CBlockDecl declr -> do case declr of C.CDecl rec decl ni' -> do (decl', ctx') <- foldr reduceCDeclarationItem (pure ([], ctx)) decl case decl' of [] | AllowEmptyDeclarations `isIn` ctx' -> split ("remove empty declaration", C.posOf r) (cont ctx') do (C.CBlockDecl (C.CDecl rec decl' ni') :) <$> cont ctx' | otherwise -> cont ctx' _ow -> (C.CBlockDecl (C.CDecl rec decl' ni') :) <$> cont ctx' d -> don'tHandle d a -> don'tHandle a reduceCDeclarationItem :: (MonadReduce Lab m) => C.CDeclarationItem C.NodeInfo -> m ([C.CDeclarationItem C.NodeInfo], Context) -> m ([C.CDeclarationItem C.NodeInfo], Context) reduceCDeclarationItem d ma = case d of C.CDeclarationItem dr@(C.CDeclr (Just i) [] Nothing [] ni) (Just (C.CInitExpr c ni')) Nothing -> do (ds, ctx) <- ma c' <- fromMaybe (pure zeroExpr) (reduceCExpr c ctx) split ("inline variable " <> C.identToString i, C.posOf ni) (pure (ds, addInlineExpr i c' ctx)) ( pure ( C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing : ds , addInlineExpr i (C.CVar i ni) ctx ) ) C.CDeclarationItem (C.CDeclr (Just i) _ Nothing [] ni) Nothing Nothing -> do (ds, ctx) <- ma split ("remove variable " <> C.identToString i, C.posOf ni) (pure (ds, ctx)) (pure (d : ds, addInlineExpr i (C.CVar i ni) ctx)) a -> don'tHandle a reduceCStatementOrEmptyBlock :: (MonadReduce Lab m) => C.CStatement C.NodeInfo -> Context -> m (C.CStatement C.NodeInfo) reduceCStatementOrEmptyBlock stmt ctx = do case reduceCStatement stmt ctx of Just ex -> do ex Nothing -> do pure emptyBlock where emptyBlock = C.CCompound [] [] C.undefNode reduceCStatement :: (MonadReduce Lab m) => C.CStatement C.NodeInfo -> Context -> Maybe (m (C.CStatement C.NodeInfo)) reduceCStatement smt ctx = case smt of C.CCompound is cbi ni -> Just do cbi' <- foldr reduceCCompoundBlockItem (\_ -> pure []) cbi ctx pure $ C.CCompound is cbi' ni C.CWhile e s dow ni -> do rs <- reduceCStatement s ctx Just do e' <- reduceCExprOrZero e ctx s' <- rs pure $ C.CWhile e' s' dow ni C.CExpr me ni -> do case me of Just e -> do if DoNoops `isIn` ctx then Just do e' <- maybeSplit ("change to noop", C.posOf smt) $ reduceCExpr e ctx pure $ C.CExpr e' ni else do re <- reduceCExpr e ctx Just do e' <- re pure $ C.CExpr (Just e') ni Nothing -> Just $ pure $ C.CExpr Nothing ni C.CReturn me ni -> Just do case me of Just e -> do e' <- reduceCExprOrZero e ctx pure $ C.CReturn (Just e') ni Nothing -> pure $ C.CReturn Nothing ni C.CIf e s els ni -> Just do e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e ctx els' <- case els of Just els' -> do maybeSplit ("remove else branch", C.posOf els') do reduceCStatement els' ctx Nothing -> pure Nothing s' <- reduceCStatementOrEmptyBlock s ctx case (e', els') of (Nothing, Nothing) -> pure s' (Just e'', Nothing) -> pure $ C.CIf e'' s' Nothing ni (Nothing, Just x) -> pure $ C.CIf zeroExpr s' (Just x) ni (Just e'', Just x) -> pure $ C.CIf e'' s' (Just x) ni C.CFor e1 e2 e3 s ni -> Just $ do (me1', ctx') <- case e1 of C.CForDecl (C.CDecl rec decl ni') -> do (decl', ctx') <- foldr reduceCDeclarationItem (pure ([], ctx)) decl res <- if null decl' then whenSplit (AllowEmptyDeclarations `isIn` ctx') ("remove empty declaration", C.posOf ni') (pure Nothing) (pure $ Just $ C.CForDecl (C.CDecl rec decl' ni')) else pure $ Just $ C.CForDecl (C.CDecl rec decl' ni') pure (res, ctx') C.CForInitializing e -> whenSplit (AllowEmptyDeclarations `isIn` ctx) ("remove empty declaration", C.posOf ni) (pure (Nothing, ctx)) (pure (Just $ C.CForInitializing e, ctx)) d -> don'tHandle d s' <- reduceCStatementOrEmptyBlock s ctx' case me1' of Nothing -> do split ("remove the for loop", C.posOf smt) (pure s') do e2' <- case e2 of Just e2' -> maybeSplit ("remove check", C.posOf e2') (reduceCExpr e2' ctx') Nothing -> pure Nothing e3' <- case e3 of Just e3' -> maybeSplit ("remove iterator", C.posOf e3') (reduceCExpr e3' ctx') Nothing -> pure Nothing pure $ C.CFor (C.CForInitializing Nothing) e2' e3' s' ni Just e1' -> do e2' <- case e2 of Just e2' -> maybeSplit ("remove check", C.posOf e2') (reduceCExpr e2' ctx') Nothing -> pure Nothing e3' <- case e3 of Just e3' -> maybeSplit ("remove iterator", C.posOf e3') (reduceCExpr e3' ctx') Nothing -> pure Nothing pure $ C.CFor e1' e2' e3' s' ni C.CBreak ni -> Just do pure (C.CBreak ni) C.CLabel i s [] ni -> Just do s' <- reduceCStatementOrEmptyBlock s ctx pure $ C.CLabel i s' [] ni C.CGoto i ni -> Just do pure $ C.CGoto i ni a -> don'tHandle a -- 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.CReturn e ni -> do -- e' <- traverse (fmap orZero reduce) e -- pure $ C.CReturn e' 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.CWhile e s dow ni -> do -- e' <- orZero (reduce @C.CExpression e) -- s' <- reduce s -- pure $ C.CWhile e' s' dow ni -- | If the condition is statisfied try to reduce to the a. whenSplit :: (MonadReduce Lab m) => Bool -> Lab -> m a -> m a -> m a whenSplit cn lab a b | cn = split lab a b | otherwise = b maybeSplit :: (MonadReduce Lab m) => Lab -> Maybe (m a) -> m (Maybe a) maybeSplit lab = \case Just r -> do split lab (pure Nothing) (Just <$> r) Nothing -> do pure Nothing zeroExpr :: C.CExpression C.NodeInfo zeroExpr = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode) reduceCExprOrZero :: (MonadReduce Lab m) => C.CExpr -> Context -> m C.CExpr reduceCExprOrZero expr ctx = do case reduceCExpr expr ctx of Just ex -> do split ("replace by zero", C.posOf expr) (pure zeroExpr) ex Nothing -> do pure zeroExpr reduceCExpr :: (MonadReduce Lab m) => C.CExpr -> Context -> Maybe (m C.CExpr) reduceCExpr expr ctx = case expr of C.CBinary o elhs erhs ni -> do case reduceCExpr elhs ctx of Just elhs' -> case reduceCExpr erhs ctx of Just erhs' -> pure do split ("reduce to left", C.posOf elhs) elhs' do split ("reduce to right", C.posOf erhs) erhs' do l' <- elhs' r' <- erhs' pure $ C.CBinary o l' r' ni Nothing -> fail "could not reduce right hand side" Nothing | otherwise -> fail "could not reduce left hand side" C.CAssign o elhs erhs ni -> case reduceCExpr elhs (addKeyword DisallowVariableInlining ctx) of Just elhs' -> case reduceCExpr erhs ctx of Just erhs' -> pure do split ("reduce to left", C.posOf elhs) elhs' do split ("reduce to right", C.posOf erhs) erhs' do l' <- elhs' r' <- erhs' pure $ C.CAssign o l' r' ni Nothing -> fail "could not reduce right hand side" Nothing | otherwise -> fail "could not reduce left hand side" C.CVar i _ -> case Map.lookup i . inlineExprs $ ctx of Just mx -> case mx of C.CVar _ _ -> pure (pure mx) _ | DisallowVariableInlining `isIn` ctx -> Nothing | otherwise -> pure (pure mx) Nothing -> fail ("Could not find " <> show i) C.CConst x -> Just do pure $ C.CConst x C.CUnary o elhs ni -> do elhs' <- reduceCExpr elhs (addKeyword DisallowVariableInlining ctx) Just $ split ("reduce to operant", C.posOf expr) elhs' do e <- elhs' pure $ C.CUnary o e ni C.CCall e es ni -> do re <- reduceCExpr e (addKeyword DisallowVariableInlining ctx) Just $ do e' <- re es' <- traverse (`reduceCExprOrZero` ctx) es pure $ C.CCall e' es' ni a -> error (show a) -- C.CCond ec et ef ni -> do -- ec' <- reduce ec -- ef' <- reduce ef -- et' <- optional do -- et' <- liftMaybe et -- reduce et' -- pure $ C.CCond ec' et' ef' ni -- C.CBinary o elhs erhs ni -> onBothExpr elhs erhs \lhs rhs -> -- pure $ C.CBinary o lhs rhs ni -- C.CUnary o elhs ni -> do -- lhs <- reduce elhs -- pure $ C.CUnary o lhs ni -- C.CConst c -> do -- -- TODO fix -- pure $ C.CConst c -- C.CCast cd e ni -> do -- -- TODO fix -- cd' <- reduce @C.CDeclaration cd -- e' <- reduce e -- pure $ C.CCast cd' e' ni -- C.CIndex e1 e2 ni -> do -- e1' <- reduce e1 -- e2' <- orZero (reduce e2) -- pure $ C.CIndex e1' e2' ni -- C.CMember e i b ni -> do -- givenThat (Val.is i) -- e' <- reduce e -- pure $ C.CMember e' i b ni -- C.CComma items ni -> do -- C.CComma <$> collectNonEmpty' reduce items <*> pure ni -- e -> error (show e) -- where -- onBothExpr elhs erhs = onBoth (reduce elhs) (reduce erhs) -- splitIf :: (MonadReduce l m) => Bool -> l -> m a -> m a -> m a -- splitIf True s a b = split s a b -- splitIf False _ _ b = b -- -- splitOn :: (MonadReduce l m, MonadReader Context m) => Keyword -> l -> m a -> m a -> m a -- splitOn k s a b = do -- con <- keyword k -- splitIf con s a b -- -- maybeSplit -- :: (MonadReduce l m) -- => l -- -> Maybe (m a) -- -> Maybe (m a) -- -> Maybe (m a) -- maybeSplit s a b = case a of -- Just a' -> case b of -- Just b' -> Just do -- split s a' b' -- Nothing -> Just a' -- Nothing -> b -- -- maybeSplitOn -- :: (MonadReduce l m) -- => Keyword -- -> l -- -> ReaderT Context Maybe (m a) -- -> ReaderT Context Maybe (m a) -- -> ReaderT Context Maybe (m a) -- maybeSplitOn k s a b = do -- con <- keyword k -- if con -- then b -- else ReaderT \ctx -> -- case runReaderT a ctx of -- Just a' -> case runReaderT b ctx of -- Just b' -> Just $ split s a' b' -- Nothing -> Just a' -- Nothing -> runReaderT b ctx inlineTypeDefs :: forall d. (Data d) => d -> Context -> d inlineTypeDefs r ctx = do case eqT @d @[C.CDeclarationSpecifier C.NodeInfo] of Just Refl -> r & concatMap \case C.CTypeSpec (C.CTypeDef idx _) -> do case Map.lookup idx . typeDefs $ ctx of Just args -> args Nothing -> error ("could not find typedef:" <> show idx) a -> [a] Nothing -> gmapT (`inlineTypeDefs` ctx) r -- instance CReducible C.CExtDecl where -- reduceC (C.CFunDef spc dec cdecls smt ni) = do -- pure $ C.CFunDef spc dec cdecls smt ni identifiers :: forall a. (Data a) => a -> [C.Ident] identifiers d = case cast d of Just l -> [l] Nothing -> concat $ gmapQ identifiers d 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 $> ())) -- 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)