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 ViewPatterns #-}
{-# LANGUAGE NoMonomorphismRestriction #-}

module ReduceC (
  defaultReduceC,
  defaultReduceCWithKeywords,
  -- 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.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.Trace
--
-- Todo stuckt names

import Control.Applicative
import Control.Monad
import qualified Control.Monad.IRTree as IRTree
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.Monoid
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 (CType, InlineType))
  , inlineExprs :: !(Map.Map C.Ident InlineExpr)
  , structs :: !(Map.Map C.Ident InlineStruct)
  }
  deriving (Show)

data InlineType
  = ITKeep
  | ITInline ![C.CDeclarationSpecifier C.NodeInfo]
  deriving (Show, Eq)

data InlineStruct
  = ISDelete
  | ISKeep
  deriving (Show, Eq)

data InlineExpr
  = IEDelete
  | IEInline !C.CExpr
  | IEKeep !CType
  deriving (Show, Eq)

data Keyword
  = LoseMain
  | DoNoops
  | InlineTypeDefs
  | NoSemantics
  | AllowEmptyDeclarations
  | DisallowVariableInlining
  | AllowInfiniteForLoops
  deriving (Show, Read, Enum, Eq, Ord)

type Lab = (String, C.Position)

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 #-}

addTypeDefs :: [C.Ident] -> (CType, InlineType) -> Context -> Context
addTypeDefs ids cs Context{..} =
  Context
    { typeDefs =
        foldl' (\a i -> Map.insert i cs a) typeDefs ids
    , ..
    }

addInlineExpr :: C.Ident -> InlineExpr -> 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
    , ..
    }

addInlineStruct :: C.Ident -> InlineStruct -> Context -> Context
addInlineStruct k is Context{..} =
  Context
    { structs = Map.insert k is structs
    , ..
    }

