ReduceC.hs

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