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

module ReduceC (
  defaultReduceC,
  defaultReduceCWithKeywords,
  -- reduceCTranslUnit,

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

  -- * Helpers
  prettyIdent,
) where

import Control.Applicative (Alternative (empty, (<|>)))
import Control.Monad (
  MonadPlus (mzero),
  foldM,
  forM,
  forM_,
  guard,
  join,
  mapAndUnzipM,
  unless,
  void,
  when,
 )
import qualified Control.Monad.IRTree as IRTree
import Control.Monad.Reduce (
  MonadReduce (split),
  collect,
  exceptIf,
  liftMaybe,
 )
import Control.Monad.State (
  MonadState (get, state),
  MonadTrans (lift),
  State,
  StateT (runStateT),
  evalState,
  evalStateT,
  gets,
  modify',
  runState,
 )
import Control.Monad.Trans.Maybe (MaybeT (runMaybeT))
import Data.Function ((&))
import Data.Functor (($>), (<&>))
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe (
  catMaybes,
  fromMaybe,
  isJust,
  isNothing,
  mapMaybe,
 )
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
import qualified Language.C as C
import qualified Language.C.Data.Ident as C
import qualified Language.C.Data.Node as C

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

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

reduceCTranslUnit ::
  (MonadReduce Lab m) =>
  C.CTranslationUnit C.NodeInfo ->
  Context ->
  m (C.CTranslationUnit C.NodeInfo)
reduceCTranslUnit (C.CTranslUnit es ni) ctx = do
  let _functions = foldMap (findFunctions (: [])) es

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

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

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

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

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

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

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

newtype SpecifierFilter = SpecifierFilter
  { sfKeepStatic :: Bool
  }

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

{- | Update the CDeclarationSpecifier's to match the context. Specifically, update
the typedefs and the structs. Alos return a base type.
-}
updateCDeclarationSpecifiers ::
  ( MonadState Context m
  , MonadPlus m
  ) =>
  SpecifierFilter ->
  [C.CDeclarationSpecifier C.NodeInfo] ->
  m (Voidable, [C.CDeclarationSpecifier C.NodeInfo])
