ReduceC.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module ReduceC (
  defaultReduceC,
  defaultReduceCWithKeywords,
  -- reduceCTranslUnit,

  -- * Context
  Context (..),
  defaultContext,

  -- * Helpers
  prettyIdent,
) where

import Control.Applicative (Alternative (empty, (<|>)))
import Control.Monad (
  MonadPlus (mzero),
  foldM,
  forM,
  guard,
  join,
  mapAndUnzipM,
  unless,
  void,
  when,
 )
import qualified Control.Monad.IRTree as IRTree
import Control.Monad.Reduce (
  MonadReduce (split),
  check,
  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.Foldable
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 (
  catMaybes,
  fromMaybe,
  isJust,
  isNothing,
  mapMaybe,
 )
import Data.Monoid
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
import qualified Language.C.Data.Node as C

defaultReduceCWithKeywords :: (MonadReduce (String, C.Position) m) => [Keyword] -> C.CTranslUnit -> m C.CTranslUnit
defaultReduceCWithKeywords keywords a = reduceCTranslUnit a (defaultContext{keywords = Set.fromList keywords})
{-# SPECIALIZE defaultReduceCWithKeywords :: [Keyword] -> C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}

defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.CTranslUnit
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 (C.CTranslUnit es ni) ctx = do
  let _functions = foldMap (findFunctions (: [])) es

  let funmap :: [(C.Ident, Maybe Function)] =
        List.sortOn (maybe 0 (negate . funSize) . snd)
          . Map.toList
          . Map.fromListWith const
          . map (\f -> (funName f, Just f))
          . List.sortOn funSize
          $ _functions

  let reduce funcs = forM funcs \(k, mf) ->
        (k,) <$> runMaybeT do
          f <- liftMaybe mf
          let fstr = C.identToString (funName f)
          when (C.identToString (funName f) /= "main" || LoseMain `isIn` ctx) do
            exceptIf ("remove function " <> fstr <> " (" <> show (funSize f) <> ")", funPosition f)
          isStatic <-
            if funIsStatic f
              then
                split
                  ("remove static from " <> fstr, funPosition f)
                  (pure False)
                  (pure True)
              else pure False
          pure f{funIsStatic = isStatic}

  -- try remove static
  functions2 <- do
    funmap' <- reduce funmap
    if ComputeFunctionFixpoint `isIn` ctx
      then reduce funmap
      else pure funmap'

  functions3 <- forM functions2 \(k, mf) ->
    (k,) <$> runMaybeT do
      f <- liftMaybe mf
      if C.identToString (funName f) /= "main" || LoseMain `isIn` ctx
        then do
          params <- case funParams f of
            Just params -> do
              Just <$> forM (zip [1 :: Int ..] params) \(i, p) ->
                if p
                  then split ("remove parameter " <> show i <> " from " <> C.identToString (funName f), funPosition f) (pure False) (pure True)
                  else pure False
            ow -> pure ow
          pure f{funParams = params}
        else do
          pure f

  let builtins =
        [ ("fabsf", FunType (NonVoid TNum) (Params [Just TNum] False))
        , ("fabs", FunType (NonVoid TNum) (Params [Just TNum] False))
        , ("__builtin_abort", FunType Void (Params [] False))
        ]

  let functions''' =
        Map.fromList $
          [ ( funName
            , Just $
                Function
                  { funIsStatic = False
                  , funPosition = C.posOf funName
                  , funSize = 0
                  , funParams = case funTypeParams funType of
                      VoidParams -> Nothing
                      Params _ True -> Nothing
                      Params fx False -> Just [isJust f | f <- fx]
                  , ..
                  }
            )
          | (C.builtinIdent -> funName, funType) <- builtins
          ]
            <> functions3

  let ctx' =
        ctx
          { functions = functions'''
          , inlineExprs =
              inlineExprs ctx
                <> Map.fromList
                  [(C.builtinIdent f, IEKeep (TFun ft)) | (f, ft) <- builtins]
          }
  res' <- evalStateT (mapM reduceCExternalDeclaration es) ctx'
  pure $ C.CTranslUnit (catMaybes res') ni

newtype SpecifierFilter = SpecifierFilter
  { sfKeepStatic :: Bool
  }

keepAll :: SpecifierFilter
keepAll = SpecifierFilter{sfKeepStatic = True}

{- | Update the CDeclarationSpecifier's to match the context. Specifically, update
the typedefs and the structs. Also return a base type.
-}
updateCDeclarationSpecifiers ::
  forall m.
  ( MonadReduce Lab m
  , HasCallStack
  ) =>
  SpecifierFilter ->
  Context ->
  [C.CDeclarationSpecifier C.NodeInfo] ->
  Maybe (m (Voidable, [C.CDeclarationSpecifier C.NodeInfo]))
updateCDeclarationSpecifiers sf ctx spec = do
  bt <- typeFromCDeclarationSpecifiers ctx spec
  specfn <- mapM updateSpec spec
  Just do
    spec' <- sequence specfn
    pure (bt, concat spec')
 where
  updateSpec ::
    C.CDeclarationSpecifier C.NodeInfo ->
    Maybe (m [C.CDeclarationSpecifier C.NodeInfo])
  updateSpec a = case a of
    C.CTypeSpec t -> case t of
      C.CSUType (C.CStruct st (Just i) (Just declrs) attr x) b -> do
        fields <- case lookupStruct ctx i of
          ISDelete -> empty
          ISDeclared _ -> empty
          ISKeep s -> do
            pure $ structTypeFields s
        Just do
          declrs' <- filterStruct fields declrs
          pure [C.CTypeSpec (C.CSUType (C.CStruct st (Just i) (Just declrs') attr x) b)]
      C.CTypeDef idx _ -> do
        case Map.lookup idx . typeDefs $ ctx of
          Just (ITKeep _) -> Just $ pure [C.CTypeSpec t]
          Just (ITInline _ res) -> Just $ pure res
          Just ITDelete -> Nothing
          Nothing -> error ("could not find typedef: " <> show idx)
      _ow -> Just $ pure [C.CTypeSpec t]
    C.CStorageSpec (C.CStatic _) -> Just $ pure [a | sfKeepStatic sf]
    C.CFunSpec (C.CInlineQual _) -> Just $ pure [a | sfKeepStatic sf]
    _ow -> Just $ pure [a]

  filterStruct ::
    [(a1, Maybe a2)] ->
    [C.CDeclaration C.NodeInfo] ->
    m [C.CDeclaration C.NodeInfo]
  filterStruct fields declrs =
    flip evalStateT fields do
      declrs' <- forM declrs $ \case
        C.CDecl spec2 items l -> runMaybeT do
          items' <- forM items $ \case
            C.CDeclarationItem (C.CDeclr mid dd sl attr ni2) enit ni1 -> runMaybeT do
              _ <- liftMaybe =<< state (\((_, t) : tps) -> (t, tps))
              (_, dd') <- evalStateT (updateCDerivedDeclarators Void (repeat True) dd) ctx
              pure (C.CDeclarationItem (C.CDeclr mid dd' sl attr ni2) enit ni1)
            a' -> notSupportedYet a' l
          (_, spec2') <- joinLiftMaybe (updateCDeclarationSpecifiers keepAll ctx spec2)
          let items'' = catMaybes items'
          guard $ not (List.null items'')
          pure (C.CDecl spec2' items'' l)
        a' -> notSupportedYet' a'
      pure $ catMaybes declrs'

typeFromCDeclarationSpecifiers ::
  forall m.
  ( MonadPlus m
  , HasCallStack
  ) =>
  Context ->
  [C.CDeclarationSpecifier C.NodeInfo] ->
  m Voidable
typeFromCDeclarationSpecifiers ctx =
  liftMaybe
    . exactlyOne
    . map \case
      C.CVoidType _ -> Just Void
      C.CSUType c _ -> NonVoid . TStruct <$> structId c
      C.CCharType _ -> Just $ NonVoid TNum
      C.CShortType _ -> Just $ NonVoid TNum
      C.CIntType _ -> Just $ NonVoid TNum
      C.CFloatType _ -> Just $ NonVoid TNum
      C.CDoubleType _ -> Just $ NonVoid TNum
      C.CSignedType _ -> Just $ NonVoid TNum
      C.CUnsigType _ -> Just $ NonVoid TNum
      C.CBoolType _ -> Just $ NonVoid TNum
      C.CLongType _ -> Just $ NonVoid TNum
      C.CInt128Type _ -> Just $ NonVoid TNum
      C.CFloatNType{} -> Just $ NonVoid TNum
      C.CEnumType (C.CEnum (Just ix) _ _ _) _ ->
        NonVoid TNum
          <$ guard (lookupEnum ctx ix == INKeep)
      C.CEnumType (C.CEnum Nothing _ _ _) _ -> Just $ NonVoid TNum
      C.CTypeDef idx _ ->
        case Map.lookup idx (typeDefs ctx) of
          Just (ITKeep t') -> Just t'
          Just ITDelete -> Nothing
          Just (ITInline t' _) -> Just t'
          Nothing -> error "error"
      a -> notSupportedYet (void a) a
    . typeSpecs
 where
  typeSpecs = mapMaybe \case
    C.CTypeSpec ts -> Just ts
    _ow -> Nothing

  exactlyOne =
    maybe
      (error "no type in type-specs")
      ( \case
          (t, []) -> NonEmpty.head t
          (t, rs) -> error ("more than one type in type-specs: " <> show (t : rs))
      )
      . List.uncons
      . NonEmpty.group

  structId (C.CStruct t mi md _ ni) =
    case mi of
      Just ix -> case lookupStruct ctx ix of
        ISDelete -> Nothing
        _ow -> Just $ Left ix
      Nothing ->
        let p' =
              maybe
                (error $ "invalid struct at" <> show (C.posOf ni))
                (concatMap namesAndTypeOf)
                md
         in pure $ Right (StructType t Nothing p')

  namesAndTypeOf = \case
    C.CDecl spec2 items ni ->
      flip map items \case
        C.CDeclarationItem decl@(C.CDeclr (Just ix) _ _ _ _) _ _ ->
          (ix, nonVoid <$> typeOf spec2 decl)
        a -> notSupportedYet (void a) ni
    a -> notSupportedYet' a

  typeOf spec2 decl = typeFromCDeclarationSpecifiers ctx spec2 >>= extendTypeWith decl

  extendTypeWith (C.CDeclr _ dd _ _ _) t =
    foldr applyDD (Just t) dd
   where
    applyDD = \case
      C.CPtrDeclr _ _ -> fmap (NonVoid . TPointer)
      C.CArrDeclr{} -> fmap (NonVoid . TPointer)
      C.CFunDeclr params _ ni -> \c ->
        case params of
          C.CFunParamsNew params' varadic -> do
            c' <- c
            Just $ NonVoid $ TFun (FunType c' (findParams varadic params'))
          b -> notSupportedYet b ni

    findParams varadic = \case
      [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> VoidParams
      rst -> flip Params varadic $ flip map rst \case
        C.CDecl spec' [] _ ->
          nonVoid <$> typeFromCDeclarationSpecifiers ctx spec'
        C.CDecl spec' [C.CDeclarationItem decl _ _] _ ->
          nonVoid <$> typeOf spec' decl
        a -> notSupportedYet' a

typeFromCDerivedDeclarators ::
  forall m.
  ( MonadPlus m
  ) =>
  Voidable ->
  Context ->
  [C.CDerivedDeclarator C.NodeInfo] ->
  m Voidable
typeFromCDerivedDeclarators bt ctx dd =
  foldM applyDD bt (reverse dd)
 where
  applyDD ::
    (r ~ Voidable) =>
    r ->
    C.CDerivedDeclarator C.NodeInfo ->
    m r
  applyDD t d = case d of
    C.CPtrDeclr _ _ -> do
      pure (NonVoid . TPointer $ t)
    C.CArrDeclr{} -> do
      pure (NonVoid . TPointer $ t)
    C.CFunDeclr params _ ni -> do
      case params of
        C.CFunParamsNew params' varadic -> do
          tp <- findParams varadic params'
          let t' = NonVoid $ TFun (FunType t tp)
          pure t'
        b -> notSupportedYet b ni

  findParams ::
    Bool ->
    [C.CDeclaration C.NodeInfo] ->
    m Params
  findParams varadic decls = case decls of
    [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] ->
      pure VoidParams
    _ow -> do
      result <-
        forM decls $ \case
          C.CDecl spec items ni -> do
            bt' <- typeFromCDeclarationSpecifiers ctx spec
            case items of
              [] -> do
                pure $ nonVoid bt'
              [C.CDeclarationItem (C.CDeclr _ dd2 Nothing [] _) Nothing _] -> do
                (nonVoid -> t) <- typeFromCDerivedDeclarators bt' ctx dd2
                pure t
              _ow -> notSupportedYet items ni
          a -> notSupportedYet' a
      pure (Params (map Just result) varadic)

updateCDerivedDeclarators ::
  forall m.
  ( MonadState Context m
  , MonadReduce (String, C.Position) 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 (t, dd') d = case d of
    C.CPtrDeclr _ _ -> do
      pure (NonVoid . TPointer $ t, d : dd')
    C.CArrDeclr r as ni -> do
      d' <- case as of
        C.CArrSize _ _ -> do
          -- b <- check ("remove array size", C.posOf ni)
          let b = False
          pure $ if b then C.CArrDeclr r (C.CNoArrSize False) ni else d
        _ -> pure d
      pure (NonVoid . TPointer $ t, d' : dd')
    C.CFunDeclr params arr ni -> do
      case params of
        C.CFunParamsNew params' varadic -> do
          (tp, params'') <- findParams varadic params'
          let t' = NonVoid $ TFun (FunType t tp)
          pure (t', C.CFunDeclr (C.CFunParamsNew params'' varadic) arr ni : dd')
        b -> notSupportedYet b ni

  findParams ::
    Bool ->
    [C.CDeclaration C.NodeInfo] ->
    m (Params, [C.CDeclaration C.NodeInfo])
  findParams varadic decls = case decls of
    [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] ->
      pure (VoidParams, decls)
    _ow -> flip evalStateT ff do
      result <-
        forM decls $ \case
          C.CDecl spec items ni -> do
            keep <- state (\(t : tps) -> (t, tps))
            lift . runMaybeT $ do
              markDeleted items
              ctx <- get
              (bt', spec') <- join (liftMaybe $ updateCDeclarationSpecifiers keepAll ctx spec)
              (t, items') <- case items of
                [] -> do
                  guard keep
                  pure (nonVoid bt', [])
                [C.CDeclarationItem (C.CDeclr mid dd2 Nothing [] ni3) Nothing ni2] -> do
                  (t, dd2') <- case mid of
                    Just ix -> do
                      (nonVoid -> t, dd2') <- updateCDerivedDeclarators bt' [] dd2
                      guard keep
                      modify' (addInlineExpr ix (IEKeep t))
                      pure (t, dd2')
                    Nothing -> do
                      (nonVoid -> t, dd2') <- updateCDerivedDeclarators bt' [] dd2
                      guard keep
                      pure (t, dd2')
                  pure (t, [C.CDeclarationItem (C.CDeclr mid dd2' Nothing [] ni3) Nothing ni2])
                _ow -> notSupportedYet items ni
              pure (t, C.CDecl spec' items' ni)
          a -> notSupportedYet' a
      let (ts, decls') = unzip $ flip map result \case
            Just (t, d') -> (Just t, [d'])
            Nothing -> (Nothing, [])
      pure (Params ts varadic, concat decls')

joinLiftMaybe :: (MonadPlus m) => Maybe (m a) -> m a
joinLiftMaybe = join . liftMaybe

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

    let C.CDeclr mid dd Nothing [] ni2 = declr

    mfun <- case mid of
      Just fid -> do
        modify' (addInlineExpr fid IEDelete)
        Just <$> liftMaybe (lookupFunction ctx fid)
      Nothing ->
        pure Nothing

    let keepStatic = maybe True funIsStatic mfun
    -- TODO handle this edgecase (struct declared in function declaration)
    _ <- reduceStructDeclaration spec

    ctx' <- get
    (bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll{sfKeepStatic = keepStatic} ctx' spec
    ((t', dd'), ctx'') <- runStateT (updateCDerivedDeclarators bt (fromMaybe (repeat True) (mfun >>= funParams)) dd) ctx'

    let t@(TFun (FunType rt _)) = nonVoid t'

    case mfun of
      Just fun -> do
        modify' (addInlineExpr (funName fun) (IEKeep t))
      Nothing -> do
        exceptIf ("remove function", C.posOf r)

    labs <- flip collect (labelsOf stmt) \l -> do
      exceptIf ("remove label" <> show l, C.posOf l)
      pure l

    stmt' <-
      reduceCStatementOrEmptyBlock stmt StmtContext{stmtLabels = labs, stmtInLoop = False} $
        ctx''{returnType = rt}

    pure . C.CFDefExt $
      C.CFunDef spec' (C.CDeclr mid dd' Nothing [] ni2) [] stmt' ni

  -- Type definitions
  C.CDeclExt (C.CDecl (C.CStorageSpec (C.CTypedef nif) : rst) [item] ni) -> runMaybeT do
    (ix, dd, wrap) <- case item of
      C.CDeclarationItem (C.CDeclr (Just ix) dd Nothing extras _) Nothing Nothing ->
        case extras of
          [] -> pure (ix, dd, id)
          [C.CAttr (C.Ident "__vector_size__" _ _) [a] _] -> do
            case a of
              C.CBinary C.CMulOp (C.CConst (C.CIntConst (C.CInteger n _ _) _)) (C.CSizeofType _ _) _ ->
                -- todo assuming this is a checked size
                pure
                  ( ix
                  , dd
                  , NonVoid . TVector (fromInteger n)
                  )
              _ -> notSupportedYet a ni
          a -> notSupportedYet (map void a) ni
      i -> notSupportedYet (void i) ni

    modify' (addTypeDef ix ITDelete)

    keep <- reduceStructDeclaration rst
    ctx <- get
    (bt, rst') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll ctx rst

    (t, _) <- updateCDerivedDeclarators bt (repeat True) dd

    unless keep do
      modify' (addTypeDef ix (ITInline (wrap t) rst'))
      exceptIf ("inline typedef " <> C.identToString ix, C.posOf ni)

    modify' (addTypeDef ix (ITKeep (wrap t)))
    pure $ C.CDeclExt $ C.CDecl (C.CStorageSpec (C.CTypedef nif) : rst') [item] ni

  -- The rest.
  C.CDeclExt (C.CDecl spec items ni) -> runMaybeT do
    ctx <- get

    markDeleted items

    -- TODO: Actually we should split it up here
    let forceStatic =
          getAny <$> flip foldMap items \case
            (C.CDeclarationItem (C.CDeclr (Just fid) (C.CFunDeclr{} : _) _ _ _) _ _) -> do
              Any . funIsStatic <$> lookupFunction ctx fid
            _ow -> Nothing

    keep <- reduceStructDeclaration spec

    isStatic <- case forceStatic of
      Just t -> pure t
      Nothing ->
        if any isStaticSpec spec
          then not <$> check ("make declaration non-static", C.posOf ni)
          else return False

    ctx' <- get
    (bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll{sfKeepStatic = isStatic} ctx' spec
    -- Try to remove each declaration item
    items' <-
      flip collect items \case
        di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size) -> do
          case dd of
            C.CFunDeclr{} : _ -> do
              mfun <- case mid of
                Just fid ->
                  Just <$> liftMaybe (lookupFunction ctx' fid)
                Nothing ->
                  pure Nothing
              let ff = fromMaybe (repeat True) (mfun >>= funParams)
              (nonVoid -> t, dd') <-
                updateCDerivedDeclarators bt ff dd
              case mid of
                Just fid -> do
                  modify' (addInlineExpr fid IEDelete)
                  exceptIf ("remove function declaration", C.posOf ni2)
                  modify' (addInlineExpr fid (IEKeep t))
                Nothing -> do
                  exceptIf ("remove function", C.posOf ni2)
              pure (C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni2) einit size)
            _dd -> reduceCDeclarationItem bt True di
        a -> notSupportedYet (a $> ()) ni

    -- Somtimes we just declare a struct or a typedef.
    when (not keep && List.null items') do
      guard (AllowEmptyDeclarations `isIn` ctx' || List.null items)
      exceptIf ("remove declaration", C.posOf ni)

    pure $ C.CDeclExt $ C.CDecl spec' items' ni
  _r -> notSupportedYet' r

isStaticSpec :: C.CDeclarationSpecifier C.NodeInfo -> Bool
isStaticSpec = \case
  C.CStorageSpec (C.CStatic _) -> True
  _ -> False

wrapCCompound :: C.CStatement C.NodeInfo -> C.CStatement C.NodeInfo
wrapCCompound = \case
  s@(C.CCompound{}) -> s
  s -> C.CCompound [] [C.CBlockStmt s] C.undefNode

isStaticFromSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Bool
isStaticFromSpecs = any \case
  (C.CStorageSpec (C.CStatic _)) -> True
  _ow -> False

{- | 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 =
  fmap or . mapM \case
    C.CTypeSpec (C.CEnumType (C.CEnum mid mf _ _) ni) -> do
      case mid of
        Just eid -> do
          case mf of
            Just times -> forM_ times \(C.CEnumVar ix _) -> do
              modify' (addInlineExpr ix IEDelete)
            Nothing -> pure ()
          modify' (addEnum eid INDelete)
          exceptIf ("delete enum " <> C.identToString eid, C.posOf ni)
          modify' (addEnum eid INKeep)
          case mf of
            Just times -> forM_ times \(C.CEnumVar ix _) -> do
              modify' (addInlineExpr ix (IEKeep TNum))
            Nothing -> pure ()

          pure True
        Nothing -> do
          pure False
    C.CTypeSpec (C.CSUType (C.CStruct tag mid mfields _ _) ni) -> case mid of
      Just sid -> do
        struct <- gets (Map.lookup sid . structs)
        let reduce fields = do
              exceptIf ("remove struct " <> C.identToString sid, C.posOf ni)
              modify' (addStruct sid (ISDeclared tag))
              (ft, _) <- mapAndUnzipM (structField sid) fields
              modify' (addStruct sid (ISKeep (StructType tag (Just sid) (concat ft))))
              pure True
        case struct of
          Just (ISDeclared _) ->
            case mfields of
              Just fields -> reduce fields
              Nothing -> pure False
          Just (ISKeep _) -> do
            pure False
          Just ISDelete -> do
            case mfields of
              Just fields -> reduce fields
              Nothing -> pure True
          Nothing -> do
            modify' (addStruct sid ISDelete)
            case mfields of
              Just fields -> reduce fields
              Nothing -> do
                exceptIf ("remove struct declaration " <> C.identToString sid, C.posOf ni)
                modify' (addStruct sid (ISDeclared tag))
                pure True
      Nothing -> pure False
    _ow -> pure False
 where
  structField sid = \case
    C.CDecl spec items ni -> do
      ctx <- get
      case updateCDeclarationSpecifiers keepAll ctx spec of
        Just fn -> do
          (bt, spec') <- fn
          (fields, items') <- flip mapAndUnzipM items \case
            (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni3) ini ni2) -> do
              let fid = fromMaybe (error "all struct fields should be named") mid
              res' <- runMaybeT $ do
                (nonVoid -> t, dd') <- updateCDerivedDeclarators bt (repeat True) dd
                exceptIf ("remove field " <> C.identToString sid <> "." <> C.identToString fid, C.posOf ni)
                pure (t, dd')
              case res' of
                Nothing -> pure ((fid, Nothing), Nothing)
                Just (t, dd') -> pure ((fid, Just t), Just $ C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni3) ini ni2)
            a -> notSupportedYet a ni
          case catMaybes items' of
            [] -> pure (fields, Nothing)
            items'' -> pure (fields, Just (C.CDecl spec' items'' ni))
        Nothing ->
          pure
            ( map (\i -> (fromMaybe (error "all struct fields should be named") (name i), Nothing)) items
            , Nothing
            )
    a@(C.CStaticAssert{}) -> notSupportedYet' a

reduceCDeclarationItem ::
  ( MonadReduce Lab m
  , MonadState Context m
  , MonadPlus m
  ) =>
  Voidable ->
  Bool ->
  C.CDeclarationItem C.NodeInfo ->
  m (C.CDeclarationItem C.NodeInfo)
reduceCDeclarationItem bt nullable = \case
  di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni) einit Nothing) -> do
    case mid of
      Just vid -> do
        (nonVoid -> t, dd') <- updateCDerivedDeclarators bt (repeat True) dd
        einit' <- case einit of
          Just einit2 -> do
            ctx <- get
            einit' <-
              whenSplit
                nullable
                ("remove initialization", C.posOf ni)
                (pure Nothing)
                (Just <$> reduceCInitializer t einit2 ctx)
            case getInlinable (fromMaybe einit2 einit') of
              Just e' -> do
                modify' (addInlineExpr vid (IEInline e'))
                exceptIf ("inline variable " <> C.identToString vid, C.posOf ni)
              Nothing -> do
                exceptIf ("delete variable", C.posOf ni)
            pure einit'
          Nothing -> do
            exceptIf ("delete uninitilized variable", C.posOf ni)
            initialize <- gets (InitializeVariables `isIn`)
            whenSplit
              (t == TNum && initialize)
              ("initilize variable", C.posOf ni)
              (pure . Just $ C.CInitExpr zeroExpr C.undefNode)
              (pure Nothing)
        modify' (addInlineExpr vid (IEKeep t))
        let decl' = C.CDeclr mid dd' Nothing [] ni
        pure (C.CDeclarationItem decl' einit' Nothing)
      Nothing -> do
        exceptIf ("remove unnamed declaration item", C.posOf ni)
        pure di
  a -> notSupportedYet a C.undefNode

getInlinable :: C.CInitializer C.NodeInfo -> Maybe C.CExpr
getInlinable = \case
  C.CInitExpr e _ -> case e of
    C.CConst _ -> Just e
    C.CVar _ _ -> Just e
    _ -> Nothing
  C.CInitList _ _ -> Nothing

reduceCInitializer ::
  (MonadReduce Lab m) =>
  Type ->
  C.CInitializer C.NodeInfo ->
  Context ->
  m (C.CInitializer C.NodeInfo)
reduceCInitializer t einit ctx = case einit of
  C.CInitExpr e ni2 -> do
    let me = reduceCExpr e (exactly t) ctx
    case (me, t) of
      (Just es, _) -> do
        e' <- es
        pure $ C.CInitExpr e' ni2
      (Nothing, TVector n _) -> do
        let items' = [([], C.CInitExpr zeroExpr ni2) | _ <- replicate n ()]
        pure $ C.CInitList (C.CInitializerList items') ni2
      (Nothing, _) -> do
        let e' = zeroExpr
        pure $ C.CInitExpr e' ni2
  C.CInitList (C.CInitializerList items) ni2 -> do
    items' <- case t of
      TStruct stct -> do
        let fields = fieldsOfStruct ctx stct
        let i'' = catMaybes $ zipWith (\(_, t') i -> (i,) <$> t') fields items
        forM i'' \((p, r), t') -> do
          r' <- reduceCInitializer t' r ctx
          pure (p, r')
      TPointer (NonVoid t') -> do
        forM items \(p, r) -> do
          r' <- reduceCInitializer t' r ctx
          pure (p, r')
      _ow ->
        -- "Unexpected type of init list: " <> show t <> " at " <> show (C.posOf ni2)
        pure items
    pure $ C.CInitList (C.CInitializerList items') ni2

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
      ctx <- get
      msmt <- runMaybeT $ reduceCStatement smt lab ctx
      case msmt of
        Just smt' -> do
          case smt' of
            C.CCompound [] ss _ ->
              whenSplit
                (all (\case C.CBlockStmt _ -> True; _ow -> False) ss)
                ("expand compound statment", C.posOf r)
                (pure ss)
                (pure [C.CBlockStmt smt'])
            _ow -> pure [C.CBlockStmt smt']
        Nothing -> pure []
    C.CBlockDecl (C.CDecl spec items ni) -> fmap (fromMaybe []) . runMaybeT $ do
      ctx <- get

      markDeleted items

      keep <- reduceStructDeclaration spec
      (bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll ctx spec

      -- Try to remove each declaration item
      items' <- collect (reduceCDeclarationItem bt False) items

      -- Somtimes we just declare a struct or a typedef.
      when (not keep && List.null items') do
        guard (AllowEmptyDeclarations `isIn` ctx || List.null items)
        exceptIf ("remove declaration", C.posOf ni)

      pure [C.CBlockDecl (C.CDecl spec' items' ni)]
    a -> notSupportedYet' a

markDeleted :: (MonadState Context m) => [C.CDeclarationItem C.NodeInfo] -> m ()
markDeleted = mapM_ \case
  C.CDeclarationItem (name -> Just ix) _ _ -> do
    modify' (addInlineExpr ix IEDelete)
  _a -> pure ()

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 stmt ids ctx = do
  fromMaybe (C.CExpr Nothing C.undefNode)
    <$> runMaybeT (reduceCStatement stmt ids ctx)

emptyBlock :: C.CStatement C.NodeInfo
emptyBlock = C.CCompound [] [] C.undefNode

data StmtContext = StmtContext
  { stmtLabels :: ![C.Ident]
  , stmtInLoop :: !Bool
  }
  deriving (Show, Eq)

etAny :: EType
etAny = EType ETAny False

etNum :: EType
etNum = EType (ETExactly TNum) False

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 smt labs ctx = case smt of
  C.CCompound is cbi ni -> do
    cbi' <- lift $ evalStateT (mapM (reduceCCompoundBlockItem labs) cbi) ctx
    pure (C.CCompound is (concat cbi') ni)
  C.CWhile e s dow ni -> split
    ("remove while loop", C.posOf ni)
    do
      reduceCStatement s labs ctx
    do
      s' <- reduceCStatement s labs{stmtInLoop = True} ctx
      e' <- fromMaybe (pure zeroExpr) (reduceCExpr e etNum ctx)
      pure $ C.CWhile e' s' dow ni
  C.CExpr me ni -> do
    case me of
      Just e -> do
        if DoNoops `isIn` ctx
          then do
            e' <-
              maybeSplit ("change to noop", C.posOf smt) $
                reduceCExpr e etAny ctx
            pure $ C.CExpr e' ni
          else do
            re' <- liftMaybe $ reduceCExpr e etAny ctx
            exceptIf ("remove expr statement", C.posOf smt)
            e' <- re'
            pure $ C.CExpr (Just e') ni
      Nothing -> do
        exceptIf ("remove expr statement", C.posOf smt)
        pure $ C.CExpr Nothing ni
  C.CReturn me ni -> do
    re :: m (Maybe C.CExpr) <- case me of
      Just e -> do
        case returnType ctx of
          NonVoid rt -> do
            res :: (m C.CExpr) <- liftMaybe (reduceCExpr e (exactly rt) ctx)
            pure (Just <$> res)
          Void -> pure (pure Nothing)
      Nothing -> pure (pure Nothing)
    exceptIf ("remove return statement", C.posOf smt)
    e <- lift re
    pure $ C.CReturn e ni
  C.CIf e s els ni -> do
    e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e etNum ctx
    els' <- lift . runMaybeT $ do
      els' <- liftMaybe els
      exceptIf ("remove else branch", C.posOf e)
      reduceCStatement els' labs ctx
    ms' <- lift . runMaybeT $ do
      exceptIf ("remove if branch", C.posOf e)
      reduceCStatement s labs ctx
    case (e', ms', els') of
      (Nothing, Nothing, Nothing) -> empty
      (Just e'', Just s', Nothing) -> pure $ C.CIf e'' s' Nothing ni
      (Nothing, Just s', Just x) -> pure $ C.CIf zeroExpr s' (Just x) ni
      (Just e'', Just s', Just x) -> pure $ C.CIf e'' s' (Just x) ni
      (Just e'', Nothing, Nothing) -> pure $ C.CExpr (Just e'') C.undefNode
      (Nothing, Nothing, Just x) -> pure x
      (Just e'', Nothing, Just x) -> pure $ C.CIf e'' emptyBlock (Just x) ni
      (Nothing, Just s', Nothing) -> pure s'
  C.CFor e1 e2 e3 s ni -> case e1 of
    C.CForDecl d@(C.CDecl spec items ni') -> split
      ("remove the for loop", C.posOf ni)
      (reduceCStatement (C.CCompound [] [C.CBlockDecl d, C.CBlockStmt s] C.undefNode) labs ctx)
      do
        (bt, spec') <- joinLiftMaybe $ updateCDeclarationSpecifiers keepAll ctx spec
        (items', ctx') <- flip runStateT ctx do
          markDeleted items
          collect (reduceCDeclarationItem bt False) items
        e2' <- runMaybeT do
          e2' <- liftMaybe e2
          re2' <- liftMaybe (reduceCExpr e2' etAny ctx')
          exceptIf ("remove check", C.posOf e2')
          re2'
        e3' <- runMaybeT do
          e3' <- liftMaybe e3
          re3' <- liftMaybe (reduceCExpr e3' etAny ctx')
          exceptIf ("remove iterator", C.posOf e3')
          re3'
        let e2'' =
              if AllowInfiniteForLoops `isIn` ctx || isNothing e2
                then e2'
                else e2' <|> Just zeroExpr
        s' <- reduceCStatementOrEmptyExpr s labs{stmtInLoop = True} ctx'
        pure $ C.CFor (C.CForDecl (C.CDecl spec' items' ni')) e2'' e3' s' ni
    C.CForInitializing e -> split
      ("remove the for loop", C.posOf ni)
      ( reduceCStatement
          ( C.CCompound
              []
              [C.CBlockStmt (C.CExpr e C.undefNode), C.CBlockStmt s]
              C.undefNode
          )
          labs
          ctx
      )
      do
        e' <-
          maybeSplit ("remove initializer", C.posOf ni) $
            e >>= \e' ->
              reduceCExpr e' etAny ctx