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.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.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 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

reduceCTranslUnit
  :: (MonadReduce Lab m)
  => C.CTranslationUnit C.NodeInfo
  -> Context
  -> m (C.CTranslationUnit C.NodeInfo)
reduceCTranslUnit (C.CTranslUnit es ni) ctx = do
  (_functions, _structs) <- flip evalState ctx do
    (fs, sts) <- flip mapAndUnzipM es \e -> do
      includeTypeDef e
      funcs <- gets \ctx' -> findFunctions (: []) ctx' e
      structs <- gets \ctx' -> findStructs (: []) ctx' e
      pure (funcs, structs)
    pure (pure (concat fs, concat sts))

  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 <- reduce =<< reduce funmap

  functions3 <- forM functions2 \(k, mf) ->
    (k,) <$> runMaybeT do
      f <- liftMaybe mf
      params <- case funParams f of
        Params params False -> do
          params' <- forM params \p -> runMaybeT do
            p' <- liftMaybe p
            exceptIf ("remove parameter", funPosition f)
            pure p'
          pure (Params params' False)
        ow -> pure ow
      pure f{funParams = params}

  let functions''' =
        Map.fromList $
          functions3
            <> [ ( funName
                 , Just $
                    Function
                      { funIsStatic = False
                      , funPosition = C.posOf funName
                      , funSize = 0
                      , ..
                      }
                 )
               | (C.builtinIdent -> funName, funReturns, funParams) <-
                  [ ("fabsf", (Just CTNum), (Params [Just CTNum] False))
                  , ("fabs", (Just CTNum), (Params [Just CTNum] False))
                  ]
               ]

  structs' <- flip execStateT (structs ctx) do
    forM_ _structs \s ->
      modify' (Map.insert (structName s) (Just s))

  let ctx' = ctx{functions = functions''', structs = structs'}
  res' <- evalStateT (mapM reduceCExternalDeclaration es) ctx'
  pure $ C.CTranslUnit (catMaybes res') ni

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
    guard (not $ any (shouldDeleteDeclSpec ctx) spec)

    let C.CDeclr mid dd Nothing [] ni2 = declr
    let (C.CFunDeclr (C.CFunParamsNew params b) attr ni3 : dd') = dd

    (pFilter, spec') <- case mid of
      Just fid -> do
        f <- liftMaybe (lookupFunction ctx fid)
        pure (funParams f, filterStorageModifiers (funIsStatic f) spec)
      Nothing -> do
        exceptIf ("remove function", C.posOf r)

        case params of
          [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> pure (VoidParams, spec)
          _ow -> pure (Params (Just . snd <$> map (functionParameter ctx) params) False, spec)

    let (params', idents) = case pFilter of
          Params flt False -> filterParams ctx flt params
          _ow -> (params, [])

    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} $
        foldr (uncurry addInlineExpr) ctx idents

    let dd'' = C.CFunDeclr (C.CFunParamsNew params' b) attr ni3 : dd'

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

  -- Type definitions
  C.CDeclExt d@(C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) [item] ni) -> runMaybeT do
    let C.CDeclarationItem (C.CDeclr (Just ix) [] Nothing [] _) Nothing Nothing = item
    split
      ("Inline typedef" <> C.identToString ix, C.posOf ni)
      (modify (\ctx' -> addTypeDefs [ix] (ctype ctx' rst, ITInline rst) ctx') >> empty)
      do
        modify (\ctx' -> addTypeDefs [ix] (ctype ctx' rst, ITKeep) ctx')
        gets (C.CDeclExt <$> inlineTypeDefsCDeclaration d)

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

    let t = ctype ctx spec

    lift $ includeTypeDef r

    keep <- containsStructDeclaration spec

    -- Try to remove each declaration item
    (items', or -> isStatic) <-
      unzip <$> flip collect items \case
        di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size) -> do
          case dd of
            (C.CFunDeclr params attr ni3) : rst -> do
              (dd', isStatic) <- case mid of
                Just fid -> do
                  f <- liftMaybe (lookupFunction ctx fid)
                  params' <- case funParams f of
                    Params flt False -> do
                      case params of
                        C.CFunParamsNew params' b -> do
                          let res = filterParams ctx flt params'
                          pure . flip C.CFunParamsNew b . fst $ res
                        C.CFunParamsOld _ ->
                          notSupportedYet (di $> ()) ni2
                    _ow -> pure params

                  pure (C.CFunDeclr params' attr ni3 : rst, funIsStatic f)
                Nothing -> do
                  exceptIf ("remove function", C.posOf ni2)
                  pure (dd, isStaticFromSpecs spec)
              pure (C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni2) einit size, isStatic)
            _dd -> do
              let Just t' = applyDerivedDeclarators dd (Just t)
              einit' <- reduceVariable t' mid einit ni2
              pure (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit' size, isStaticFromSpecs spec)
        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)

    decl' <- gets (inlineTypeDefsCDeclaration (C.CDecl (filterStorageModifiers isStatic spec) items' ni))
    pure (C.CDeclExt decl')
  _r -> don'tHandle 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

reduceVariable
  :: ( MonadReduce Lab m
     , MonadState Context m
     , MonadPlus m
     )
  => CType
  -> Maybe C.Ident
  -> Maybe (C.CInitializer C.NodeInfo)
  -> C.NodeInfo
  -> m (Maybe (C.CInitializer C.NodeInfo))
reduceVariable t' mid einit ni = do
  case mid of
    Just vid -> do
      case einit of
        Just (C.CInitExpr e ni2) -> do
          ctx <- get
          e' <- reduceCExprOrZero e ctx
          split
            ("inline variable " <> C.identToString vid, C.posOf ni)
            do
              modify' (addInlineExpr vid (IEInline e'))
              empty
            do
              modify' (addInlineExpr vid (IEKeep t'))
              pure (Just (C.CInitExpr e' ni2))
        -- TODO handle later
        Just (C.CInitList i ni2) ->
          split
            ("delete variable", C.posOf ni)
            (modify' (addInlineExpr vid IEDelete) >> empty)
            do
              modify' (addInlineExpr vid (IEKeep t'))
              pure (Just (C.CInitList i ni2))
        Nothing ->
          split
            ("delete uninitialized variable", C.posOf vid)
            (modify' (addInlineExpr vid IEDelete) >> empty)
            do
              modify' (addInlineExpr vid (IEKeep t'))
              pure Nothing
    Nothing -> do
      exceptIf ("remove unnamed declaration item", C.posOf ni)
      pure einit

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

      let t = ctype ctx spec

      keep <- containsStructDeclaration spec

      -- Try to remove each declaration item
      items' <- flip collect items \case
        C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size -> do
          let Just t' = applyDerivedDeclarators dd (Just t)
          einit' <- reduceVariable t' mid einit ni2
          pure (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit' size)
        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)

      decl' <- gets (inlineTypeDefsCDeclaration (C.CDecl spec items' ni))
      pure [C.CBlockDecl decl']
    a -> don'tHandle a

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)

