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 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.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 qualified Language.C as C
import qualified Language.C.Data.Ident as C
import qualified Language.C.Data.Node as C

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

defaultReduceC :: (MonadReduce (String, C.Position) m) => C.CTranslUnit -> m C.CTranslUnit
defaultReduceC a = reduceCTranslUnit a defaultContext
{-# SPECIALIZE defaultReduceC :: C.CTranslUnit -> IRTree.IRTree (String, C.Position) C.CTranslUnit #-}

reduceCTranslUnit
  :: (MonadReduce Lab m)
  => C.CTranslationUnit C.NodeInfo
  -> Context
  -> m (C.CTranslationUnit C.NodeInfo)
reduceCTranslUnit (C.CTranslUnit es ni) ctx = do
  (_functions, _structs) <- flip evalState ctx do
    (fs, sts) <- flip mapAndUnzipM es \e -> do
      includeTypeDef e
      funcs <- gets \ctx' -> findFunctions (: []) ctx' e
      structs <- state \ctx' ->
        let ss = findStructs (: []) ctx' e
         in ( ss
            , ctx'
                { structs =
                    foldr
                      ( \s ->
                          Map.insert (structName s) (structType s, Nothing)
                      )
                      (structs ctx')
                      ss
                }
            )

      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 <- 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
      let FunType rtype rparams = funType f
      params <- case rparams 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{funType = FunType rtype params}

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

  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)
        pure s
      modify' (Map.insert (structName s) (structType s, ms))

  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

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

    (FunType rtype pFilter, spec') <- case mid of
      Just fid -> do
        modify' (addInlineExpr fid IEDelete)
        guard (not $ any (shouldDeleteDeclSpec ctx) spec)
        f <- liftMaybe (lookupFunction ctx fid)
        modify' (addInlineExpr fid (IEKeep (TFun $ funType f)))
        pure (funType f, filterStorageModifiers (funIsStatic f) spec)
      Nothing -> do
        let TFun ft = nonVoidTypeOfFromContext ctx spec declr
        exceptIf ("remove function", C.posOf r)
        pure (ft, 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){returnType = rtype}

    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 decl@(C.CDeclr (Just ix) [] Nothing [] _) Nothing Nothing = item
    ctx <- get
    let t = nonVoidTypeOfFromContext ctx rst decl
    modify' (addTypeDef ix (t, ITInline rst))
    exceptIf ("inline typedef" <> C.identToString ix, C.posOf ni)
    modify' (addTypeDef ix (t, ITKeep))
    -- TODO delete typedefs
    gets (C.CDeclExt <$> inlineTypeDefsCDeclaration d)

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

    lift $ includeTypeDef r

    let keep = containsStructDeclaration ctx 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
                  modify' (addInlineExpr fid IEDelete)
                  f <- liftMaybe (lookupFunction ctx fid)
                  modify' (addInlineExpr fid (IEKeep (TFun $ funType f)))
                  params' <- case funTypeParams (funType 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 (void 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
              di' <- reduceCDeclarationItem spec di
              pure (di', 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 -> 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

reduceCDeclarationItem
  :: ( MonadReduce Lab m
     , MonadState Context m
     , MonadPlus m
     )
  => [C.CDeclarationSpecifier C.NodeInfo]
  -> C.CDeclarationItem C.NodeInfo
  -> m (C.CDeclarationItem C.NodeInfo)
reduceCDeclarationItem spec = \case
  di@(C.CDeclarationItem decl@(C.CDeclr mid _ Nothing [] ni) einit Nothing) -> do
    ctx <- get
    case mid of
      Just vid -> do
        modify' (addInlineExpr vid IEDelete)
        let t = nonVoidTypeOfFromContext ctx spec decl
        guard (not $ any (shouldDeleteDeclSpec ctx) spec)
        einit' <- case einit of
          Just (C.CInitExpr e ni2) -> do
            e' <- fromMaybe (pure zeroExpr) $ reduceCExpr e (exactly t) ctx
            let inlinable = case e' of
                  C.CConst _ -> True
                  C.CVar _ _ -> True
                  _ow -> False
            when inlinable do
              modify' (addInlineExpr vid (IEInline e'))
              exceptIf ("inline variable " <> C.identToString vid, C.posOf ni)
            modify' (addInlineExpr vid (IEKeep t))
            pure (Just (C.CInitExpr e' ni2))
          -- TODO handle later
          Just (C.CInitList i ni2) -> do
            exceptIf ("delete variable", C.posOf ni)
            modify' (addInlineExpr vid (IEKeep t))
            pure (Just (C.CInitList i ni2))
          Nothing -> do
            exceptIf ("delete uninitialized variable", C.posOf vid)
            modify' (addInlineExpr vid (IEKeep t))
            pure Nothing
        pure (C.CDeclarationItem decl einit' Nothing)
      Nothing -> do
        guard (not $ any (shouldDeleteDeclSpec ctx) spec)
        exceptIf ("remove unnamed declaration item", C.posOf ni)
        pure di
  a -> notSupportedYet a C.undefNode

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 keep = containsStructDeclaration ctx spec

      -- Try to remove each declaration item
      items' <- collect (reduceCDeclarationItem spec) 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)

      decl' <- gets (inlineTypeDefsCDeclaration (C.CDecl spec items' ni))
      pure [C.CBlockDecl decl']
    a -> notSupportedYet' 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)

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
        let spec' = inlineTypeDefsSpecs spec ctx
        (items', ctx') <- runStateT (collect (reduceCDeclarationItem spec) 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) => Type -> EType -> m ()
checkExpectedType t et = guard $ isExpectedType t et

isExpectedType :: Type -> EType -> Bool
isExpectedType = \c et ->
  -- pTraceShowWith (\a -> ("check", a, c, et, a)) $
  go c (etSet et)
 where
  go c = \case
    ETExactly t -> t == 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 =
  -- pTraceShowWith (\t' -> ("unpoint", t, 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'}
    _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

ctypeOf :: Context -> C.CExpr -> Maybe Type
ctypeOf ctx = \case
  C.CVar i _ -> do
    f <- lookupFunction ctx i
    pure $ TFun (funType f)
  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
        let t' =
              if o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]
                then EType ETComparable False
                else exactly TNum
        -- in this case we change type, so we need to keep the operation
        rl <- reduceCExpr elhs t' ctx
        rr <- reduceCExpr erhs t' ctx
        Just do
          l' <- rl
          r' <- rr
          pure $ C.CBinary o l' r' ni
  C.CAssign o elhs erhs ni ->
    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
        let t' = if o == C.CAssignOp then etSet t else ETExactly TNum
        -- in this case we change type, so we need to keep the operation
        rl <- reduceCExpr elhs (EType t' True) ctx
        rr <- reduceCExpr erhs (EType t' False) ctx
        Just do
          l' <- rl
          r' <- rr
          pure $ C.CAssign o l' r' ni
  C.CVar i _ ->
    case lookupVariable ctx i of
      IEKeep c -> do
        checkExpectedType c t
        Just (pure expr)
      IEInline mx' -> do
        guard (DisallowVariableInlining `isIn` ctx || not (etAssignable t))
        Just (pure mx')
      IEDelete ->
        Nothing
  C.CConst x -> do
    case x of
      C.CStrConst _ _ -> do
        checkNotAssignable t
        -- guard (TPointer (NonVoid TNum) `match` etSet t)
        Just (pure expr)
      _ow -> do
        checkNotAssignable t
        -- guard (TNum `match` etSet t)
        Just (pure expr)
  C.CUnary o eopr ni -> do
    msplit ("reduce to operant", C.posOf eopr) (reduceCExpr eopr t ctx) do
      case o of
        C.CIndOp -> do
          checkNotAssignable t
          ropr <- reduceCExpr eopr (EType{etSet = ETPointer (etSet t), etAssignable = False}) ctx
          Just do
            eopr' <- ropr
            pure $ C.CUnary o eopr' ni
        C.CAdrOp -> do
          t' <- etUnPointer t
          -- pTraceShowM (t', void eopr)
          ropr <- reduceCExpr eopr (t'{etAssignable = True}) ctx
          Just do
            eopr' <- ropr
            pure $ C.CUnary o eopr' ni
        e
          | e `List.elem` [C.CPreIncOp, C.CPreDecOp, C.CPostIncOp, C.CPostDecOp] -> do
              reduceCExpr eopr t{etAssignable = True} ctx <&> \ropr -> do
                eopr' <- ropr
                pure $ C.CUnary o eopr' ni
          | otherwise -> do
              reduceCExpr eopr t ctx <&> \ropr -> do
                eopr' <- ropr
                pure $ C.CUnary o eopr' ni
  C.CCall ef args ni -> do
    (\fn a -> foldr fn a args)
      (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx))
      do
        ct <- ctypeOf ctx ef
        case ct of
          ft@(TFun (FunType _ fargs)) -> do
            checkNotAssignable t
            -- unless (etSet t == ETAny) do
            --   rt <- fromVoid mzero pure mrt
            --   guard (rt `match` etSet t)
            -- TODO (should be function?)
            ref <- reduceCExpr ef (exactly ft) ctx
            let targs = case fargs of
                  Params targs' v ->
                    let cons = if v then repeat (Just ETAny) else []
                     in map (fmap ETExactly) targs' <> cons
                  VoidParams -> repeat (Just ETAny)
            let pargs = mapMaybe (\(ta, a) -> (,a) <$> ta) (zip targs args)
            rargs <- forM pargs \(ta, a) ->
              reduceCExpr a (EType ta False) ctx
            Just do
              ef' <- ref
              args' <- sequence rargs
              pure $ C.CCall ef' args' ni
          ow -> do
            error $
              "Original c code does not type-check: exepected function, got "
                <> show ow
                <> " at "
                <> show (C.posOf ef)
  C.CCond et (Just ec) ef ni -> do
    msplit ("reduce to true branch", C.posOf et) (reduceCExpr et t ctx) do
      msplit ("reduce to false branch", C.posOf ef) (reduceCExpr ef t ctx) do
        msplit ("reduce to condtion", C.posOf ef) (reduceCExpr ec t ctx) do
          checkNotAssignable t
          ret <- reduceCExpr et t ctx
          ref <- reduceCExpr ef t ctx
          rec <- reduceCExpr ec etAny ctx
          Just $ do
            et' <- ret
            ef' <- ref
            ec' <- rec
            pure $ C.CCond et' (Just ec') ef' ni
  C.CCast decl@(C.CDecl spec items _) e ni -> do
    msplit ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do
      re <- case items of
        [C.CDeclarationItem dec _ _] -> do
          -- let ct = nonVoidTypeOfFromContext ctx spec dec
          reduceCExpr e etAny ctx
        [] -> case baseTypeOfFromContext ctx spec of
          Void ->
            reduceCExpr e etAny ctx
          NonVoid ct' -> do
            -- checkExpectedType ct' t
            reduceCExpr e etAny ctx
        a -> notSupportedYet a ni
      Just do
        e' <- re
        pure (C.CCast (inlineTypeDefsCDeclaration decl ctx) e' ni)
  C.CIndex e1 e2 ni -> do
    msplit ("reduce to indexee", C.posOf e1) (reduceCExpr e1 t ctx) do
      msplit ("reduce to index", C.posOf e2) (reduceCExpr e2 t ctx) do
        re1 <- reduceCExpr e1 t{etSet = ETPointer (etSet t)} ctx
        Just do
          e1' <- re1
          e2' <-
            fromMaybe (pure zeroExpr) $
              reduceCExpr e2 etNum ctx
          pure $ C.CIndex e1' e2' ni
  C.CComma items ni -> do
    (x, rst) <- List.uncons (reverse items)
    (\fn a -> foldr fn a (reverse items))
      (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx))
      do
        rx <- reduceCExpr x t ctx
        Just do
          rst' <- flip collect rst \e -> do
            re <- liftMaybe (reduceCExpr e (EType ETAny False) ctx)
            e' <- re
            exceptIf ("remove expression", C.posOf e)
            pure (e' :: C.CExpr)
          x' <- rx
          pure $ C.CComma (reverse (x' : rst')) ni
  C.CMember e i l ni -> do
    re <- reduceCExpr e t{etSet = ETStructWithField i (etSet t)} ctx
    Just do
      e' <- re
      pure (C.CMember e' i l ni)
  a -> notSupportedYet' 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 -> notSupportedYet' 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 -> notSupportedYet' a
 where
  shouldDeleteDeclItem = \case
    C.CDeclarationItem a _ _ -> shouldDeleteDeclartor a
    a -> notSupportedYet a decl

  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 -> notSupportedYet' 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 -> 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

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

lookupVariable :: (HasCallStack) => Context -> C.Ident -> InlineExpr
lookupVariable ctx k =
  fromMaybe (error ("could not find variable " <> C.identToString k)) $
    inlineExprs ctx Map.!? k

lookupStruct :: (HasCallStack) => Context -> C.Ident -> Maybe Struct
lookupStruct ctx k =
  maybe (error ("could not find struct " <> C.identToString k)) snd $
    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 -> []

-- applyDerivedDeclarators :: [C.CDerivedDeclarator C.NodeInfo] -> Maybe CType -> Maybe CType
-- applyDerivedDeclarators [] ct = ct
-- applyDerivedDeclarators _ _ = Just (CTPointer undefined)

-- -- \| Returns nothing if void is used
-- functionParameters
--   :: Context
--   -> [C.CDerivedDeclarator C.NodeInfo]
--   -> Maybe FunctionParams
-- functionParameters ctx = \case
--   (C.CFunDeclr (C.CFunParamsNew x b) _ _) : rst ->
--     case x of
--       [C.CDecl [C.CTypeSpec (C.CVoidType _)] _ _] ->
--         Just VoidParams
--       params ->
--         Just (Params (fmap (Just . snd) . map (functionParameter ctx) $ params) b)
--   _ow -> Nothing

structField :: Context -> C.CDeclaration C.NodeInfo -> [(C.Ident, Type)]
structField ctx = \case
  C.CDecl spec items _ ->
    map
      ( \(C.CDeclarationItem decl _ _) ->
          (fromJust (name decl), nonVoidTypeOfFromContext ctx spec decl)
      )
      items
  a@(C.CStaticAssert{}) -> notSupportedYet' a

data Context = Context
  { keywords :: !(Set.Set Keyword)
  , typeDefs :: !(Map.Map C.Ident (Type, InlineType))
  , inlineExprs :: !(Map.Map C.Ident InlineExpr)
  , structs :: !(Map.Map C.Ident (StructType, Maybe Struct))
  , functions :: !(Map.Map C.Ident (Maybe Function))
  , returnType :: !Voidable
  }
  deriving (Show)

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

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

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

type Lab = (String, C.Position)

addTypeDef :: C.Ident -> (Type, InlineType) -> Context -> Context
addTypeDef i cs ctx = ctx{typeDefs = Map.insert i cs $ typeDefs ctx}

addInlineExpr :: C.Ident -> InlineExpr -> Context -> Context
addInlineExpr i e Context{..} =
  Context{inlineExprs = Map.insert i e inlineExprs, ..}

defaultContext :: Context
defaultContext =
  Context
    { keywords = Set.fromList []
    , typeDefs = Map.empty
    , inlineExprs =
        Map.fromList
          [ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
          , (C.builtinIdent "__FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
          ]
    , structs = Map.empty
    , functions = Map.empty
    , returnType = Void
    }

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)