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

module ReduceC (
  defaultReduceC,
  defaultReduceCWithKeywords,
  -- reduceCTranslUnit,

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

  -- * Helpers
  prettyIdent,
) where

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

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

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

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

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

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

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

  functions3 <- forM functions2 \(k, mf) ->
    (k,) <$> runMaybeT do
      f <- liftMaybe mf
      params <- case funParams f of
        Just params -> do
          Just <$> forM params \p ->
            if p
              then split ("remove parameter", funPosition f) (pure False) (pure True)
              else pure False
        ow -> pure ow
      pure f{funParams = params}

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

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

  -- let _structs = foldMap (findStructs (: [])) es
  -- structs' <- flip execStateT (structs ctx) do
  --   forM_ _structs \s -> do
  --     let sstr = C.identToString (structName s)
  --     ms <- runMaybeT do
  --       exceptIf ("remove struct " <> show sstr, structPosition s)
  --       let st = structType s
  --       fields <- forM (structTypeFields st) \(i, m) -> do
  --         (i,) <$> runMaybeT do
  --           m' <- liftMaybe m
  --           exceptIf ("remove field " <> sstr <> "." <> C.identToString i, structPosition s)
  --           pure m'
  --       pure s{structType = st{structTypeFields = fields}}
  --     modify' (Map.insert (structName s) (structType s, ms))

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

data SpecifierFilter = SpecifierFilter
  { sfKeepStatic :: Bool
  }

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

{- | Update the CDeclarationSpecifier's to match the context. Specifically, update
the typedefs and the structs. Alos return a base type.
-}
updateCDeclarationSpecifiers
  :: ( MonadState Context m
     , MonadPlus m
     )
  => SpecifierFilter
  -> [C.CDeclarationSpecifier C.NodeInfo]
  -> m (Voidable, [C.CDeclarationSpecifier C.NodeInfo])
