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 CType
import Control.Applicative
import Control.Monad
import qualified Control.Monad.IRTree as IRTree
import Control.Monad.Reduce
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.Bifunctor
import Data.Function
import Data.Functor
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import Data.Maybe
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
import Debug.Pretty.Simple
import Language.C (Pos (posOf))
import qualified Language.C as C
import qualified Language.C.Data.Ident as C
import qualified Language.C.Data.Node as C
import Text.Pretty.Simple (pShow)

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
      params <- case funParams f of
        Just params -> do
          Just <$> forM params \p ->
            if p
              then split ("remove parameter", funPosition f) (pure False) (pure True)
              else pure False
        ow -> pure ow
      pure f{funParams = params}

  let builtins =
        [ ("fabsf", FunType (NonVoid TNum) (Params [Just TNum] False))
        , ("fabs", FunType (NonVoid TNum) (Params [Just TNum] 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 _structs = foldMap (findStructs (: [])) es
  -- structs' <- flip execStateT (structs ctx) do
  --   forM_ _structs \s -> do
  --     let sstr = C.identToString (structName s)
  --     ms <- runMaybeT do
  --       exceptIf ("remove struct " <> show sstr, structPosition s)
  --       let st = structType s
  --       fields <- forM (structTypeFields st) \(i, m) -> do
  --         (i,) <$> runMaybeT do
  --           m' <- liftMaybe m
  --           exceptIf ("remove field " <> sstr <> "." <> C.identToString i, structPosition s)
  --           pure m'
  --       pure s{structType = st{structTypeFields = fields}}
  --     modify' (Map.insert (structName s) (structType s, ms))

  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

data 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. Alos return a base type.
-}
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 ctx = do
    liftMaybe
      . baseTypeOf
        (lookupStruct ctx)
        ( \t -> case Map.lookup t (typeDefs ctx) of
            Just (ITKeep t') -> Just t'
            Just ITDelete -> Nothing
            Just (ITInline t' _) -> Just t'
            Nothing -> error "error"
        )

  updateSpec ctx a = case a of
    C.CTypeSpec t -> case t of
      C.CSUType (C.CStruct st (Just i) (Just declrs) attr x) b -> do
        fields <- liftMaybe $ structTypeFields <$> lookupStruct ctx i
        let declrs' :: [C.CDeclaration C.NodeInfo] = filterStruct ctx 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 _) -> pure [C.CTypeSpec t]
          Just (ITInline _ res) -> pure res
          Just ITDelete -> mzero
          Nothing -> error ("could not find typedef: " <> show idx)
      _ow -> pure [C.CTypeSpec t]
    C.CStorageSpec (C.CStatic _) -> pure [a | sfKeepStatic sf]
    C.CFunSpec (C.CInlineQual _) -> pure [a | sfKeepStatic sf]
    _ow -> pure [a]

  filterStruct ctx fields declrs = flip evalState fields do
    fmap concat . forM declrs $ \case
      decl@(C.CDecl def items l) -> do
        items' <- fmap catMaybes . forM items $ \item -> do
          t' <- state (\((_, t) : tps) -> (t, tps))
          case t' of
            Just _ -> do
              -- TODO check for bad struct name here declaration
              pure (Just item)
            _ow -> do
              pure Nothing
        pure [C.CDecl def items' l | not (List.null items')]
      a' -> notSupportedYet' a'

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 (t, dd') d = case d of
    C.CPtrDeclr _ _ -> do
      pure (NonVoid . TPointer $ t, d : dd')
    C.CArrDeclr{} ->
      pure (NonVoid . TPointer $ t, d : dd')
    C.CFunDeclr params arr ni -> do
      case params of
        C.CFunParamsNew params' varadic -> do
          (tp, params'') <- state (runState (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]
    -> State Context (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
              (bt', spec') <- updateCDeclarationSpecifiers keepAll 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
                      modify' (addInlineExpr ix IEDelete)
                      (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 (t, decls') = unzip $ catMaybes result
      pure (Params (map Just t) varadic, decls')

-- filterParams
--   :: Context
--   -> [Maybe Type]
--   -> [C.CDeclaration C.NodeInfo]
--   -> ([C.CDeclaration C.NodeInfo], [(C.Ident, InlineExpr)])
-- filterParams ctx typefilter params = flip evalState typefilter do
--   (params', mapping) <- flip mapAndUnzipM params \case
--     decl@(C.CDecl def items l) -> do
--       t' <- state (\(t : tps) -> (t, tps))
--       case t' of
--         Just t
--           | not (shouldDeleteDeclaration ctx decl) -> do
--               let defs = [(idx', IEKeep t) | i <- items, idx' <- maybeToList (name i)]
--               pure ([C.CDecl def items l], defs)
--         _ow -> do
--           let defs = [(idx', IEDelete) | i <- items, idx' <- maybeToList (name i)]
--           pure ([], defs)
--     a' -> notSupportedYet' a'
--   pure (concat params', concat mapping)

-- inlineTypeDefsCDeclaration :: C.CDeclaration C.NodeInfo -> Context -> C.CDeclaration C.NodeInfo
-- inlineTypeDefsCDeclaration decl ctx =
--   case decl of
--     C.CDecl items decli ni ->
--       C.CDecl (inlineTypeDefsSpecs items ctx) (map (`inlineTypeDefsCDI` ctx) decli) ni
--     a -> notSupportedYet' a
--
-- inlineTypeDefsCDeclarator
--   :: C.CDeclarator C.NodeInfo
--   -> Context
--   -> C.CDeclarator C.NodeInfo
-- inlineTypeDefsCDeclarator (C.CDeclr idn derivedd st atr ni) ctx =
--   C.CDeclr idn (map (inlineTypeDefsX ctx) derivedd) st atr ni
--
-- inlineTypeDefsX :: Context -> C.CDerivedDeclarator C.NodeInfo -> C.CDerivedDeclarator C.NodeInfo
-- inlineTypeDefsX ctx = \case
--   C.CFunDeclr (C.CFunParamsNew x y) b c ->
--     C.CFunDeclr (C.CFunParamsNew (map (`inlineTypeDefsCDeclaration` ctx) x) y) b c
--   C.CArrDeclr a b c -> C.CArrDeclr a b c
--   C.CPtrDeclr a b -> C.CPtrDeclr a b
--   a -> notSupportedYet' a
--
-- inlineTypeDefsCDI :: C.CDeclarationItem C.NodeInfo -> Context -> C.CDeclarationItem C.NodeInfo
-- inlineTypeDefsCDI di ctx = case di of
--   C.CDeclarationItem a b ni -> C.CDeclarationItem (inlineTypeDefsCDeclarator a ctx) b ni
--   a -> notSupportedYet a C.undefNode

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

    -- TODO handle this edgecase (struct declared in function declaration)
    (_, spec2) <- reduceStructDeclaration spec

    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

    (bt, spec') <- updateCDeclarationSpecifiers keepAll{sfKeepStatic = keepStatic} spec2
    ((nonVoid -> t@(TFun (FunType rt _)), dd'), ctx') <-
      runStateT
        (updateCDerivedDeclarators bt (fromMaybe (repeat True) (mfun >>= funParams)) dd)
        ctx

    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
    let C.CDeclarationItem (C.CDeclr (Just ix) [] Nothing [] _) Nothing Nothing = item

    modify' (addTypeDef ix ITDelete)

    (keep, rst2) <- reduceStructDeclaration rst
    (NonVoid t, rst') <- updateCDeclarationSpecifiers keepAll rst2

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

    modify' (addTypeDef ix (ITKeep 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 isStatic = flip any items \case
          (C.CDeclarationItem (C.CDeclr (Just fid) (C.CFunDeclr{} : _) _ _ _) _ _) -> do
            maybe True funIsStatic (lookupFunction ctx fid)
          _ow -> True

    (keep, spec2) <- reduceStructDeclaration spec

    (bt, spec') <- updateCDeclarationSpecifiers keepAll{sfKeepStatic = isStatic} spec2
    -- 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') <-
                evalStateT (updateCDerivedDeclarators bt ff dd) ctx
              case mid of
                Just fid -> do
                  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 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)
      exceptIf ("remove declaration", C.posOf ni)

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

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, [C.CDeclarationSpecifier C.NodeInfo])
reduceStructDeclaration =
  fmap (first or) . mapAndUnzipM \case
    x@(C.CTypeSpec (C.CSUType (C.CStruct tag mid (Just fields) attr ni2) ni)) -> case mid of
      Just sid -> do
        struct <- gets (Map.lookup sid . structs)
        case struct of
          -- Already declared do nothing.
          Just _ ->
            pure (False, x)
          -- Not declared do somthing
          Nothing -> do
            split
              ("remove struct " <> C.identToString sid, C.posOf ni)
              do
                modify' (addStruct sid Nothing)
                mzero
              do
                (ft, catMaybes -> fields') <- mapAndUnzipM (structField sid) fields
                modify'
                  ( addStruct
                      sid
                      ( Just
                          StructType
                            { structTypeTag = tag
                            , structTypeName = Just sid
                            , structTypeFields = concat ft
                            }
                      )
                  )
                pure (True, C.CTypeSpec (C.CSUType (C.CStruct tag mid (Just fields') attr ni2) ni))
      Nothing -> pure (False, x)
    x -> pure (False, x)
 where
  structField sid = \case
    C.CDecl spec items ni -> do
      -- TODO: Currently deletes all struct fields if one of them are deleted.
      res <- runMaybeT $ updateCDeclarationSpecifiers keepAll spec
      case res of
        Just (bt, spec') -> do
          (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
  -> 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
    case mid of
      Just vid -> do
        (nonVoid -> t, dd') <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx
        einit' <- case einit of
          Just einit2 -> do
            (einit', inlinable) <- reduceCInitializer t einit2 ctx
            case inlinable 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 (Just einit')
          Nothing -> do
            exceptIf ("delete uninitilized variable", C.posOf ni)
            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

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
    pure
      ( C.CInitExpr e' ni2
      , case e' of
          C.CConst _ -> Just e'
          C.CVar _ _ -> Just e'
          _ow -> Nothing
      )
  C.CInitList (C.CInitializerList items) ni2 -> do
    items' <- case t of
      TStruct stct -> do
        let i'' = catMaybes $ zipWith (\(_, t') i -> (i,) <$> t') (structTypeFields stct) 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 -> error $ "Unexpected type of init list" <> show t
    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 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, spec2) <- reduceStructDeclaration spec
      (bt, spec') <- updateCDeclarationSpecifiers keepAll spec2

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

      -- Somtimes we just declare a struct or a typedef.
      when (not keep && List.null items') do
        guard (AllowEmptyDeclarations `isIn` ctx)
        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
      reduceCStatement els' labs ctx
    ms' <- lift . runMaybeT $ reduceCStatement s labs ctx
    case (e', ms', els') of
      (Nothing, Nothing, Nothing) -> pure emptyBlock
      (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 -> do
    case e1 of
      C.CForDecl (C.CDecl spec items ni') -> do
        (bt, spec') <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx
        (items', ctx') <- runStateT (collect (reduceCDeclarationItem bt) items) ctx
        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'
        -- Todo allow removal of these loops as well
        pure $ C.CFor (C.CForDecl (C.CDecl spec' items' ni')) e2'' e3' s' ni
      C.CForInitializing e -> do
        split
          ("remove the for loop", C.posOf ni)
          do
            reduceCStatement s labs ctx
          do
            e' <- maybeSplit ("remove initializer", C.posOf ni) (e >>= \e' -> reduceCExpr e' etAny ctx)
            e2' <- runMaybeT do
              e2' <- liftMaybe e2
              re2' <- liftMaybe (reduceCExpr e2' etNum 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.CForInitializing e') e2'' e3' s' ni
      d -> notSupportedYet d ni
  C.CLabel i s [] ni -> do
    if i `List.elem` stmtLabels labs
      then do
        s' <- lift $ reduceCStatementOrEmptyExpr s labs ctx
        pure $ C.CLabel i s' [] ni
      else do
        empty
  C.CGoto i ni ->
    if i `List.elem` stmtLabels labs
      then do
        exceptIf ("remove goto", C.posOf smt)
        pure $ C.CGoto i ni
      else empty
  C.CBreak n ->
    if stmtInLoop labs
      then do
        exceptIf ("remove break", C.posOf smt)
        pure $ C.CBreak n
      else empty
  C.CCont n ->
    if stmtInLoop labs
      then do
        exceptIf ("remove continue", C.posOf smt)
        pure $ C.CCont n
      else empty
  a -> notSupportedYet' a

-- | 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, HasCallStack) => C.CExpr -> Context -> m C.CExpr
-- reduceCExprOrZero expr ctx = do
--   case reduceCExpr expr ctx of
--     Just ex -> do
--       r <- ex
--       if r == zeroExpr
--         then pure r
--         else split ("replace by zero", C.posOf expr) (pure zeroExpr) (pure r)
--     Nothing -> do
--       pure zeroExpr
-- {-# INLINE reduceCExprOrZero #-}

-- | The expected type
data EType = EType
  { etSet :: !ETSet
  , etAssignable :: !Bool
  }
  deriving (Show, Eq)

data ETSet
  = ETExactly !Type
  | ETStructWithField !C.Ident !ETSet
  | ETComparable
  | ETCastable !Type
  | ETPointer !ETSet
  | ETAny
  deriving (Show, Eq)

checkExpectedType :: (MonadPlus m) => Voidable -> EType -> m ()
checkExpectedType (NonVoid t) et = guard $ isExpectedType t et
checkExpectedType Void _ = pure ()

match :: Type -> Type -> Bool
match = curry \case
  (TPointer Void, TPointer _) -> True
  (TPointer _, TPointer Void) -> True
  (TPointer (NonVoid a), TPointer (NonVoid b)) -> a `match` b
  (t1, t2) -> t1 == t2

isExpectedType :: Type -> EType -> Bool
isExpectedType = \c et ->
  -- pTraceWith (\a -> "check " <> show a <> " " <> show c <> " " <> show et) $
  go c (etSet et)
 where
  go c = \case
    ETExactly t -> t `match` c
    ETAny -> True
    ETStructWithField ix et -> case c of
      TStruct s -> fromMaybe False do
        let fields = structTypeFields s
        (_, mt) <- liftMaybe $ List.find (\(a, _) -> ix == a) fields
        t' <- liftMaybe mt
        pure $ go t' et
      _ow -> False
    ETComparable ->
      isNum c || isPointer c
    ETPointer t' ->
      case c of
        TPointer Void -> True
        TPointer (NonVoid c') -> go c' t'
        _ow -> False
    ETCastable TNum -> True
    a -> error (show a)

etUnPointer :: EType -> Maybe EType
etUnPointer t =
  -- pTraceWith (\t' -> "unpoint " <> show t <> " " <> show t') $
  case etSet t of
    ETPointer t' -> Just t{etSet = t'}
    ETExactly (TPointer Void) -> Just t{etSet = ETAny}
    ETExactly (TPointer (NonVoid t')) -> Just t{etSet = ETExactly t'}
    ETComparable -> Just etAny
    _ow -> Nothing

checkNotAssignable :: (MonadPlus m) => EType -> m ()
checkNotAssignable = guard . not . etAssignable

msplit :: (MonadReduce Lab m) => Lab -> Maybe (m a) -> Maybe (m a) -> Maybe (m a)
msplit l m1 m2 = do
  case m1 of
    Just a -> Just $ case m2 of
      Just b -> split l a b
      Nothing -> a
    Nothing -> m2

inferType :: Context -> C.CExpr -> Maybe Voidable
inferType ctx = \case
  C.CVar i _ -> do
    case lookupVariable ctx i of
      IEInline e -> inferType ctx e
      IEKeep t -> pure (NonVoid t)
      IEDelete -> Nothing
  C.CUnary i e _ -> do
    t <- inferType ctx e
    case i of
      C.CIndOp -> case t of
        NonVoid (TPointer t') -> pure t'
        Void -> pure Void
        _ow -> Nothing
      C.CAdrOp -> pure (NonVoid (TPointer t))
      _ow -> pure t
  C.CConst x -> pure . NonVoid $ case x of
    (C.CStrConst _ _) ->
      TPointer (NonVoid TNum)
    _ow ->
      TNum
  C.CIndex a x _ -> do
    t1 <- inferType ctx a
    t2 <- inferType ctx x
    case (t1, t2) of
      (NonVoid (TPointer x'), NonVoid TNum) -> pure x'
      _ow -> error (show ("index", t1, t2))
  C.CMember a l t _ -> do
    t1 <- inferType ctx a
    s' <- case (t1, t) of
      (NonVoid (TPointer (NonVoid (TStruct s))), True) -> pure s
      (NonVoid (TStruct s), False) -> pure s
      _ow -> error (show ("member", a, l))
    NonVoid <$> fieldLookup l s'
  C.CBinary o lhs _ _ -> do
    if o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]
      then pure (NonVoid TNum)
      else inferType ctx lhs
  C.CCast decl@(C.CDecl spec items _) _ _ -> do
    -- todo is this a good handling of this?
    (bt, _) <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx
    case items of
      [C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] _) _ _] -> do
        (t, _) <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx
        pure t
      [] ->
        pure bt
      _ow -> notSupportedYet' decl
  C.CCall f _ ni -> do
    ft <- inferType ctx f
    case ft of
      NonVoid (TFun (FunType rt _)) -> pure rt
      a -> do
        error (show ("call", a, ni, pTraceWith show f))
  C.CAssign _ lhs _ _ -> do
    inferType ctx lhs
  -- inferType ctx rhs
  -- if t1 == t2 then pure t1 else error (show ("assign", o, t1, t2))
  C.CComma items _ -> do
    inferType ctx (List.last items)
  a -> notSupportedYet' a

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
      msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
        checkNotAssignable t
        when (o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]) do
          checkExpectedType (NonVoid TNum) t
        c <- inferType ctx elhs
        let t' = fromVoid etAny exactly c
        -- if
        --   then EType ETComparable False
        --   else exactly TNum