updateCDeclarationSpecifiers sf spec = do
  ctx <- get
  spec' <- concat <$> mapM (updateSpec ctx) spec
  bt <- baseType ctx spec'
  pure (bt, spec')
 where
  baseType ::
    (MonadPlus m) =>
    Context ->
    [C.CDeclarationSpecifier C.NodeInfo] ->
    m Voidable
  baseType ctx =
    liftMaybe
      . exactlyOne
      . map \case
        C.CVoidType _ -> Just Void
        C.CSUType c _ -> NonVoid . TStruct <$> structId c
        C.CCharType _ -> Just $ NonVoid TNum
        C.CShortType _ -> Just $ NonVoid TNum
        C.CIntType _ -> Just $ NonVoid TNum
        C.CFloatType _ -> Just $ NonVoid TNum
        C.CDoubleType _ -> Just $ NonVoid TNum
        C.CSignedType _ -> Just $ NonVoid TNum
        C.CUnsigType _ -> Just $ NonVoid TNum
        C.CBoolType _ -> Just $ NonVoid TNum
        C.CLongType _ -> Just $ NonVoid TNum
        C.CInt128Type _ -> Just $ NonVoid TNum
        C.CFloatNType{} -> Just $ NonVoid TNum
        C.CEnumType (C.CEnum (Just ix) _ _ _) _ ->
          NonVoid TNum
            <$ guard (lookupEnum ctx ix == INKeep)
        C.CEnumType (C.CEnum Nothing _ _ _) _ -> Just $ NonVoid TNum
        C.CTypeDef idx _ ->
          case Map.lookup idx (typeDefs ctx) of
            Just (ITKeep t') -> Just t'
            Just ITDelete -> Nothing
            Just (ITInline t' _) -> Just t'
            Nothing -> error "error"
        a -> notSupportedYet (void a) a
      . typeSpecs
   where
    typeSpecs = mapMaybe \case
      C.CTypeSpec ts -> Just ts
      _ow -> Nothing

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

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

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

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

    typeOf spec2 decl = baseType ctx spec2 >>= extendTypeWith decl

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

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

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

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

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

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

reduceCExternalDeclaration ::
  (HasCallStack, MonadReduce Lab m) =>
  C.CExternalDeclaration C.NodeInfo ->
  StateT Context m (Maybe (C.CExternalDeclaration C.NodeInfo))
reduceCExternalDeclaration r = case r of
  C.CFDefExt (C.CFunDef spec declr [] stmt ni) -> runMaybeT do
    ctx <- get

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

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

    let keepStatic = maybe True funIsStatic mfun
    -- TODO handle this edgecase (struct declared in function declaration)
    _ <- reduceStructDeclaration spec
    (bt, spec') <- updateCDeclarationSpecifiers keepAll{sfKeepStatic = keepStatic} spec
    ((nonVoid -> t@(TFun (FunType rt _)), dd'), ctx') <-
      runStateT
        (updateCDerivedDeclarators bt (fromMaybe (repeat True) (mfun >>= funParams)) dd)
        ctx

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

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

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

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

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

    modify' (addTypeDef ix ITDelete)

    keep <- reduceStructDeclaration rst
    (bt, rst') <- updateCDeclarationSpecifiers keepAll rst

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

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

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

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

    markDeleted items

    -- TODO: Actually we should split it up here
    let isStatic = flip any items \case
          (C.CDeclarationItem (C.CDeclr (Just fid) (C.CFunDeclr{} : _) _ _ _) _ _) -> do
            maybe True funIsStatic (lookupFunction ctx fid)
          _ow -> True

    keep <- reduceStructDeclaration spec

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

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

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

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

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

{- | This checks the current declaration and reduces any new struct found here.
Returns true if the specifier is requried.
-}
reduceStructDeclaration ::
  ( MonadReduce Lab m
  , MonadState Context m
  , MonadPlus m
  ) =>
  [C.CDeclarationSpecifier C.NodeInfo] ->
  m Bool
reduceStructDeclaration =
  fmap or . mapM \case
    C.CTypeSpec (C.CEnumType (C.CEnum mid mf _ _) ni) -> do
      case mid of
        Just eid -> do
          case mf of
            Just times -> forM_ times \(C.CEnumVar ix _) -> do
              modify' (addInlineExpr ix IEDelete)
            Nothing -> pure ()
          modify' (addEnum eid INDelete)
          exceptIf ("delete enum " <> C.identToString eid, C.posOf ni)
          modify' (addEnum eid INKeep)
          case mf of
            Just times -> forM_ times \(C.CEnumVar ix _) -> do
              modify' (addInlineExpr ix (IEKeep TNum))
            Nothing -> pure ()

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

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

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

reduceCCompoundBlockItem ::
  (MonadReduce Lab m, HasCallStack) =>
  StmtContext ->
  C.CCompoundBlockItem C.NodeInfo ->
  StateT Context m [C.CCompoundBlockItem C.NodeInfo]
reduceCCompoundBlockItem lab r = do
  case r of
    C.CBlockStmt smt -> do
      ctx <- get
      msmt <- runMaybeT $ reduceCStatement smt lab ctx
      case msmt of
        Just smt' -> do
          case smt' of
            C.CCompound [] ss _ ->
              whenSplit
                (all (\case C.CBlockStmt _ -> True; _ow -> False) ss)
                ("expand compound statment", C.posOf r)
                (pure ss)
                (pure [C.CBlockStmt smt'])
            _ow -> pure [C.CBlockStmt smt']
        Nothing -> pure []
    C.CBlockDecl (C.CDecl spec items ni) -> fmap (fromMaybe []) . runMaybeT $ do
      ctx <- get

      markDeleted items

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

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

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

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

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

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

reduceCStatementOrEmptyExpr ::
  (MonadReduce Lab m, HasCallStack) =>
  C.CStatement C.NodeInfo ->
  StmtContext ->
  Context ->
  m (C.CStatement C.NodeInfo)
reduceCStatementOrEmptyExpr stmt ids ctx = do
  fromMaybe (C.CExpr Nothing C.undefNode)
    <$> runMaybeT (reduceCStatement stmt ids ctx)

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

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

etAny :: EType
etAny = EType ETAny False

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

exactly :: Type -> EType
exactly c = EType (ETExactly c) False

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

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

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

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

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

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

fieldsOfStruct :: (HasCallStack) => Context -> Either C.Ident StructType -> [(C.Ident, Maybe Type)]
fieldsOfStruct ctx (Left ix) =
  case lookupStruct ctx ix of
    ISKeep a -> structTypeFields a
    _ow -> error "Something bad happend"
fieldsOfStruct _ (Right a) = structTypeFields a

etUnPointer :: EType -> Maybe EType
etUnPointer t =
  -- pTraceWith (\t' -> "unpoint " <> show t <> " " <> show t') $
  case etSet t of
    ETPointer t' -> Just t{etSet = t'}
    ETExactly (TPointer Void) -> Just t{etSet = ETAny}
    ETExactly (TPointer (NonVoid t')) -> Just t{etSet = ETExactly t'}
    _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
{-# INLINE msplit #-}

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

reduceCExpr ::
  forall m.
  (MonadReduce Lab m, HasCallStack) =>
  C.CExpr ->
  EType ->
  Context ->
  Maybe (m C.CExpr)
reduceCExpr expr t ctx = case expr of
  C.CBinary o elhs erhs ni -> do
    msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
      msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
        checkNotAssignable t
        when (o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]) do
          checkExpectedType ctx (NonVoid TNum) t
        c <- inferType ctx elhs
        let t' = fromVoid etAny exactly c
        rl <- reduceCExpr elhs t' ctx
        rr <- reduceCExpr erhs t' ctx
        Just do
          l' <- rl
          r' <- rr
          let r'' = case o of
                C.CDivOp -> case r' of
                  C.CConst (C.CIntConst i _)
                    | i == C.cInteger 0 ->
                        C.CConst (C.CIntConst (C.cInteger 1) C.undefNode)
                  C.CUnary o' (C.CConst (C.CIntConst i _)) _
                    | i == C.cInteger 0 ->
                        C.CUnary o' (C.CConst (C.CIntConst (C.cInteger 1) C.undefNode)) C.undefNode
                  _ow -> r'
                _ow -> r'
          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
        c <- inferType ctx elhs
        checkExpectedType ctx c t
        let t' = fromVoid etAny exactly c
        -- in this case we change type, so we need to keep the operation
        rl <- reduceCExpr elhs t'{etAssignable = True} ctx
        rr <- reduceCExpr erhs t' 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 ctx (NonVoid c) t
        Just (pure expr)
      IEInline mx' -> do
        guard (not $ DisallowVariableInlining `isIn` ctx)
        reduceCExpr mx' t ctx
      IEDelete ->
        Nothing
  C.CConst x -> do
    case x of
      C.CStrConst _ _ -> do
        checkNotAssignable t
        checkExpectedType ctx (NonVoid (TPointer (NonVoid TNum))) t
        -- guard ( `match` etSet t)
        Just (pure expr)
      C.CIntConst (C.getCInteger -> 0) _ -> do
        checkNotAssignable t
        checkExpectedType ctx (NonVoid (TPointer Void)) t
          <|> checkExpectedType ctx (NonVoid TNum) t
        Just (pure expr)
      _ow -> do
        checkNotAssignable t
        checkExpectedType ctx (NonVoid TNum) 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
          ropr <-
            if etSet t == ETAny
              then do
                reduceCExpr eopr t ctx
              else reduceCExpr eopr (t{etSet = ETPointer (etSet t), etAssignable = True}) ctx
          Just do
            eopr' <- ropr
            pure $ C.CUnary o eopr' ni
        C.CAdrOp -> do
          t' <- etUnPointer t
          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 <- inferType ctx ef
        case ct of
          NonVoid ft@(TFun (FunType rt fargs)) -> do
            checkNotAssignable t
            checkExpectedType ctx rt t
            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 (C.CDecl spec items ni2) e ni -> do
    msplit ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do
      (bt, spec') <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx
      (items', re) <- case items of
        [C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] a) b c] -> do
          (_, dd') <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx
          ([C.CDeclarationItem (C.CDeclr Nothing dd' Nothing [] a) b c],) <$> do
            reduceCExpr e etAny ctx
        [] ->
          ([],) <$> case bt of
            Void ->
              reduceCExpr e etAny ctx
            NonVoid _ -> do
              -- checkExpectedType ct' t
              reduceCExpr e etAny ctx
        a -> notSupportedYet a ni
      Just do
        e' <- re
        pure (C.CCast (C.CDecl spec' items' ni2) 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 = ETIndexable (etSet t), etAssignable = True} 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

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 -> InlineStruct
lookupStruct ctx k =
  fromMaybe (error ("could not find struct " <> C.identToString k)) $
    structs ctx Map.!? k
lookupEnum :: (HasCallStack) => Context -> C.Ident -> InlineEnum
lookupEnum ctx k =
  fromMaybe (error ("could not find enum " <> C.identToString k)) $
    enums 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 -> []

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

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

data InlineStruct
  = ISKeep !StructType
  | ISDeclared !C.CStructTag
  | ISDelete
  deriving (Show, Eq)

data InlineEnum
  = INKeep
  | INDelete
  deriving (Show, Eq)

data InlineExpr
  = IEKeep !Type
  | IEInline !C.CExpr
  | IEDelete
  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 -> 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, ..}

addStruct :: C.Identifier C.NodeInfo -> InlineStruct -> Context -> Context
addStruct i cs ctx = ctx{structs = Map.insert i cs $ structs ctx}

addEnum :: C.Identifier C.NodeInfo -> InlineEnum -> Context -> Context
addEnum i cs ctx = ctx{enums = Map.insert i cs $ enums ctx}

defaultContext :: Context
defaultContext =
  Context
    { keywords = Set.fromList []
    , typeDefs = Map.fromList [(C.builtinIdent "__builtin_va_list", ITKeep (NonVoid (TPointer Void)))]
    , inlineExprs =
        Map.fromList
          [ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
          , (C.builtinIdent "__FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
          ]
    , structs = Map.empty
    , enums = 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)

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

data Function = Function
  { funName :: !C.Ident
  , funParams :: !(Maybe [Bool])
  , funIsStatic :: !Bool
  , funSize :: !Int
  , funPosition :: !C.Position
  }
  deriving (Show, Eq)

findFunctions ::
  (Monoid m) =>
  (Function -> m) ->
  C.CExternalDeclaration C.NodeInfo ->
  m
findFunctions inject = \case
  C.CFDefExt (C.CFunDef spec declr [] _ ni) ->
    findFunctionsInDeclarator ni spec declr
  -- # for now let's not anlyse function declarations.
  C.CFDefExt def@(C.CFunDef{}) ->
    notSupportedYet (void def) def
  C.CDeclExt (C.CDecl spec items ni) -> flip foldMap items \case
    C.CDeclarationItem declr Nothing Nothing ->
      findFunctionsInDeclarator ni spec declr
    _ow -> mempty
  C.CDeclExt a@(C.CStaticAssert{}) ->
    notSupportedYet (void a) a
  C.CAsmExt _ _ -> mempty
 where
  findFunctionsInDeclarator ni spec = \case
    (C.CDeclr mid (C.CFunDeclr param _ _ : _) Nothing [] _) ->
      case mid of
        Just funName -> inject Function{..}
         where
          funIsStatic = isStaticFromSpecs spec
          funSize = fromMaybe 0 (C.lengthOfNode ni)
          funPosition = C.posOf ni
          funParams = case param of
            C.CFunParamsNew declr var ->
              case declr of
                [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> Nothing
                _
                  | var -> Nothing
                  | otherwise -> Just [True | _ <- declr]
            a -> notSupportedYet (void a) ni
        Nothing -> mempty
    _ow -> mempty

class Named f where
  name :: f a -> Maybe (C.Identifier a)

instance Named C.CDeclarator where
  name (C.CDeclr idx _ _ _ _) = idx

instance Named C.CDeclarationItem where
  name = \case
    C.CDeclarationItem decl _ _ -> name decl
    C.CDeclarationExpr _ -> Nothing

data Params
  = VoidParams
  | Params ![Maybe Type] !Bool
  deriving (Show, Eq)

data FunType = FunType
  { funTypeReturn :: !Voidable
  , funTypeParams :: !Params
  }
  deriving (Show, Eq)

data StructType = StructType
  { structTypeTag :: !C.CStructTag
  , structTypeName :: !(Maybe C.Ident)
  , structTypeFields :: ![(C.Ident, Maybe Type)]
  }
  deriving (Show, Eq)

data Type
  = TNum
  | TStruct !(Either C.Ident StructType)
  | TPointer !Voidable
  | TVector !Int !Voidable
  | TFun !FunType
  deriving (Show, Eq)

data Voidable
  = Void
  | NonVoid !Type
  deriving (Show, Eq)

fromVoid :: a -> (Type -> a) -> Voidable -> a
fromVoid a fn = \case
  Void -> a
  NonVoid t -> fn t
{-# INLINE fromVoid #-}

nonVoid :: (HasCallStack) => Voidable -> Type
nonVoid = fromVoid (error "expected non void type") id
{-# INLINE nonVoid #-}

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

notSupportedYet' :: (HasCallStack, Show (a ()), Functor a, C.Pos (a C.NodeInfo)) => a C.NodeInfo -> b
notSupportedYet' a = notSupportedYet (void a) a