ReduceC.hs

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

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

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

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

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

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

reduceCExpr ::
  forall m.
  (MonadReduce Lab m, HasCallStack) =>
  C.CExpr ->
  EType ->
  Context ->
  Maybe (m C.CExpr)
reduceCExpr expr t ctx = case expr of
  C.CBinary o elhs erhs ni -> do
    msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
      msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
        checkNotAssignable t
        when (o `elem` [C.CNeqOp, C.CEqOp, C.CGeqOp, C.CLeqOp, C.CGrOp, C.CLeOp]) do
          checkExpectedType ctx (NonVoid TNum) t
        c <- inferType ctx elhs
        let t' = fromVoid etAny exactly c
        rl <- reduceCExpr elhs t' ctx
        rr <- reduceCExpr erhs t' ctx
        Just do
          l' <- rl
          r' <- rr
          let r'' = case o of
                C.CDivOp -> case r' of
                  C.CConst (C.CIntConst i _)
                    | i == C.cInteger 0 ->
                        C.CConst (C.CIntConst (C.cInteger 1) C.undefNode)
                  C.CUnary o' (C.CConst (C.CIntConst i _)) _
                    | i == C.cInteger 0 ->
                        C.CUnary o' (C.CConst (C.CIntConst (C.cInteger 1) C.undefNode)) C.undefNode
                  _ow -> r'
                _ow -> r'
          pure $ C.CBinary o l' r'' ni
  C.CAssign o elhs erhs ni ->
    msplit ("reduce to left", C.posOf elhs) (reduceCExpr elhs t ctx) do
      msplit ("reduce to right", C.posOf erhs) (reduceCExpr erhs t ctx) do
        c <- inferType ctx elhs
        checkExpectedType ctx c t
        let t' = fromVoid etAny exactly c
        -- in this case we change type, so we need to keep the operation
        rl <- reduceCExpr elhs t'{etAssignable = True} ctx
        rr <- reduceCExpr erhs t' ctx
        Just do
          l' <- rl
          r' <- rr
          pure $ C.CAssign o l' r' ni
  C.CVar i _ ->
    case lookupVariable ctx i of
      IEKeep c -> do
        checkExpectedType ctx (NonVoid c) t
        Just (pure expr)
      IEInline mx' -> do
        guard (not $ DisallowVariableInlining `isIn` ctx)
        reduceCExpr mx' t ctx
      IEDelete ->
        Nothing
  C.CConst x -> do
    case x of
      C.CStrConst _ _ -> do
        checkNotAssignable t
        checkExpectedType ctx (NonVoid (TPointer (NonVoid TNum))) t
        -- guard ( `match` etSet t)
        Just (pure expr)
      C.CIntConst (C.getCInteger -> 0) _ -> do
        checkNotAssignable t
        checkExpectedType ctx (NonVoid (TPointer Void)) t
          <|> checkExpectedType ctx (NonVoid TNum) t
        Just (pure expr)
      _ow -> do
        checkNotAssignable t
        checkExpectedType ctx (NonVoid TNum) t
        Just (pure expr)
  C.CUnary o eopr ni -> do
    msplit ("reduce to operant", C.posOf eopr) (reduceCExpr eopr t ctx) do
      case o of
        C.CIndOp -> do
          ropr <-
            if etSet t == ETAny
              then do
                reduceCExpr eopr t ctx
              else reduceCExpr eopr (t{etSet = ETPointer (etSet t), etAssignable = True}) ctx
          Just do
            eopr' <- ropr
            pure $ C.CUnary o eopr' ni
        C.CAdrOp -> do
          t' <- etUnPointer t
          ropr <- reduceCExpr eopr (t'{etAssignable = True}) ctx
          Just do
            eopr' <- ropr
            pure $ C.CUnary o eopr' ni
        e
          | e `List.elem` [C.CPreIncOp, C.CPreDecOp, C.CPostIncOp, C.CPostDecOp] -> do
              reduceCExpr eopr t{etAssignable = True} ctx <&> \ropr -> do
                eopr' <- ropr
                pure $ C.CUnary o eopr' ni
          | otherwise -> do
              reduceCExpr eopr t ctx <&> \ropr -> do
                eopr' <- ropr
                pure $ C.CUnary o eopr' ni
  C.CCall ef args ni -> do
    (\fn a -> foldr fn a args)
      (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx))
      do
        ct <- inferType ctx ef
        case ct of
          NonVoid ft@(TFun (FunType rt fargs)) -> do
            checkNotAssignable t
            checkExpectedType ctx rt t
            ref <- reduceCExpr ef (exactly ft) ctx
            let targs = case fargs of
                  Params targs' v ->
                    let cons = if v then repeat (Just ETAny) else []
                     in map (fmap ETExactly) targs' <> cons
                  VoidParams -> repeat (Just ETAny)
            let pargs = mapMaybe (\(ta, a) -> (,a) <$> ta) (zip targs args)
            rargs <- forM pargs \(ta, a) ->
              reduceCExpr a (EType ta False) ctx
            Just do
              ef' <- ref
              args' <- sequence rargs
              pure $ C.CCall ef' args' ni
          ow -> do
            error $
              "Original c code does not type-check: exepected function, got "
                <> show ow
                <> " at "
                <> show (C.posOf ef)
  C.CCond et (Just ec) ef ni -> do
    msplit ("reduce to true branch", C.posOf et) (reduceCExpr et t ctx) do
      msplit ("reduce to false branch", C.posOf ef) (reduceCExpr ef t ctx) do
        msplit ("reduce to condtion", C.posOf ef) (reduceCExpr ec t ctx) do
          checkNotAssignable t
          ret <- reduceCExpr et t ctx
          ref <- reduceCExpr ef t ctx
          rec <- reduceCExpr ec etAny ctx
          Just $ do
            et' <- ret
            ef' <- ref
            ec' <- rec
            pure $ C.CCond et' (Just ec') ef' ni
  C.CCast (C.CDecl spec items ni2) e ni -> do
    msplit ("do not cast", C.posOf ni) (reduceCExpr e t ctx) do
      (bt, spec') <- evalStateT (updateCDeclarationSpecifiers keepAll spec) ctx
      (items', re) <- case items of
        [C.CDeclarationItem (C.CDeclr Nothing dd Nothing [] a) b c] -> do
          (_, dd') <- evalStateT (updateCDerivedDeclarators bt (repeat True) dd) ctx
          ([C.CDeclarationItem (C.CDeclr Nothing dd' Nothing [] a) b c],) <$> do
            reduceCExpr e etAny ctx
        [] ->
          ([],) <$> case bt of
            Void ->
              reduceCExpr e etAny ctx
            NonVoid _ -> do
              -- checkExpectedType ct' t
              reduceCExpr e etAny ctx
        a -> notSupportedYet a ni
      Just do
        e' <- re
        pure (C.CCast (C.CDecl spec' items' ni2) e' ni)
  C.CIndex e1 e2 ni -> do
    msplit ("reduce to indexee", C.posOf e1) (reduceCExpr e1 t ctx) do
      msplit ("reduce to index", C.posOf e2) (reduceCExpr e2 t ctx) do
        re1 <- reduceCExpr e1 t{etSet = ETIndexable (etSet t), etAssignable = True} ctx
        Just do
          e1' <- re1
          e2' <- fromMaybe (pure zeroExpr) $ reduceCExpr e2 etNum ctx
          pure $ C.CIndex e1' e2' ni
  C.CComma items ni -> do
    (x, rst) <- List.uncons (reverse items)
    (\fn a -> foldr fn a (reverse items))
      (\e -> msplit ("reduce to expression", C.posOf e) (reduceCExpr e t ctx))
      do
        rx <- reduceCExpr x t ctx
        Just do
          rst' <- flip collect rst \e -> do
            re <- liftMaybe (reduceCExpr e (EType ETAny False) ctx)
            e' <- re
            exceptIf ("remove expression", C.posOf e)
            pure (e' :: C.CExpr)
          x' <- rx
          pure $ C.CComma (reverse (x' : rst')) ni
  C.CMember e i l ni -> do
    re <- reduceCExpr e t{etSet = ETStructWithField i (etSet t)} ctx
    Just do
      e' <- re
      pure (C.CMember e' i l ni)
  a -> notSupportedYet' a

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

lookupVariable :: (HasCallStack) => Context -> C.Ident -> InlineExpr
lookupVariable ctx k =
  fromMaybe (error ("could not find variable " <> C.identToString k)) $
    inlineExprs ctx Map.!? k

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

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

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

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

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

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

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

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

type Lab = (String, C.Position)

addTypeDef :: C.Ident -> InlineType -> Context -> Context
addTypeDef i cs ctx = ctx{typeDefs = Map.insert i cs $ typeDefs ctx}

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

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

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

defaultContext :: Context
defaultContext =
  Context
    { keywords = Set.fromList []
    , typeDefs = Map.fromList [(C.builtinIdent "__builtin_va_list", ITKeep (NonVoid (TPointer Void)))]
    , inlineExprs =
        Map.fromList
          [ (C.builtinIdent "__PRETTY_FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
          , (C.builtinIdent "__FUNCTION__", IEKeep (TPointer (NonVoid TNum)))
          ]
    , structs = Map.empty
    , enums = Map.empty
    , functions = Map.empty
    , returnType = Void
    }

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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