-- | Reduce given a list of required labels reduce a c statement, possibly into nothingness.
reduceCStatement
  :: (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
    when (all List.null cbi') do
      exceptIf ("Remove compound", C.posOf ni)
    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' <- 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 -> do
        exceptIf ("remove expr statement", C.posOf smt)
        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
    case e1 of
      C.CForDecl (C.CDecl spec items ni') -> do
        let t = ctype ctx spec
        let spec' = inlineTypeDefsSpecs spec ctx
        (items', ctx') <- flip runStateT ctx $ flip collect items \case
          C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size -> do
            einit' <- reduceVariable t mid einit ni'
            pure (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit' size)
          a -> notSupportedYet a ni'
        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
        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' ctx)
            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
            s' <- reduceCStatementOrEmptyExpr s labs{stmtInLoop = True} ctx
            pure $ C.CFor (C.CForInitializing e') e2'' e3' s' ni
      d -> don'tHandle d
  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 -> don'tHandleWithPos 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 #-}

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 (C.identToString 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 $
      whenSplit (o `List.elem` [C.CPlusOp, C.CMinOp, C.CCompOp, C.CNegOp]) ("reduce to operant", C.posOf expr) elhs' do
        e <- elhs'
        pure $ C.CUnary o e ni
  C.CCall e es ni -> do
    case e of
      (C.CVar i _) -> case functions ctx Map.!? i of
        Just Nothing -> Nothing
        -- TODO improve
        -- 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 (Just fun) -> do
          let params :: [(Bool, C.CExpr)] = case funParams fun of
                Params params' False -> do
                  catMaybes $ zipWith (\mt e' -> mt <&> \t -> (t /= CTStruct, e')) params' es
                _ow -> map (False,) es

          rargs :: [m C.CExpr] <- forM params \(canBeZero, e') -> do
            case reduceCExpr e' ctx of
              Just re ->
                Just $
                  whenSplit
                    canBeZero
                    ("do without param", C.posOf e')
                    (pure zeroExpr)
                    re
              Nothing
                | canBeZero -> Just (pure zeroExpr)
                | otherwise -> Nothing
          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 (Just _) -> False
      Just Nothing -> True
      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, C.Pos n) => a -> n -> b
notSupportedYet a ni = error (show a <> " at " <> show (C.posOf ni))

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))

lookupFunction :: (HasCallStack) => Context -> C.Ident -> Maybe Function
lookupFunction ctx k =
  fromMaybe (error ("could not find function " <> C.identToString k)) $
    functions ctx Map.!? k

lookupStruct :: (HasCallStack) => Context -> C.Ident -> Maybe Struct
lookupStruct ctx k =
  fromMaybe (error ("could not find struct " <> C.identToString k)) $
    structs ctx Map.!? k

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 -> []

ctype :: (HasCallStack) => 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 _ -> CTNum
      C.CShortType _ -> CTNum
      C.CIntType _ -> CTNum
      C.CFloatType _ -> CTNum
      C.CDoubleType _ -> CTNum
      C.CSignedType _ -> CTNum
      C.CUnsigType _ -> CTNum
      C.CBoolType _ -> CTNum
      C.CLongType _ -> CTNum
      C.CInt128Type _ -> CTNum
      C.CFloatNType{} -> CTNum
      C.CSUType _ _ -> CTStruct
      C.CEnumType _ _ -> CTNum
      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 (C.identToString idx))
      a -> notSupportedYet a C.undefNode
    _ow -> Nothing

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 (Maybe Struct))
  , functions :: !(Map.Map C.Ident (Maybe Function))
  }
  deriving (Show)

data InlineType
  = ITKeep
  | ITInline ![C.CDeclarationSpecifier C.NodeInfo]
  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)

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

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
    , ..
    }

