ReduceC.hs

data Struct = Struct
  { structName :: !C.Ident
  , structType :: !StructType
  , 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 (structField ctx) fields
    sid <- mid
    pure $ inject (Struct sid (StructType tag mid fields') (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' 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
  , funType :: !FunType
  , 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
    decl@(C.CDeclr mid _ Nothing [] _) ->
      case nonVoidTypeOfFromContext ctx spec decl of
        TFun funType -> case mid of
          Just funName -> inject Function{..}
           where
            funIsStatic = isStaticFromSpecs spec
            funSize = fromMaybe 0 (C.lengthOfNode ni)
            funPosition = C.posOf ni
          Nothing -> mempty
        _ow -> 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

baseTypeOfFromContext
  :: (HasCallStack) => Context -> [C.CDeclarationSpecifier C.NodeInfo] -> Voidable
baseTypeOfFromContext ctx spec =
  baseTypeOf
    (\t -> fst <$> Map.lookup t (structs ctx))
    (\t -> fst <$> Map.lookup t (typeDefs ctx))
    spec

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) items _) -> do
    let [C.CDeclarationItem decl _ _] = items
    modify'
      ( \ctx ->
          addTypeDef
            (fromMaybe (error "expected typedef to have a name") $ name decl)
            (nonVoidTypeOfFromContext ctx rst decl, ITInline rst)
            ctx
      )
  _ow -> pure ()

containsStructDeclaration
  :: Context
  -> [C.CDeclarationSpecifier C.NodeInfo]
  -> Bool
containsStructDeclaration ctx =
  any \case
    -- Is a struct definition
    C.CTypeSpec (C.CSUType (C.CStruct _ mid (Just _) _ _) _) -> case mid of
      Just sid -> do
        -- Delete if struct is deleted.
        case lookupStruct ctx sid of
          Just _ -> True
          Nothing -> False
      Nothing -> False
    _ow -> False

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