defaultContext :: Context
defaultContext =
  Context
    { keywords = Set.fromList []
    , typeDefs = Map.empty
    , inlineExprs =
        Map.fromList
          [ (C.builtinIdent "fabsf", IEKeep (CTFun [Just CTInt, Just CTInt]))
          , (C.builtinIdent "fabs", IEKeep (CTFun [Just CTInt, Just CTInt]))
          , (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep CTInt)
          , (C.builtinIdent "__FUNCTION__", IEKeep CTInt)
          ]
    , structs = 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
  res' <- evalStateT (mapM (StateT . reduceCExternalDeclaration) es) ctx
  es' <- sequence . catMaybes $ res'
  pure $ C.CTranslUnit es' ni

reduceCExternalDeclaration
  :: (MonadReduce Lab m)
  => C.CExternalDeclaration C.NodeInfo
  -> Context
  -> m (Maybe (m (C.CExternalDeclaration C.NodeInfo)), Context)
reduceCExternalDeclaration r ctx = case r of
  C.CFDefExt fun
    | not (LoseMain `isIn` ctx)
        && maybe False (("main" ==) . C.identToString) (functionName fun) -> do
        pure (Just $ C.CFDefExt <$> reduceCFunDef fun ctx, ctx)
    | otherwise ->
        case functionName fun of
          Just fid
            | shouldDeleteFunction ctx fun -> do
                pure (Nothing, addInlineExpr fid IEDelete ctx)
            | otherwise -> do
                let nctx =
                      ctx & foldr \case
                        (Just t, Just i) -> addInlineExpr i (IEKeep t)
                        (Nothing, Just i) -> addInlineExpr i IEDelete
                        (_, Nothing) -> id
                let red fun' ps = reduceCFunDef fun' (nctx ps)
                case Map.lookup fid . inlineExprs $ ctx of
                  Just (IEKeep (CTFun args)) -> do
                    (fun', ps) <- reduceParamsTo args fun
                    pure
                      ( Just (C.CFDefExt <$> red fun' ps)
                      , addInlineExpr fid (IEKeep (CTFun (map fst ps))) ctx
                      )
                  _ow -> do
                    split
                      ("remove function " <> C.identToString fid, C.posOf r)
                      (pure (Nothing, addInlineExpr fid IEDelete ctx))
                      do
                        (fun', ps) <- reduceParams ctx fun
                        pure
                          ( Just (C.CFDefExt <$> red fun' ps)
                          , addInlineExpr fid (IEKeep (CTFun (map fst ps))) ctx
                          )
          Nothing
            | shouldDeleteFunction ctx fun -> do
                pure (Nothing, ctx)
            | otherwise -> do
                split
                  ("remove function", C.posOf r)
                  (pure (Nothing, ctx))
                  (pure (Just (C.CFDefExt <$> reduceCFunDef fun ctx), ctx))
  C.CDeclExt decl -> do
    (decl', ctx') <- handleDecl decl ctx
    case decl' of
      Just d -> pure (Just (C.CDeclExt <$> d), ctx')
      Nothing -> pure (Nothing, ctx')
  _r -> don'tHandle r

data StructDef = StructDef
  { structId :: !C.Ident
  , fieldIds :: ![C.Ident]
  , structDef :: !C.CStructUnion
  }
  deriving (Show, Eq)

structIds
  :: (Foldable f)
  => f (C.CDeclarationSpecifier C.NodeInfo)
  -> [StructDef]
structIds = concatMap \case
  C.CTypeSpec (C.CSUType (C.CStruct a (Just n) (Just ma) b c) _) ->
    [ StructDef
        n
        [ x
        | C.CDecl _ itms _ <- ma
        , C.CDeclarationItem (C.CDeclr (Just x) _ _ _ _) _ _ <- itms
        ]
        (C.CStruct a (Just n) (Just ma) b c)
    ]
  _ow -> []

trySplit :: (MonadReduce l m, Eq a) => l -> a -> (a -> a) -> m a
trySplit l a action = do
  let a' = action a
  if a /= a'
    then split l (pure a') (pure a)
    else pure a

reduceCFunDef
  :: (MonadReduce Lab m, HasCallStack)
  => C.CFunctionDef C.NodeInfo
  -> Context
  -> m (C.CFunctionDef C.NodeInfo)
reduceCFunDef (C.CFunDef spc dec cdecls smt ni) ctx = do
  spc1 <- trySplit ("remove static", C.posOf ni) spc $ filter \case
    C.CStorageSpec (C.CStatic _) -> False
    _ow -> True
  spc2 <- trySplit ("remove inline", C.posOf ni) spc1 $ filter \case
    C.CFunSpec (C.CInlineQual _) -> False
    _ow -> True
  let labs = labelsOf smt
  labs' <-
    foldr
      (\l r -> split ("remove label" <> show l, C.posOf l) r $ (l :) <$> r)
      (pure [])
      labs
  smt' <- reduceCStatementOrEmptyBlock smt labs' ctx
  pure $
    C.CFunDef
      (inlineTypeDefsSpecs spc2 ctx)
      (inlineTypeDefsCDeclarator dec ctx)
      (map (`inlineTypeDefsCDeclaration` ctx) cdecls)
      smt'
      ni

labelsOf :: C.CStatement C.NodeInfo -> [C.Ident]
labelsOf = \case
  C.CLabel i s [] _ -> i : labelsOf s
  C.CWhile _ s _ _ -> labelsOf s
  C.CCase _ s _ -> labelsOf s
  C.CDefault s _ -> labelsOf s
  C.CCompound _ ss _ ->
    ss & concatMap \case
      C.CBlockStmt s -> labelsOf s
      _ow -> []
  C.CCases _ _ s _ -> labelsOf s
  C.CIf _ l r _ -> labelsOf l <> maybe [] labelsOf r
  C.CSwitch _ s _ -> labelsOf s
  C.CFor _ _ _ s _ -> labelsOf s
  _ow -> []

reduceParamsTo
  :: (MonadReduce Lab m)
  => [Maybe CType]
  -> C.CFunctionDef C.NodeInfo
  -> m (C.CFunctionDef C.NodeInfo, [(Maybe CType, Maybe (C.Identifier C.NodeInfo))])
reduceParamsTo types (C.CFunDef a (C.CDeclr b declrs c d e) f g h) =
  types & evalStateT do
    (unzip -> (declrs', defs)) <-
      declrs & mapM \case
        C.CFunDeclr (C.CFunParamsNew decls i) j k -> do
          (unzip -> (decls', defs)) <-
            decls & mapM \case
              C.CDecl def items l -> do
                (unzip -> (items', defs)) <-
                  items & mapM \case
                    a'@(C.CDeclarationItem (C.CDeclr idx _ _ _ _) _ _) -> do
                      t' <- state (\(t : tps) -> (t, tps))
                      case t' of
                        Just t -> pure ([a'], [(Just t, idx)])
                        Nothing -> pure ([], [(Nothing, idx)])
                    a' -> notSupportedYet a' k
                case concat items' of
                  [] -> pure ([], concat defs)
                  items'' -> pure ([C.CDecl def items'' l], concat defs)
              a' -> don'tHandleWithPos a'
          pure (C.CFunDeclr (C.CFunParamsNew (concat decls') i) j k, concat defs)
        ow -> pure (ow, [])
    pure (C.CFunDef a (C.CDeclr b declrs' c d e) f g h, concat defs)

reduceParams'
  :: (MonadReduce Lab m)
  => Context
  -> [C.CDerivedDeclarator C.NodeInfo]
  -> m ([C.CDerivedDeclarator C.NodeInfo], [[(Maybe CType, Maybe (C.Identifier C.NodeInfo))]])
reduceParams' ctx declrs = do
  (unzip -> (declrs', defs)) <-
    declrs & mapM \case
      C.CFunDeclr (C.CFunParamsNew decls i) j k -> do
        (unzip -> (decls', defs)) <-
          decls & mapM \case
            a@(C.CDecl def items l) -> do
              (unzip -> (items', defs)) <-
                items & mapM \case
                  a'@(C.CDeclarationItem (C.CDeclr idx _ _ _ _) _ _) ->
                    if shouldDeleteDeclaration ctx a
                      then pure ([], [(Nothing, idx)])
                      else
                        split
                          ("remove parameter", C.posOf k)
                          (pure ([], [(Nothing, idx)]))
                          (pure ([a'], [(Just (ctype ctx def), idx)]))
                  a' -> notSupportedYet a' k
              case concat items' of
                [] -> pure ([], concat defs)
                items'' -> pure ([C.CDecl def items'' l], concat defs)
            a' -> don'tHandleWithPos a'
        pure (C.CFunDeclr (C.CFunParamsNew (concat decls') i) j k, [concat defs])
      ow -> pure (ow, [])
  pure (declrs', concat defs)

reduceParams
  :: (MonadReduce Lab m)
  => Context
  -> C.CFunctionDef C.NodeInfo
  -> m (C.CFunctionDef C.NodeInfo, [(Maybe CType, Maybe C.Ident)])
reduceParams ctx (C.CFunDef a (C.CDeclr b declrs c d e) f g h) = do
  (declrs', defs) <- reduceParams' ctx declrs
  pure (C.CFunDef a (C.CDeclr b declrs' c d e) f g h, concat defs)

ctype :: Context -> [C.CDeclarationSpecifier C.NodeInfo] -> CType
ctype ctx xs =
  let ts = mapMaybe f xs
   in fromJust $
        foldr
          ( \t t' -> case t' of
              Nothing -> Just t
              Just t''
                | t == t'' -> Just t''
                | otherwise -> error ("something is broken in the c-file" <> show ts)
          )
          Nothing
          ts
 where
  f = \case
    (C.CTypeSpec tp) -> Just $ case tp of
      C.CVoidType _ -> CTAny
      C.CCharType _ -> CTInt
      C.CShortType _ -> CTInt
      C.CIntType _ -> CTInt
      C.CFloatType _ -> CTInt
      C.CDoubleType _ -> CTInt
      C.CSignedType _ -> CTInt
      C.CUnsigType _ -> CTInt
      C.CBoolType _ -> CTInt
      C.CLongType _ -> CTInt
      C.CInt128Type _ -> CTInt
      C.CFloatNType{} -> CTInt
      C.CSUType _ _ -> CTStruct
      C.CEnumType _ _ -> CTInt
      C.CTypeDef idx _ ->
        case Map.lookup idx . typeDefs $ ctx of
          Just (t, ITKeep) -> t
          Just (t, ITInline _) -> t
          Nothing -> error ("could not find typedef:" <> show idx)
      a -> notSupportedYet a C.undefNode
    _ow -> Nothing

reduceCCompoundBlockItem
  :: (MonadReduce Lab m, HasCallStack)
  => [C.Ident]
  -> 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 _ ->
              split
                ("expand compound statment", C.posOf r)
                (pure ss)
                (pure [C.CBlockStmt smt'])
            _ow -> pure [C.CBlockStmt smt']
        Nothing -> pure []
    C.CBlockDecl declr -> do
      ctx <- get
      (declr', ctx') <- handleDecl declr ctx
      put ctx'
      case declr' of
        Just d -> do
          d' <- C.CBlockDecl <$> d
          pure [d']
        Nothing -> pure []
    a -> don'tHandle a

handleDecl
  :: (MonadReduce Lab m)
  => C.CDeclaration C.NodeInfo
  -> Context
  -> m (Maybe (m (C.CDeclaration C.NodeInfo)), Context)
handleDecl d ctx = case inlineTypeDefsCDeclaration d ctx of
  -- A typedef
  C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) decl _ -> do
    let [ids] = identifiers decl
    whenSplit
      (InlineTypeDefs `isIn` ctx)
      ("inline typedef " <> C.identToString ids, C.posOf d)
      (pure (Nothing, addTypeDefs [ids] (ctype ctx rst, ITInline rst) ctx))
      (pure (Just (pure d), addTypeDefs [ids] (ctype ctx rst, ITKeep) ctx))
  -- A const
  d'@(C.CDecl spc decl ni') -> do
    (decl', ctx') <-
      foldr
        ( reduceCDeclarationItem
            (shouldDeleteDeclaration ctx d')
            (ctype ctx spc)
        )
        (pure ([], ctx))
        decl
    let fn = do
          spc1 <- trySplit ("remove static", C.posOf ni') spc $ filter \case
            C.CStorageSpec (C.CStatic _) -> False
            _ow -> True
          pure $ C.CDecl spc1 decl' ni'
    case (decl', structIds spc) of
      ([], [])
        | AllowEmptyDeclarations `isIn` ctx' ->
            split ("remove empty declaration", C.posOf d) (pure (Nothing, ctx')) do
              pure (Just fn, ctx')
        | otherwise -> pure (Nothing, ctx')
      ([], stcts) ->
        split
          ("remove declaration", C.posOf d)
          (pure (Nothing, foldr (\(StructDef k _ _) -> addInlineStruct k ISDelete) ctx' stcts))
          do
            pure (Just fn, foldr (\(StructDef k _ _) -> addInlineStruct k ISKeep) ctx' stcts)
      (_, stcts) ->
        pure (Just fn, foldr (\(StructDef k _ _) -> addInlineStruct k ISKeep) ctx' stcts)
  a -> don'tHandleWithPos a

reduceCDeclarationItem
  :: (MonadReduce Lab m)
  => Bool
  -> CType
  -> C.CDeclarationItem C.NodeInfo
  -> m ([C.CDeclarationItem C.NodeInfo], Context)
  -> m ([C.CDeclarationItem C.NodeInfo], Context)
reduceCDeclarationItem shouldDelete t 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)
      if shouldDelete
        then pure (ds, addInlineExpr i (IEInline c') ctx)
        else
          split
            ("inline variable " <> C.identToString i, C.posOf ni)
            (pure (ds, addInlineExpr i (IEInline c') ctx))
            ( pure
                ( inlineTypeDefsCDI (C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing) ctx
                    : ds
                , addInlineExpr i (IEKeep t) ctx
                )
            )
  C.CDeclarationItem (C.CDeclr (Just i) a Nothing b ni) ex Nothing -> do
    (ds, ctx) <- ma
    if shouldDelete
      then pure (ds, addInlineExpr i IEDelete ctx)
      else do
        ex' <- case ex of
          Just ix -> maybeSplit ("remove initializer", C.posOf ni) (reduceCInitializer ix ctx)
          Nothing -> pure Nothing

        (a', t') <-
          if C.identToString i == "printf"
            then pure (a, CTAny)
            else do
              (a', defs) <- reduceParams' ctx a
              let t' = case defs of
                    [args] -> CTFun (map fst args)
                    [] -> t
                    _x -> error ("Unexpected" <> unlines (map show _x) <> show (C.posOf ni))
              pure (a', t')
        let d' = C.CDeclarationItem (C.CDeclr (Just i) a' Nothing b ni) ex' Nothing
        split
          ("remove variable " <> C.identToString i, C.posOf ni)
          (pure (ds, addInlineExpr i IEDelete ctx))
          (pure (inlineTypeDefsCDI d' ctx : ds, addInlineExpr i (IEKeep t') ctx))
  a@(C.CDeclarationItem (C.CDeclr _ _ _ _ ni) _ _) -> do
    don'tHandleWithNodeInfo a ni
  a -> don'tHandle a

reduceCInitializer
  :: (MonadReduce Lab m)
  => C.CInitializer C.NodeInfo
  -> Context
  -> Maybe (m (C.CInitializer C.NodeInfo))
reduceCInitializer a ctx = case a of
  C.CInitExpr e ni' -> do
    rm <- reduceCExpr e ctx
    Just $ (`C.CInitExpr` ni') <$> rm
  C.CInitList (C.CInitializerList items) ni -> do
    ritems <- forM items \case
      ([], it) -> fmap ([],) <$> reduceCInitializer it ctx
      (as, _) -> notSupportedYet (fmap noinfo as) ni
    Just $ (`C.CInitList` ni) . C.CInitializerList <$> sequence ritems

reduceCStatementOrEmptyBlock
  :: (MonadReduce Lab m, HasCallStack)
  => C.CStatement C.NodeInfo
  -> [C.Ident]
  -> Context
  -> m (C.CStatement C.NodeInfo)
reduceCStatementOrEmptyBlock stmt ids ctx = do
  fromMaybe emptyBlock <$> runMaybeT (reduceCStatement stmt ids ctx)

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

-- | Reduce given a list of required labels reduce a c statement, possibly into nothingness.
reduceCStatement
  :: (MonadReduce Lab m, HasCallStack)
  => C.CStatement C.NodeInfo
  -> [C.Ident]
  -> 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
    case concat cbi' of
      [] -> do
        exceptIf ("remove empty compound", C.posOf smt)
        pure (C.CCompound is [] ni)
      ccbi -> pure (C.CCompound is ccbi ni)
  C.CWhile e s dow ni -> do
    s' <- reduceCStatement s labs ctx
    e' <- lift (reduceCExprOrZero e 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 ctx
            pure $ C.CExpr e' ni
          else do
            re' <- liftMaybe $ reduceCExpr e ctx
            exceptIf ("remove expr statement", C.posOf smt)
            e' <- re'
            pure $ C.CExpr (Just e') ni
      Nothing ->
        pure $ C.CExpr Nothing ni
  C.CReturn me ni -> do
    -- TODO: If function returntype is not struct return 0
    case me of
      Just e -> do
        re' <- liftMaybe $ reduceCExpr e ctx
        exceptIf ("remove return statement", C.posOf smt)
        e' <- re'
        pure $ C.CReturn (Just e') ni
      Nothing -> do
        exceptIf ("remove return statement", C.posOf smt)
        pure $ C.CReturn Nothing ni
  C.CIf e s els ni -> do
    e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e 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
    (me1', ctx') <- case e1 of
      C.CForDecl d@(C.CDecl rec decl ni') -> do
        (decl', ctx') <-
          foldr
            (reduceCDeclarationItem (shouldDeleteDeclaration ctx d) (ctype ctx rec))
            (pure ([], ctx))
            decl
        res <-
          if null decl'
            then
              if AllowEmptyDeclarations `isIn` ctx'
                then
                  split
                    ("remove empty declaration", C.posOf ni')
                    (pure Nothing)
                    (pure $ Just $ C.CForDecl (C.CDecl rec decl' ni'))
                else pure Nothing
            else pure $ Just $ C.CForDecl (C.CDecl rec decl' ni')
        pure (res, ctx')
      C.CForInitializing e -> do
        e' <- maybeSplit ("remove initializer", C.posOf ni) (e >>= \e' -> reduceCExpr e' ctx)
        split
          ("remove empty declaration", C.posOf ni)
          (pure (Nothing, ctx))
          (pure (Just $ C.CForInitializing e', ctx))
      d -> don'tHandle d

    s' <- reduceCStatementOrEmptyBlock s labs ctx'
    let forloop n = do
          e2' <- runMaybeT do
            e2' <- liftMaybe e2
            re2' <- liftMaybe (reduceCExpr e2' ctx')
            exceptIf ("remove check", C.posOf e2')
            re2'
          e3' <- runMaybeT do
            e3' <- liftMaybe e3
            re3' <- liftMaybe (reduceCExpr e3' ctx')
            exceptIf ("remove iterator", C.posOf e3')
            re3'
          let e2'' =
                if AllowInfiniteForLoops `isIn` ctx || isNothing e2
                  then e2'
                  else e2' <|> Just zeroExpr
          pure $ C.CFor n e2'' e3' s' ni

    case me1' of
      Nothing -> do
        split ("remove the for loop", C.posOf smt) (pure s') do
          forloop (C.CForInitializing Nothing)
      Just e1' -> do
        forloop e1'
  C.CLabel i s [] ni -> do
    if i `List.elem` labs
      then do
        s' <- lift $ reduceCStatementOrEmptyBlock s labs ctx
        pure $ C.CLabel i s' [] ni
      else do
        empty
  C.CGoto i ni ->
    if i `List.elem` labs
      then pure $ C.CGoto i ni
      else empty
  C.CBreak _ -> defaultBehavior
  C.CCont _ -> defaultBehavior
  a -> don'tHandleWithPos a
 where
  defaultBehavior =
    split ("remove statement", C.posOf smt) empty (pure smt)

-- | 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 #-}

data CType
  = CTInt
  | CTStruct
  | CTPointer
  | CTFun ![Maybe CType]
  | CTAny
  deriving (Show, Eq)

reduceCExpr :: forall m. (MonadReduce Lab m, HasCallStack) => C.CExpr -> Context -> Maybe (m C.CExpr)
reduceCExpr expr ctx = case expr of
  C.CBinary o elhs erhs ni -> do
    if o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]
      then do
        -- in this case we change type, so we need to keep the operation
        rl <- reduceCExpr elhs ctx
        rr <- reduceCExpr erhs ctx
        Just $ do
          l' <- rl
          r' <- rr
          pure $ C.CBinary o l' r' ni
      else 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 ->
              pure elhs'
          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
        IEKeep _ -> Just (pure expr)
        IEInline mx'
          | DisallowVariableInlining `isIn` ctx -> Nothing
          | otherwise -> Just (pure mx')
        IEDelete ->
          Nothing
      Nothing -> error ("Could not find " <> show i <> " at " <> show (C.posOf expr) <> "\n" <> show (inlineExprs ctx))
  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
    let inlineExprOf i = Map.lookup i . inlineExprs $ ctx
    case e of
      (C.CVar i _) -> case inlineExprOf i of
        Just IEDelete -> Just $ do
          es' <- traverse (maybeSplit ("do without param", C.posOf e) . (`reduceCExpr` ctx)) es
          -- Not completely correct.
          case catMaybes es' of
            [] -> pure zeroExpr
            [e''] -> pure e''
            es'' -> pure $ C.CComma es'' C.undefNode
        Just (IEKeep (CTFun args)) -> do
          rargs' :: [m C.CExpr] <- sequence . catMaybes . (\f -> zipWith f args es) $ \a ae' ->
            a <&> \tt ->
              let r = case reduceCExpr ae' ctx of
                    Just re ->
                      Just $
                        whenSplit
                          (tt /= CTStruct)
                          ("do without param", C.posOf ae')
                          (pure zeroExpr)
                          re
                    Nothing
                      | tt /= CTStruct -> Just (pure zeroExpr)
                      | otherwise -> Nothing
               in r :: Maybe (m C.CExpr)
          Just $ do
            es' <- sequence rargs'
            pure $ C.CCall e es' ni
        Just (IEKeep CTAny) -> do
          let re = reduceCExpr e (addKeyword DisallowVariableInlining ctx)
              res = map (`reduceCExpr` ctx) es
          case (re, catMaybes res) of
            (Nothing, []) -> Nothing
            (Nothing, [r]) -> Just r
            (_, _) -> Just do
              e' <- maybeSplit ("do without function", C.posOf e) re
              es' <- res & traverse (maybeSplit ("do without pram", C.posOf e))
              case (e', catMaybes es') of
                (Nothing, []) -> pure zeroExpr
                (Nothing, [e'']) -> pure e''
                (Nothing, es'') -> pure $ C.CComma es'' C.undefNode
                (Just f, _) -> pure $ C.CCall f (map (fromMaybe zeroExpr) es') ni
        Just (IEKeep t) -> error ("unexpected type" <> show i <> show t)
        Just (IEInline x) -> error ("unexpected inline" <> show x)
        Nothing -> error ("could not find " <> show i)
      _ow -> notSupportedYet e ni
  -- do
  --   let re = reduceCExpr e (addKeyword DisallowVariableInlining ctx)
  --       res = map (`reduceCExpr` ctx) es
  --   case (re, catMaybes res) of
  --     (Nothing, []) -> Nothing
  --     (Nothing, [r]) -> Just r
  --     (_, _) -> Just do
  --       e' <- maybeSplit ("do without function", C.posOf e) re
  --       es' <- res & traverse (maybeSplit ("do without pram", C.posOf e))
  --       case (e', catMaybes es') of
  --         (Nothing, []) -> pure zeroExpr
  --         (Nothing, [e'']) -> pure e''
  --         (Nothing, es'') -> pure $ C.CComma es'' C.undefNode
  --         (Just f, _) -> pure $ C.CCall f (map (fromMaybe zeroExpr) es') ni
  C.CCond ec et ef ni -> do
    -- TODO: More fine grained reduction is possible here.
    Just $ do
      ec' <- reduceCExprOrZero ec ctx
      ef' <- reduceCExprOrZero ef ctx
      et' <- case et of
        Just et' -> Just <$> reduceCExprOrZero et' ctx
        Nothing -> pure Nothing
      pure $ C.CCond ec' et' ef' ni
  C.CCast decl e ni -> do
    re <- reduceCExpr e ctx
    Just do
      split ("don't cast", C.posOf ni) re do
        e' <- re
        pure (C.CCast (inlineTypeDefsCDeclaration decl ctx) e' ni)
  C.CIndex e1 e2 ni -> do
    -- TODO: Better reduction is posisble here.
    re1 <- reduceCExpr e1 ctx
    Just do
      e1' <- re1
      e2' <- reduceCExprOrZero e2 ctx
      pure $ C.CIndex e1' e2' ni
  C.CComma items ni -> do
    let Just (x, rst) = List.uncons (reverse items)
    rx <- reduceCExpr x ctx
    Just do
      rst' <-
        foldr
          ( \e cc -> do
              maybeSplit ("remove expression", C.posOf e) (reduceCExpr e ctx) >>= \case
                Just e' -> (e' :) <$> cc
                Nothing -> cc
          )
          (pure [])
          rst
      x' <- rx
      if List.null rst'
        then pure x'
        else pure $ C.CComma (reverse (x' : rst')) ni
  C.CMember e i l ni -> do
    re <- reduceCExpr e ctx
    Just do
      e' <- re
      pure (C.CMember e' i l ni)
  a -> don'tHandleWithPos a

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 -> don'tHandle a

shouldDeleteFunction :: Context -> C.CFunctionDef C.NodeInfo -> Bool
shouldDeleteFunction ctx (C.CFunDef spec _ _ _ _) =
  any (shouldDeleteDeclSpec ctx) spec

shouldDeleteDeclaration :: Context -> C.CDeclaration C.NodeInfo -> Bool
shouldDeleteDeclaration ctx decl =
  case decl of
    C.CDecl items decli _ -> any (shouldDeleteDeclSpec ctx) items || any shouldDeleteDeclItem decli
    a -> don'tHandle a
 where
  shouldDeleteDeclItem = \case
    C.CDeclarationItem a _ _ -> shouldDeleteDeclartor a
    a -> don'tHandle a

  shouldDeleteDeclartor = \case
    C.CDeclr _ def _ _ _ -> any shouldDeleteDerivedDeclartor def

  shouldDeleteDerivedDeclartor = \case
    C.CFunDeclr (C.CFunParamsNew x _) _ _ ->
      any (shouldDeleteDeclaration ctx) x
    C.CArrDeclr{} -> False
    C.CPtrDeclr _ _ -> False
    a -> don'tHandle a

shouldDeleteDeclSpec :: Context -> C.CDeclarationSpecifier C.NodeInfo -> Bool
shouldDeleteDeclSpec ctx = \case
  C.CTypeSpec (C.CSUType (C.CStruct _ (Just idx) Nothing _ _) _) ->
    case Map.lookup idx . structs $ ctx of
      Just ISDelete -> True
      Just ISKeep -> False
      Nothing -> error ("could not find struct:" <> show idx)
  C.CTypeSpec (C.CSUType (C.CStruct _ _ (Just c) _ _) _) ->
    any (shouldDeleteDeclaration ctx) c
  _ow -> False

inlineTypeDefsSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Context -> [C.CDeclarationSpecifier C.NodeInfo]
inlineTypeDefsSpecs r ctx =
  r & concatMap \case
    a@(C.CTypeSpec (C.CTypeDef idx _)) -> do
      case Map.lookup idx . typeDefs $ ctx of
        Just (_, ITKeep) -> [a]
        Just (_, ITInline res) -> res
        Nothing -> error ("could not find typedef:" <> show idx)
    -- a@(C.CTypeSpec (C.CSUType (C.CStruct _ (Just idx) Nothing _ _) _)) ->
    --   case Map.lookup idx . structs $ ctx of
    --     Just (Just def) -> [C.CTypeSpec (C.CSUType def C.undefNode)]
    --     Just Nothing -> [a]
    --     Nothing -> error ("could not find struct:" <> show idx)
    C.CTypeSpec (C.CSUType (C.CStruct a b (Just c) d e) f) ->
      [C.CTypeSpec (C.CSUType (C.CStruct a b (Just $ map (`inlineTypeDefsCDeclaration` ctx) c) d e) f)]
    a -> [a]
{-# NOINLINE inlineTypeDefsSpecs #-}

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 -> don'tHandle 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 -> don'tHandle a

identifiers :: forall a. (Data a) => a -> [C.Ident]
identifiers d = appEndo (go d) []
 where
  go :: forall a'. (Data a') => a' -> Endo [C.Ident]
  go d' = case cast d' of
    Just l -> Endo (l :)
    Nothing -> gmapQl (<>) mempty go d'

functionName :: C.CFunctionDef C.NodeInfo -> Maybe C.Ident
functionName = \case
  C.CFunDef _ (C.CDeclr ix _ _ _ _) _ _ _ -> ix

notSupportedYet :: (HasCallStack, Show a) => a -> C.NodeInfo -> b
notSupportedYet a ni = error (show a <> " at " <> show (C.posOf ni))

noinfo :: (Functor f) => f C.NodeInfo -> f ()
noinfo a = a $> ()

don'tHandle :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> b
don'tHandle f = error (show (f $> ()))

don'tHandleWithPos :: (HasCallStack, Functor f, Show (f ()), C.Pos (f C.NodeInfo)) => f C.NodeInfo -> b
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))