defaultContext :: Context
defaultContext =
  Context
    { keywords = Set.fromList []
    , typeDefs = Map.empty
    , inlineExprs =
        Map.fromList
          [ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep CTNum)
          , (C.builtinIdent "__FUNCTION__", IEKeep CTNum)
          ]
    , structs = Map.empty
    , functions = 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)

data Struct = Struct
  { structName :: !C.Ident
  , structFields :: ![(Maybe C.Ident, Maybe CType)]
  , structTag :: !C.CStructTag
  , structPosition :: !C.Position
  }
  deriving (Show, Eq)

findStructs
  :: forall m
   . (Monoid m)
  => (Struct -> m)
  -> Context
  -> C.CExternalDeclaration C.NodeInfo
  -> m
findStructs inject ctx = \case
  C.CDeclExt decl -> findStructsInDeclaration decl
  C.CFDefExt (C.CFunDef spec declr params stmt _ni) ->
    findStructsInDeclarator declr
      <> foldMap findStructsInSpecifier spec
      <> foldMap findStructsInDeclaration params
      <> findStructsInStatement stmt
  C.CAsmExt _ _ -> mempty
 where
  toStruct (C.CStruct tag mid mfields _attr ni) = fromMaybe mempty do
    fields <- mfields
    let fields' = fmap Just <$> concatMap (structField ctx) fields
    sid <- mid
    pure $ inject (Struct sid fields' tag (C.posOf ni))

  -- TODO currently we do not look for structs inside of expressions.
  -- (Can hide in CCompoundLiterals)
  findStructsInStatement = \case
    C.CCompound _ blocks _ -> flip foldMap blocks \case
      C.CBlockDecl decl -> findStructsInDeclaration decl
      C.CBlockStmt stmt -> findStructsInStatement stmt
      a@(C.CNestedFunDef _) -> notSupportedYet (void a) a
    C.CFor (C.CForDecl decl) _ _ _ _ ->
      findStructsInDeclaration decl
    _ow -> mempty

  findStructsInDeclarator = \case
    C.CDeclr _ dd Nothing [] _ -> flip foldMap dd \case
      C.CPtrDeclr _ _ -> mempty
      C.CArrDeclr{} -> mempty
      C.CFunDeclr (C.CFunParamsOld _) _ _ -> mempty
      C.CFunDeclr (C.CFunParamsNew params _) _ _ ->
        foldMap findStructsInDeclaration params
    a -> notSupportedYet (a $> ()) a