updateCDeclarationSpecifiers sf spec = do
  ctx <- get
  spec' <- concat <$> mapM (updateSpec ctx) spec
  bt <- baseType ctx spec'
  pure (bt, spec')
 where
  baseType
    :: (MonadPlus m)
    => Context
    -> [C.CDeclarationSpecifier C.NodeInfo]
    -> m Voidable
  baseType ctx = do
    liftMaybe
      . baseTypeOf
        (lookupStruct ctx)
        ( \t -> case Map.lookup t (typeDefs ctx) of
            Just (ITKeep t') -> Just t'
            Just ITDelete -> Nothing
            Just (ITInline t' _) -> Just t'
            Nothing -> error "error"
        )

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

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

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

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

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

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

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

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

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

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

    let keepStatic = maybe True funIsStatic mfun

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

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

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

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

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

  -- Type definitions
  C.CDeclExt (C.CDecl (C.CStorageSpec (C.CTypedef nif) : rst) [item] ni) -> runMaybeT do
    let C.CDeclarationItem (C.CDeclr (Just ix) [] Nothing [] _) Nothing Nothing = item

    modify' (addTypeDef ix ITDelete)

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

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

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

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

    markDeleted items

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

    (keep, spec2) <- reduceStructDeclaration spec

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

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

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

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

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

{- | This checks the current declaration and reduces any new struct found here.
Returns true if the specifier is requried.
-}
reduceStructDeclaration
  :: ( MonadReduce Lab m
     , MonadState Context m
     , MonadPlus m
     )
  => [C.CDeclarationSpecifier C.NodeInfo]
  -> m (Bool, [C.CDeclarationSpecifier C.NodeInfo])
reduceStructDeclaration =
  fmap (first or) . mapAndUnzipM \case
    x@(C.CTypeSpec (C.CSUType (C.CStruct tag mid (Just fields) attr ni2) ni)) -> case mid of
      Just sid -> do
        struct <- gets (Map.lookup sid . structs)
        case struct of
          -- Already declared do nothing.
          Just _ ->
            pure (False, x)
          -- Not declared do somthing
          Nothing -> do
            (ft, fields') <- mapAndUnzipM structField fields
            split
              ("remove struct " <> C.identToString sid, C.posOf ni)
              do
                modify' (addStruct sid Nothing)
                mzero
              do
                modify'
                  ( addStruct
                      sid
                      ( Just
                          StructType
                            { structTypeTag = tag
                            , structTypeName = Just sid
                            , structTypeFields = concat ft
                            }
                      )
                  )
                pure (True, C.CTypeSpec (C.CSUType (C.CStruct tag mid (Just fields') attr ni2) ni))
      Nothing -> pure (False, x)
    x -> pure (False, x)
 where
  structField = \case
    C.CDecl spec items ni -> do
      -- TODO: Currently deletes all struct fields if one of them are deleted.
      (bt, spec') <- updateCDeclarationSpecifiers keepAll spec
      (fields, items') <- flip mapAndUnzipM items \case
        (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni3) ini ni2) -> do
          (nonVoid -> t, dd') <- updateCDerivedDeclarators bt (repeat True) dd
          let ft = (fromMaybe (error "all struct fields should be named") mid, Just t)
          pure (ft, C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni3) ini ni2)
        a -> notSupportedYet a ni
      pure (fields, C.CDecl spec' items' ni)
    a@(C.CStaticAssert{}) -> notSupportedYet' a

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

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

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

      markDeleted items

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

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

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

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

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

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

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

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

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

etAny :: EType
etAny = EType ETAny False

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

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

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

-- | If the condition is statisfied try to reduce to the a.
whenSplit :: (MonadReduce Lab m) => Bool -> Lab -> m a -> m a -> m a
whenSplit cn lab a b
  | cn = split lab a b
  | otherwise = b

maybeSplit :: (MonadReduce Lab m) => Lab -> Maybe (m a) -> m (Maybe a)
maybeSplit lab = \case
  Just r -> do
    split lab (pure Nothing) (Just <$> r)
  Nothing -> do
    pure Nothing

zeroExpr :: C.CExpression C.NodeInfo
zeroExpr = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)

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

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

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

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

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

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

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

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

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

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

reduceCExpr
  :: forall m
   . (MonadReduce Lab m, HasCallStack)
  => C.CExpr
  -> EType
  -> Context
  -> Maybe (m C.CExpr)
reduceCExpr expr t ctx = case expr of
  C.CBinary o elhs erhs ni -> do
    msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
      msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
        checkNotAssignable t
        when (o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]) do
          checkExpectedType (NonVoid TNum) t
        c <- inferType ctx elhs
        let t' = fromVoid etAny exactly c
        -- if
        --   then EType ETComparable False
        --   else exactly TNum
        -- 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
        c <- inferType ctx elhs
        checkExpectedType 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 (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 (NonVoid (TPointer (NonVoid TNum))) t
        -- guard ( `match` etSet t)
        Just (pure expr)
      C.CIntConst (C.getCInteger -> 0) _ -> do
        checkNotAssignable t
        checkExpectedType (NonVoid (TPointer Void)) t
          <|> checkExpectedType (NonVoid TNum) t
        Just (pure expr)
      _ow -> do
        checkNotAssignable t
        checkExpectedType (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 <- 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
          -- 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 <- inferType ctx ef
        case ct of
          NonVoid 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 (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 = 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

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

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

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

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

data InlineType
  = ITKeep !Type
  | ITInline !Type ![C.CDeclarationSpecifier C.NodeInfo]
  | ITDelete
  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 -> 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 -> Maybe StructType -> Context -> Context
addStruct i cs ctx = ctx{structs = Map.insert i cs $ structs ctx}

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)

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

findStructs
  :: forall m
   . (Monoid m)
  => (Struct -> m)
  -> C.CExternalDeclaration C.NodeInfo
  -> m
findStructs inject = \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 _ mid mfields _attr ni) = fromMaybe mempty do
    fields <- mfields
    let fields' = Just <$> concatMap structField fields
    sid <- mid
    pure $ inject (Struct sid fields' (C.posOf ni))

  structField = \case
    C.CDecl _ items _ ->
      map (\(C.CDeclarationItem decl _ _) -> fromMaybe (error "all struct fields should be named") (name decl)) items
    a@(C.CStaticAssert{}) -> notSupportedYet' a

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

  findStructsInDeclaration = \case
    C.CDecl spec items ni ->
      foldMap findStructsInSpecifier spec <> flip foldMap items \case
        C.CDeclarationItem d _minit _mexpr -> do
          findStructsInDeclarator d
        a -> notSupportedYet a ni
    a@(C.CStaticAssert _ _ ni) -> notSupportedYet (a $> ()) ni

  findStructsInSpecifier = \case
    C.CTypeSpec (C.CSUType cu _) -> toStruct cu
    _ow -> mempty

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
    decl@(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

-- nonVoidTypeOfFromContext
--   :: (HasCallStack) => Context -> [C.CDeclarationSpecifier C.NodeInfo] -> C.CDeclarator C.NodeInfo -> Type
-- nonVoidTypeOfFromContext ctx spec decl =
--   fromVoid (notSupportedYet' decl) id $
--     typeOf
--       (\t -> fst <$> Map.lookup t (structs ctx))
--       (\t -> fst <$> Map.lookup t (typeDefs ctx))
--       spec
--       decl

-- nonVoidExtendType
--   :: (HasCallStack, MonadState Context m, MonadPlus m)
--   => C.CDeclarator C.NodeInfo
--   -> Voidable
--   -> m Type
-- nonVoidExtendType decl bt = do
--   ctx <- get
--   pure $
--     fromVoid (notSupportedYet' decl) id $
--       extendTypeWith
--         (\t -> fst <$> Map.lookup t (structs ctx))
--         (\t -> case Map.lookup t (typeDefs ctx) of
--           Nothing -> error ("could not find " <> show t)
--           Just (ITKeep )
--         decl
--         bt

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

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