Skip to content
Snippets Groups Projects
ReduceC.hs 38.9 KiB
Newer Older
chrg's avatar
chrg committed
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE ConstraintKinds #-}
chrg's avatar
chrg committed
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
chrg's avatar
chrg committed
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
chrg's avatar
chrg committed
{-# LANGUAGE TupleSections #-}
chrg's avatar
chrg committed
{-# LANGUAGE TypeFamilies #-}
chrg's avatar
chrg committed
{-# LANGUAGE ViewPatterns #-}
chrg's avatar
chrg committed
{-# LANGUAGE NoMonomorphismRestriction #-}

chrg's avatar
chrg committed
module ReduceC (
  defaultReduceC,
chrg's avatar
chrg committed
  defaultReduceCWithKeywords,
chrg's avatar
chrg committed
  -- reduceCTranslUnit,
chrg's avatar
chrg committed

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

  -- * Helpers
  prettyIdent,
) where
chrg's avatar
chrg committed

chrg's avatar
chrg committed
import Control.Applicative
import Control.Monad
import qualified Control.Monad.IRTree as IRTree
chrg's avatar
chrg committed
import Control.Monad.Reduce
chrg's avatar
chrg committed
import Control.Monad.State
import Control.Monad.Trans.Maybe
import Data.Data
import Data.Foldable
chrg's avatar
chrg committed
import Data.Function
chrg's avatar
chrg committed
import Data.Functor
chrg's avatar
chrg committed
import qualified Data.List as List
import qualified Data.Map.Strict as Map
chrg's avatar
chrg committed
import Data.Maybe
chrg's avatar
chrg committed
import Data.Monoid
chrg's avatar
chrg committed
import qualified Data.Set as Set
import Data.Vector.Internal.Check (HasCallStack)
chrg's avatar
chrg committed
import qualified Language.C as C
chrg's avatar
chrg committed
import qualified Language.C.Data.Ident as C
chrg's avatar
chrg committed
import qualified Language.C.Data.Node as C
chrg's avatar
chrg committed

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

  functions' <- flip execStateT (functions ctx) do
    forM_ (List.sortOn (negate . funSize) _functions) \f -> do
      functions <- get

      if funName f `Map.member` functions
        then pure ()
chrg's avatar
chrg committed
        else do
          mf <- runMaybeT do
            when (C.identToString (funName f) /= "main" || LoseMain `isIn` ctx) do
              exceptIf ("remove function " <> C.identToString (funName f), funPosition f)

            case funParams f of
              Just params -> do
                params' <- forM params \p -> runMaybeT do
                  p' <- liftMaybe p
                  exceptIf ("remove parameter", funPosition f)
                  pure p'
                pure f{funParams = Just params'}
              Nothing -> pure f
          modify' (Map.insert (funName f) mf)

      let insertStub (C.builtinIdent -> fid) ret params
            | not (fid `Map.member` functions) =
                modify' . Map.insert fid . Just $
                  Function
                    { funName = fid
                    , funParams = params
                    , funReturns = ret
                    , funIsStatic = False
                    , funPosition = C.posOf fid
                    , funSize = 0
                    }
            | otherwise = pure ()

      insertStub "fabsf" (Just CTNum) (Just [Just CTNum, Just CTNum])
      insertStub "fabs" (Just CTNum) (Just [Just CTNum, Just CTNum])
chrg's avatar
chrg committed

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

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

reduceCExternalDeclaration
chrg's avatar
chrg committed
  :: (HasCallStack, MonadReduce Lab m)
chrg's avatar
chrg committed
  => C.CExternalDeclaration C.NodeInfo
chrg's avatar
chrg committed
  -> StateT Context m (Maybe (C.CExternalDeclaration C.NodeInfo))
reduceCExternalDeclaration r = case r of
  C.CFDefExt (C.CFunDef spec declr [] stmt ni) -> runMaybeT do
    ctx <- get
    guard (not $ any (shouldDeleteDeclSpec ctx) spec)

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

    pFilter <- case mid of
      Just fid -> do
        f <- liftMaybe (lookupFunction ctx fid)
        pure $ funParams f
      Nothing -> do
        exceptIf ("remove function", C.posOf r)
        case params of
          [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> pure Nothing
          _ow -> pure . Just $ Just . snd <$> concatMap (declarations ctx) params

    let (params', idents) = case pFilter of
          Just flt -> filterParams ctx flt params
          Nothing -> ([C.CDecl [C.CTypeSpec (C.CVoidType C.undefNode)] [] C.undefNode], [])

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

    stmt' <-
      reduceCStatementOrEmptyBlock stmt labs $
        foldr (uncurry addInlineExpr) ctx idents

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

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

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

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

    let t = ctype ctx spec

    lift $ includeTypeDef r

    keep <- containsStructDeclaration spec

    -- Try to remove each declaration item
    items' <- flip collect items \case
      di@(C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit size) -> do
        case dd of
          (C.CFunDeclr params attr ni3) : rst -> do
            dd' <- case mid of
              Just fid -> do
                f <- liftMaybe (lookupFunction ctx fid)
                params' <- case funParams f of
                  Just flt -> case params of
                    C.CFunParamsNew params' b ->
                      pure . flip C.CFunParamsNew b . fst $
                        filterParams ctx flt params'
                    C.CFunParamsOld _ ->
                      notSupportedYet (di $> ()) ni2
                  Nothing -> pure params
                pure (C.CFunDeclr params' attr ni3 : rst)
              Nothing -> do
                exceptIf ("remove function", C.posOf ni2)
                pure dd
            pure (C.CDeclarationItem (C.CDeclr mid dd' Nothing [] ni2) einit size)
          _dd -> do
            let Just t' = applyDerivedDeclarators dd (Just t)
chrg's avatar
chrg committed
            einit' <- reduceVariable t' mid einit ni2
            pure (C.CDeclarationItem (C.CDeclr mid dd Nothing [] ni2) einit' size)
chrg's avatar
chrg committed
      a -> notSupportedYet (a $> ()) ni

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

chrg's avatar
chrg committed
    decl' <- gets (inlineTypeDefsCDeclaration (C.CDecl spec items' ni))
    pure (C.CDeclExt decl')
chrg's avatar
chrg committed
  _r -> don'tHandle r
chrg's avatar
chrg committed

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

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

      let t = ctype ctx spec

      keep <- containsStructDeclaration spec

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

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

chrg's avatar
chrg committed
reduceCDeclarationItem
chrg's avatar
chrg committed
  :: (MonadReduce Lab m)
chrg's avatar
chrg committed
  => Bool
  -> CType
chrg's avatar
chrg committed
  -> C.CDeclarationItem C.NodeInfo
chrg's avatar
chrg committed
  -> m ([C.CDeclarationItem C.NodeInfo], Context)
  -> m ([C.CDeclarationItem C.NodeInfo], Context)
chrg's avatar
chrg committed
reduceCDeclarationItem shouldDelete t d ma = case d of
chrg's avatar
chrg committed
  C.CDeclarationItem
chrg's avatar
chrg committed
    dr@(C.CDeclr (Just i) [] Nothing [] ni)
    (Just (C.CInitExpr c ni'))
chrg's avatar
chrg committed
    Nothing -> do
chrg's avatar
chrg committed
      (ds, ctx) <- ma
      c' <- fromMaybe (pure zeroExpr) (reduceCExpr c ctx)
chrg's avatar
chrg committed
      if shouldDelete
        then pure (ds, addInlineExpr i (IEInline c') ctx)
        else
          split
            ("inline variable " <> C.identToString i, C.posOf ni)
            (pure (ds, addInlineExpr i (IEInline c') ctx))
            ( pure
                ( inlineTypeDefsCDI (C.CDeclarationItem dr (Just (C.CInitExpr c' ni')) Nothing) ctx
                    : ds
                , addInlineExpr i (IEKeep t) ctx
                )
chrg's avatar
chrg committed
            )
chrg's avatar
chrg committed
  C.CDeclarationItem (C.CDeclr (Just i) a Nothing b ni) ex Nothing -> do
chrg's avatar
chrg committed
    (ds, ctx) <- ma
chrg's avatar
chrg committed
    if shouldDelete
      then pure (ds, addInlineExpr i IEDelete ctx)
      else do
        ex' <- case ex of
          Just ix -> maybeSplit ("remove initializer", C.posOf ni) (reduceCInitializer ix ctx)
          Nothing -> pure Nothing

chrg's avatar
chrg committed
        let d' = C.CDeclarationItem (C.CDeclr (Just i) a Nothing b ni) ex' Nothing
chrg's avatar
chrg committed
        split
          ("remove variable " <> C.identToString i, C.posOf ni)
          (pure (ds, addInlineExpr i IEDelete ctx))
chrg's avatar
chrg committed
          (pure (inlineTypeDefsCDI d' ctx : ds, addInlineExpr i (IEKeep t) ctx))
chrg's avatar
chrg committed
  a@(C.CDeclarationItem (C.CDeclr _ _ _ _ ni) _ _) -> do
    don'tHandleWithNodeInfo a ni
chrg's avatar
chrg committed
  a -> don'tHandle a

chrg's avatar
chrg committed
reduceCInitializer
  :: (MonadReduce Lab m)
  => C.CInitializer C.NodeInfo
  -> Context
  -> Maybe (m (C.CInitializer C.NodeInfo))
reduceCInitializer a ctx = case a of
  C.CInitExpr e ni' -> do
    rm <- reduceCExpr e ctx
    Just $ (`C.CInitExpr` ni') <$> rm
  C.CInitList (C.CInitializerList items) ni -> do
    ritems <- forM items \case
      ([], it) -> fmap ([],) <$> reduceCInitializer it ctx
      (as, _) -> notSupportedYet (fmap noinfo as) ni
    Just $ (`C.CInitList` ni) . C.CInitializerList <$> sequence ritems

chrg's avatar
chrg committed
reduceCStatementOrEmptyBlock
chrg's avatar
chrg committed
  :: (MonadReduce Lab m, HasCallStack)
chrg's avatar
chrg committed
  => C.CStatement C.NodeInfo
chrg's avatar
chrg committed
  -> [C.Ident]
chrg's avatar
chrg committed
  -> Context
  -> m (C.CStatement C.NodeInfo)
chrg's avatar
chrg committed
reduceCStatementOrEmptyBlock stmt ids ctx = do
  fromMaybe emptyBlock <$> runMaybeT (reduceCStatement stmt ids ctx)
chrg's avatar
chrg committed

emptyBlock :: C.CStatement C.NodeInfo
emptyBlock = C.CCompound [] [] C.undefNode
chrg's avatar
chrg committed

chrg's avatar
chrg committed
-- | Reduce given a list of required labels reduce a c statement, possibly into nothingness.
chrg's avatar
chrg committed
reduceCStatement
chrg's avatar
chrg committed
  :: (MonadReduce Lab m, HasCallStack)
chrg's avatar
chrg committed
  => C.CStatement C.NodeInfo
chrg's avatar
chrg committed
  -> [C.Ident]
chrg's avatar
chrg committed
  -> Context
chrg's avatar
chrg committed
  -> 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
    case concat cbi' of
chrg's avatar
chrg committed
      [] -> do
        pure (C.CCompound is [] ni)
chrg's avatar
chrg committed
      ccbi -> pure (C.CCompound is ccbi ni)
chrg's avatar
chrg committed
  C.CWhile e s dow ni -> do
chrg's avatar
chrg committed
    s' <- reduceCStatement s labs ctx
    e' <- lift (reduceCExprOrZero e ctx)
    pure $ C.CWhile e' s' dow ni
chrg's avatar
chrg committed
  C.CExpr me ni -> do
    case me of
      Just e -> do
        if DoNoops `isIn` ctx
chrg's avatar
chrg committed
          then do
chrg's avatar
chrg committed
            e' <- maybeSplit ("change to noop", C.posOf smt) $ reduceCExpr e ctx
            pure $ C.CExpr e' ni
          else do
chrg's avatar
chrg committed
            re' <- liftMaybe $ reduceCExpr e ctx
            exceptIf ("remove expr statement", C.posOf smt)
            e' <- re'
            pure $ C.CExpr (Just e') ni
chrg's avatar
chrg committed
      Nothing -> do
        exceptIf ("remove expr statement", C.posOf smt)
chrg's avatar
chrg committed
        pure $ C.CExpr Nothing ni
chrg's avatar
chrg committed
  C.CReturn me ni -> do
    -- TODO: If function returntype is not struct return 0
chrg's avatar
chrg committed
    case me of
      Just e -> do
chrg's avatar
chrg committed
        re' <- liftMaybe $ reduceCExpr e ctx
        exceptIf ("remove return statement", C.posOf smt)
        e' <- re'
        pure $ C.CReturn (Just e') ni
      Nothing -> do
        exceptIf ("remove return statement", C.posOf smt)
        pure $ C.CReturn Nothing ni
  C.CIf e s els ni -> do
chrg's avatar
chrg committed
    e' <- maybeSplit ("remove condition", C.posOf e) $ reduceCExpr e ctx
chrg's avatar
chrg committed
    els' <- lift . runMaybeT $ do
      els' <- liftMaybe els
      reduceCStatement els' labs ctx
    ms' <- lift . runMaybeT $ reduceCStatement s labs ctx
chrg's avatar
chrg committed
    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'
chrg's avatar
chrg committed
  C.CFor e1 e2 e3 s ni -> do
chrg's avatar
chrg committed
    (me1', ctx') <- case e1 of
chrg's avatar
chrg committed
      C.CForDecl d@(C.CDecl spec decl ni') -> do
chrg's avatar
chrg committed
        (decl', ctx') <-
          foldr
chrg's avatar
chrg committed
            (reduceCDeclarationItem (shouldDeleteDeclaration ctx d) (ctype ctx spec))
chrg's avatar
chrg committed
            (pure ([], ctx))
            decl
chrg's avatar
chrg committed
        res <-
          if null decl'
            then
chrg's avatar
chrg committed
              if AllowEmptyDeclarations `isIn` ctx'
                then
                  split
                    ("remove empty declaration", C.posOf ni')
                    (pure Nothing)
chrg's avatar
chrg committed
                    (pure $ Just $ C.CForDecl (C.CDecl spec decl' ni'))
chrg's avatar
chrg committed
                else pure Nothing
chrg's avatar
chrg committed
            else pure $ Just $ C.CForDecl (C.CDecl spec decl' ni')
chrg's avatar
chrg committed
        pure (res, ctx')
chrg's avatar
chrg committed
      C.CForInitializing e -> do
        e' <- maybeSplit ("remove initializer", C.posOf ni) (e >>= \e' -> reduceCExpr e' ctx)
chrg's avatar
chrg committed
        split
chrg's avatar
chrg committed
          ("remove empty declaration", C.posOf ni)
          (pure (Nothing, ctx))
chrg's avatar
chrg committed
          (pure (Just $ C.CForInitializing e', ctx))
chrg's avatar
chrg committed
      d -> don'tHandle d

chrg's avatar
chrg committed
    s' <- reduceCStatementOrEmptyBlock s labs ctx'
chrg's avatar
chrg committed
    let forloop n = do
chrg's avatar
chrg committed
          e2' <- runMaybeT do
            e2' <- liftMaybe e2
            re2' <- liftMaybe (reduceCExpr e2' ctx')
            exceptIf ("remove check", C.posOf e2')
            re2'
          e3' <- runMaybeT do
            e3' <- liftMaybe e3
            re3' <- liftMaybe (reduceCExpr e3' ctx')
            exceptIf ("remove iterator", C.posOf e3')
            re3'
chrg's avatar
chrg committed
          let e2'' =
                if AllowInfiniteForLoops `isIn` ctx || isNothing e2
                  then e2'
                  else e2' <|> Just zeroExpr
          pure $ C.CFor n e2'' e3' s' ni

    case me1' of
      Nothing -> do
        split ("remove the for loop", C.posOf smt) (pure s') do
          forloop (C.CForInitializing Nothing)
chrg's avatar
chrg committed
      Just e1' -> do
chrg's avatar
chrg committed
        forloop e1'
chrg's avatar
chrg committed
  C.CLabel i s [] ni -> do
    if i `List.elem` labs
      then do
        s' <- lift $ reduceCStatementOrEmptyBlock s labs ctx
        pure $ C.CLabel i s' [] ni
      else do
        empty
  C.CGoto i ni ->
    if i `List.elem` labs
      then pure $ C.CGoto i ni
      else empty
  C.CBreak _ -> defaultBehavior
  C.CCont _ -> defaultBehavior
chrg's avatar
chrg committed
  a -> don'tHandleWithPos a
chrg's avatar
chrg committed
 where
  defaultBehavior =
    split ("remove statement", C.posOf smt) empty (pure smt)
chrg's avatar
chrg committed

chrg's avatar
chrg committed
-- | 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

chrg's avatar
chrg committed
zeroExpr :: C.CExpression C.NodeInfo
zeroExpr = C.CConst (C.CIntConst (C.cInteger 0) C.undefNode)

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

chrg's avatar
chrg committed
reduceCExpr :: forall m. (MonadReduce Lab m, HasCallStack) => C.CExpr -> Context -> Maybe (m C.CExpr)
chrg's avatar
chrg committed
reduceCExpr expr ctx = case expr of
  C.CBinary o elhs erhs ni -> do
chrg's avatar
chrg committed
    if o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]
      then do
        -- in this case we change type, so we need to keep the operation
        rl <- reduceCExpr elhs ctx
        rr <- reduceCExpr erhs ctx
        Just $ do
          l' <- rl
          r' <- rr
          pure $ C.CBinary o l' r' ni
      else do
        case reduceCExpr elhs ctx of
          Just elhs' -> case reduceCExpr erhs ctx of
            Just erhs' -> pure do
              split ("reduce to left", C.posOf elhs) elhs' do
                split ("reduce to right", C.posOf erhs) erhs' do
                  l' <- elhs'
                  r' <- erhs'
                  pure $ C.CBinary o l' r' ni
            Nothing ->
              pure elhs'
          Nothing
            | otherwise -> fail "could not reduce left hand side"
chrg's avatar
chrg committed
  C.CAssign o elhs erhs ni ->
    case reduceCExpr elhs (addKeyword DisallowVariableInlining ctx) of
      Just elhs' -> case reduceCExpr erhs ctx of
        Just erhs' -> pure do
          split ("reduce to left", C.posOf elhs) elhs' do
            split ("reduce to right", C.posOf erhs) erhs' do
              l' <- elhs'
              r' <- erhs'
              pure $ C.CAssign o l' r' ni
        Nothing ->
          fail "could not reduce right hand side"
      Nothing
        | otherwise -> fail "could not reduce left hand side"
  C.CVar i _ ->
    case Map.lookup i . inlineExprs $ ctx of
      Just mx -> case mx of
chrg's avatar
chrg committed
        IEKeep _ -> Just (pure expr)
chrg's avatar
chrg committed
        IEInline mx'
chrg's avatar
chrg committed
          | DisallowVariableInlining `isIn` ctx -> Nothing
chrg's avatar
chrg committed
          | otherwise -> Just (pure mx')
chrg's avatar
chrg committed
        IEDelete ->
chrg's avatar
chrg committed
          Nothing
chrg's avatar
chrg committed
      Nothing -> error ("Could not find " <> show (C.identToString i) <> " at " <> show (C.posOf expr) <> "\n" <> show (inlineExprs ctx))
chrg's avatar
chrg committed
  C.CConst x -> Just do
    pure $ C.CConst x
  C.CUnary o elhs ni -> do
    elhs' <- reduceCExpr elhs (addKeyword DisallowVariableInlining ctx)
    Just $ split ("reduce to operant", C.posOf expr) elhs' do
      e <- elhs'
      pure $ C.CUnary o e ni
  C.CCall e es ni -> do
chrg's avatar
chrg committed
    case e of
chrg's avatar
chrg committed
      (C.CVar i _) -> case functions ctx Map.!? i of
        Just Nothing -> Nothing
        -- TODO improve
        -- Just $ do
        -- es' <- traverse (maybeSplit ("do without param", C.posOf e) . (`reduceCExpr` ctx)) es
        -- -- Not completely correct.
        -- case catMaybes es' of
        --   [] -> pure zeroExpr
        --   [e''] -> pure e''
        --   es'' -> pure $ C.CComma es'' C.undefNode
        Just (Just fun) -> do
          let f a ae' =
                a <&> \tt -> case reduceCExpr ae' ctx of
                  Just re ->
                    Just $
                      whenSplit
                        (tt /= CTStruct)
                        ("do without param", C.posOf ae')
                        (pure zeroExpr)
                        re
                  Nothing
                    | tt /= CTStruct -> Just (pure zeroExpr)
                    | otherwise -> Nothing
          rargs' <- sequence . catMaybes $ zipWith f (fromMaybe [] $ funParams fun) es
chrg's avatar
chrg committed
          Just $ do
            es' <- sequence rargs'
            pure $ C.CCall e es' ni
chrg's avatar
chrg committed
        -- Just (IEKeep CTAny) -> do
        --   let re = reduceCExpr e (addKeyword DisallowVariableInlining ctx)
        --       res = map (`reduceCExpr` ctx) es
        --   case (re, catMaybes res) of
        --     (Nothing, []) -> Nothing
        --     (Nothing, [r]) -> Just r
        --     (_, _) -> Just do
        --       e' <- maybeSplit ("do without function", C.posOf e) re
        --       es' <- res & traverse (maybeSplit ("do without pram", C.posOf e))
        --       case (e', catMaybes es') of
        --         (Nothing, []) -> pure zeroExpr
        --         (Nothing, [e'']) -> pure e''
        --         (Nothing, es'') -> pure $ C.CComma es'' C.undefNode
        --         (Just f, _) -> pure $ C.CCall f (map (fromMaybe zeroExpr) es') ni
        -- Just (IEKeep t) -> error ("unexpected type" <> show i <> show t)
        -- Just (IEInline x) -> error ("unexpected inline" <> show x)
chrg's avatar
chrg committed
        Nothing -> error ("could not find " <> show i)
      _ow -> notSupportedYet e ni
  -- do
  --   let re = reduceCExpr e (addKeyword DisallowVariableInlining ctx)
  --       res = map (`reduceCExpr` ctx) es
  --   case (re, catMaybes res) of
  --     (Nothing, []) -> Nothing
  --     (Nothing, [r]) -> Just r
  --     (_, _) -> Just do
  --       e' <- maybeSplit ("do without function", C.posOf e) re
  --       es' <- res & traverse (maybeSplit ("do without pram", C.posOf e))
  --       case (e', catMaybes es') of
  --         (Nothing, []) -> pure zeroExpr
  --         (Nothing, [e'']) -> pure e''
  --         (Nothing, es'') -> pure $ C.CComma es'' C.undefNode
  --         (Just f, _) -> pure $ C.CCall f (map (fromMaybe zeroExpr) es') ni
chrg's avatar
chrg committed
  C.CCond ec et ef ni -> do
    -- TODO: More fine grained reduction is possible here.
    Just $ do
      ec' <- reduceCExprOrZero ec ctx
      ef' <- reduceCExprOrZero ef ctx
      et' <- case et of
        Just et' -> Just <$> reduceCExprOrZero et' ctx
        Nothing -> pure Nothing
      pure $ C.CCond ec' et' ef' ni
  C.CCast decl e ni -> do
    re <- reduceCExpr e ctx
    Just do
      split ("don't cast", C.posOf ni) re do
        e' <- re
chrg's avatar
chrg committed
        pure (C.CCast (inlineTypeDefsCDeclaration decl ctx) e' ni)
chrg's avatar
chrg committed
  C.CIndex e1 e2 ni -> do
    -- TODO: Better reduction is posisble here.
    re1 <- reduceCExpr e1 ctx
    Just do
      e1' <- re1
      e2' <- reduceCExprOrZero e2 ctx
      pure $ C.CIndex e1' e2' ni
chrg's avatar
chrg committed
  C.CComma items ni -> do
chrg's avatar
chrg committed
    let Just (x, rst) = List.uncons (reverse items)
chrg's avatar
chrg committed
    rx <- reduceCExpr x ctx
    Just do
      rst' <-
        foldr
          ( \e cc -> do
              maybeSplit ("remove expression", C.posOf e) (reduceCExpr e ctx) >>= \case
                Just e' -> (e' :) <$> cc
                Nothing -> cc
          )
          (pure [])
          rst
      x' <- rx
      if List.null rst'
        then pure x'
        else pure $ C.CComma (reverse (x' : rst')) ni
  C.CMember e i l ni -> do
    re <- reduceCExpr e ctx
    Just do
      e' <- re
      pure (C.CMember e' i l ni)
chrg's avatar
chrg committed
  a -> don'tHandleWithPos a

chrg's avatar
chrg committed
inlineTypeDefsCDeclaration :: C.CDeclaration C.NodeInfo -> Context -> C.CDeclaration C.NodeInfo
inlineTypeDefsCDeclaration decl ctx =
  case decl of
    C.CDecl items decli ni ->
      C.CDecl (inlineTypeDefsSpecs items ctx) (map (`inlineTypeDefsCDI` ctx) decli) ni
    a -> don'tHandle a
chrg's avatar
chrg committed

chrg's avatar
chrg committed
-- shouldDeleteFunction :: Context -> C.CFunctionDef C.NodeInfo -> Bool
-- shouldDeleteFunction ctx (C.CFunDef spec _ _ _ _) =
--   any (shouldDeleteDeclSpec ctx) spec
chrg's avatar
chrg committed

chrg's avatar
chrg committed
shouldDeleteDeclaration :: Context -> C.CDeclaration C.NodeInfo -> Bool
shouldDeleteDeclaration ctx decl =
  case decl of
chrg's avatar
chrg committed
    C.CDecl items decli _ -> any (shouldDeleteDeclSpec ctx) items || any shouldDeleteDeclItem decli
chrg's avatar
chrg committed
    a -> don'tHandle a
 where
  shouldDeleteDeclItem = \case
    C.CDeclarationItem a _ _ -> shouldDeleteDeclartor a
    a -> don'tHandle a

  shouldDeleteDeclartor = \case
    C.CDeclr _ def _ _ _ -> any shouldDeleteDerivedDeclartor def

  shouldDeleteDerivedDeclartor = \case
    C.CFunDeclr (C.CFunParamsNew x _) _ _ ->
      any (shouldDeleteDeclaration ctx) x
    C.CArrDeclr{} -> False
    C.CPtrDeclr _ _ -> False
    a -> don'tHandle a

chrg's avatar
chrg committed
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
chrg's avatar
chrg committed
      Just (Just _) -> False
      Just Nothing -> True
chrg's avatar
chrg committed
      Nothing -> error ("could not find struct:" <> show idx)
  C.CTypeSpec (C.CSUType (C.CStruct _ _ (Just c) _ _) _) ->
    any (shouldDeleteDeclaration ctx) c
  _ow -> False
chrg's avatar
chrg committed

chrg's avatar
chrg committed
inlineTypeDefsSpecs :: [C.CDeclarationSpecifier C.NodeInfo] -> Context -> [C.CDeclarationSpecifier C.NodeInfo]
inlineTypeDefsSpecs r ctx =
  r & concatMap \case
    a@(C.CTypeSpec (C.CTypeDef idx _)) -> do
      case Map.lookup idx . typeDefs $ ctx of
chrg's avatar
chrg committed
        Just (_, ITKeep) -> [a]
        Just (_, ITInline res) -> res
chrg's avatar
chrg committed
        Nothing -> error ("could not find typedef:" <> show idx)
chrg's avatar
chrg committed
    -- a@(C.CTypeSpec (C.CSUType (C.CStruct _ (Just idx) Nothing _ _) _)) ->
    --   case Map.lookup idx . structs $ ctx of
    --     Just (Just def) -> [C.CTypeSpec (C.CSUType def C.undefNode)]
    --     Just Nothing -> [a]
    --     Nothing -> error ("could not find struct:" <> show idx)
    C.CTypeSpec (C.CSUType (C.CStruct a b (Just c) d e) f) ->
      [C.CTypeSpec (C.CSUType (C.CStruct a b (Just $ map (`inlineTypeDefsCDeclaration` ctx) c) d e) f)]
chrg's avatar
chrg committed
    a -> [a]
{-# NOINLINE inlineTypeDefsSpecs #-}

inlineTypeDefsCDeclarator
  :: C.CDeclarator C.NodeInfo
  -> Context
  -> C.CDeclarator C.NodeInfo
inlineTypeDefsCDeclarator (C.CDeclr idn derivedd st atr ni) ctx =
chrg's avatar
chrg committed
  C.CDeclr idn (map (inlineTypeDefsX ctx) derivedd) st atr ni

inlineTypeDefsX :: Context -> C.CDerivedDeclarator C.NodeInfo -> C.CDerivedDeclarator C.NodeInfo
inlineTypeDefsX ctx = \case
  C.CFunDeclr (C.CFunParamsNew x y) b c ->
    C.CFunDeclr (C.CFunParamsNew (map (`inlineTypeDefsCDeclaration` ctx) x) y) b c
  C.CArrDeclr a b c -> C.CArrDeclr a b c
  C.CPtrDeclr a b -> C.CPtrDeclr a b
  a -> don'tHandle a
chrg's avatar
chrg committed
inlineTypeDefsCDI :: C.CDeclarationItem C.NodeInfo -> Context -> C.CDeclarationItem C.NodeInfo
inlineTypeDefsCDI di ctx = case di of
  C.CDeclarationItem a b ni -> C.CDeclarationItem (inlineTypeDefsCDeclarator a ctx) b ni
  a -> don'tHandle a

chrg's avatar
chrg committed
identifiers :: forall a. (Data a) => a -> [C.Ident]
chrg's avatar
chrg committed
identifiers d = appEndo (go d) []
 where
  go :: forall a'. (Data a') => a' -> Endo [C.Ident]
  go d' = case cast d' of
    Just l -> Endo (l :)
    Nothing -> gmapQl (<>) mempty go d'
chrg's avatar
chrg committed
-- functionName :: C.CFunctionDef C.NodeInfo -> Maybe C.Ident
-- functionName = \case
--   C.CFunDef _ (C.CDeclr ix _ _ _ _) _ _ _ -> ix
chrg's avatar
chrg committed
notSupportedYet :: (HasCallStack, Show a, C.Pos n) => a -> n -> b
chrg's avatar
chrg committed
notSupportedYet a ni = error (show a <> " at " <> show (C.posOf ni))

noinfo :: (Functor f) => f C.NodeInfo -> f ()
noinfo a = a $> ()

chrg's avatar
chrg committed
don'tHandle :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> b
don'tHandle f = error (show (f $> ()))

chrg's avatar
chrg committed
don'tHandleWithPos :: (HasCallStack, Functor f, Show (f ()), C.Pos (f C.NodeInfo)) => f C.NodeInfo -> b
don'tHandleWithPos f = error (show (f $> ()) <> " at " <> show (C.posOf f))

don'tHandleWithNodeInfo :: (HasCallStack, Functor f, Show (f ())) => f C.NodeInfo -> C.NodeInfo -> b
don'tHandleWithNodeInfo f ni = error (show (f $> ()) <> " at " <> show (C.posOf ni))
chrg's avatar
chrg committed

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

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

labelsOf :: C.CStatement C.NodeInfo -> [C.Ident]
labelsOf = \case
  C.CLabel i s [] _ -> i : labelsOf s
  C.CWhile _ s _ _ -> labelsOf s
  C.CCase _ s _ -> labelsOf s
  C.CDefault s _ -> labelsOf s
  C.CCompound _ ss _ ->
    ss & concatMap \case
      C.CBlockStmt s -> labelsOf s
      _ow -> []
  C.CCases _ _ s _ -> labelsOf s
  C.CIf _ l r _ -> labelsOf l <> maybe [] labelsOf r
  C.CSwitch _ s _ -> labelsOf s
  C.CFor _ _ _ s _ -> labelsOf s
  _ow -> []

ctype :: (HasCallStack) => Context -> [C.CDeclarationSpecifier C.NodeInfo] -> CType
ctype ctx xs =
  let ts = mapMaybe f xs
   in fromJust $
        foldr
          ( \t t' -> case t' of
              Nothing -> Just t
              Just t''
                | t == t'' -> Just t''
                | otherwise -> error ("something is broken in the c-file" <> show ts)
          )
          Nothing
          ts
 where
  f = \case
    (C.CTypeSpec tp) -> Just $ case tp of
      C.CVoidType _ -> CTAny
      C.CCharType _ -> CTNum
      C.CShortType _ -> CTNum
      C.CIntType _ -> CTNum
      C.CFloatType _ -> CTNum
      C.CDoubleType _ -> CTNum
      C.CSignedType _ -> CTNum
      C.CUnsigType _ -> CTNum
      C.CBoolType _ -> CTNum
      C.CLongType _ -> CTNum
      C.CInt128Type _ -> CTNum
      C.CFloatNType{} -> CTNum
      C.CSUType _ _ -> CTStruct
      C.CEnumType _ _ -> CTNum
      C.CTypeDef idx _ ->
        case Map.lookup idx . typeDefs $ ctx of
          Just (t, ITKeep) -> t
          Just (t, ITInline _) -> t
          Nothing -> error ("could not find typedef: " <> show (C.identToString idx))
      a -> notSupportedYet a C.undefNode
    _ow -> Nothing
chrg's avatar
chrg committed

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

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

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

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

type Lab = (String, C.Position)

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

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

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

addTypeDefs :: [C.Ident] -> (CType, InlineType) -> Context -> Context
addTypeDefs ids cs Context{..} =
  Context
    { typeDefs =
        foldl' (\a i -> Map.insert i cs a) typeDefs ids
    , ..
    }

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

addKeyword :: Keyword -> Context -> Context
addKeyword k Context{..} =
  Context
    { keywords = Set.insert k keywords
    , ..
    }

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

isIn :: Keyword -> Context -> Bool
isIn k = Set.member k . keywords

prettyIdent :: C.Identifier C.NodeInfo -> [Char]
prettyIdent (C.Ident s _ a) = s ++ " at " ++ show (C.posOfNode a)

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

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

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

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

  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 [Maybe CType])
  , funReturns :: !(Maybe CType)
  , funIsStatic :: !Bool
  , funSize :: !Int
  , funPosition :: !C.Position
  }
  deriving (Show, Eq)

findFunctions
  :: (Monoid m)
  => (Function -> m)
  -> Context
  -> C.CExternalDeclaration C.NodeInfo
  -> m
findFunctions inject ctx = \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 (functionParameters -> Just (params, change)) Nothing [] _) -> case mid of
      Just funName -> inject Function{..}
       where
        funParams = params <&> fmap (Just . snd) . concatMap (declarations ctx)
        funReturns = change $ case ctype ctx spec of
          CTAny -> Nothing
          t -> Just t
        funIsStatic = any (\case (C.CStorageSpec (C.CStatic _)) -> True; _ow -> False) spec
        funSize = fromMaybe 0 (C.lengthOfNode ni)
        funPosition = C.posOf ni
      Nothing -> mempty
    _ow -> mempty

  -- \| Returns nothing if void is used
  functionParameters
    :: [C.CDerivedDeclarator C.NodeInfo]
    -> Maybe (Maybe [C.CDeclaration C.NodeInfo], Maybe CType -> Maybe CType)
  functionParameters = \case
    (C.CFunDeclr (C.CFunParamsNew x _) _ _) : rst ->
      case x of
        [C.CDecl [C.CTypeSpec (C.CVoidType _)] _ _] ->
          Just (Nothing, applyDerivedDeclarators rst)
        params -> Just (Just params, applyDerivedDeclarators rst)
    _ow -> Nothing

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

declarations :: Context -> C.CDeclaration C.NodeInfo -> [(Maybe C.Ident, CType)]
declarations ctx = \case
  C.CDecl spec items _ -> let t = ctype ctx spec in map (\i -> (name i, t)) items
  a@(C.CStaticAssert _ _ n) -> notSupportedYet a n

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

includeTypeDef :: (Monad m) => C.CExternalDeclaration C.NodeInfo -> StateT Context m ()
includeTypeDef = \case
  C.CDeclExt (C.CDecl (C.CStorageSpec (C.CTypedef _) : rst) decl _) -> do
    let [ids] = identifiers decl
    modify (\ctx -> addTypeDefs [ids] (ctype ctx rst, ITInline rst) ctx)
  _ow -> pure ()

containsStructDeclaration
  :: (MonadPlus m, MonadState Context m)
  => [C.CDeclarationSpecifier C.NodeInfo]
  -> m Bool
containsStructDeclaration spec =
  or <$> forM spec \case
    -- Is a struct definition
    C.CTypeSpec (C.CSUType (C.CStruct _ mid def _ _) _) -> case mid of
      Just sid -> do
        -- Delete if struct is deleted.
        ctx <- get
        _ <- liftMaybe (lookupStruct ctx sid)
        case def of
          Just _ -> pure True
          Nothing -> pure False
      Nothing -> pure False
    _ow -> pure False

filterParams
  :: Context
  -> [Maybe CType]
  -> [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
      (items', defs) <- flip mapAndUnzipM items \case
        a'@(C.CDeclarationItem (C.CDeclr idx _ _ _ _) _ _) -> do
          t' <- state (\(t : tps) -> (t, tps))
          pure $ case t' of
            Just t
              | not (shouldDeleteDeclaration ctx decl) ->
                  ([a'], [(idx', IEKeep t) | idx' <- maybeToList idx])
            _ow ->
              ([], [(idx', IEDelete) | idx' <- maybeToList idx])
        a' -> notSupportedYet a' l
      case concat items' of
        [] -> pure ([], concat defs)
        items'' -> pure ([C.CDecl def items'' l], concat defs)
    a' -> don'tHandleWithPos a'
  pure (concat params', concat mapping)