CType.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}

-- | A module for typing of c expressions.
module CType where

import Control.Monad
import qualified Data.List as List
import qualified Data.List.NonEmpty as NonEmpty
import Data.Maybe
import GHC.Stack
import qualified Language.C as C

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 !StructType
  | TPointer !Voidable
  | TFun !FunType
  deriving (Show, Eq)

isNum, isStruct, isPointer, isFun :: Type -> Bool
isNum = \case TNum -> True; _ow -> False
isStruct = \case TStruct _ -> True; _ow -> False
isPointer = \case TPointer _ -> True; _ow -> False
isFun = \case TFun _ -> True; _ow -> False

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

type TypeDefLookup = (C.Ident -> Maybe Type)
type StructLookup = (C.Ident -> Maybe StructType)

typeOf
  :: (HasCallStack)
  => StructLookup
  -> TypeDefLookup
  -> [C.CDeclarationSpecifier C.NodeInfo]
  -> C.CDeclarator C.NodeInfo
  -> Voidable
typeOf structLookup typeDefLookup spec (C.CDeclr _ dd _ _ _) =
  foldr applyDD (baseTypeOf structLookup typeDefLookup spec) dd
 where
  applyDD :: C.CDerivedDeclarator C.NodeInfo -> Voidable -> Voidable
  applyDD = \case
    C.CPtrDeclr _ _ -> NonVoid . TPointer
    C.CArrDeclr{} -> NonVoid . TPointer
    C.CFunDeclr params _ ni -> \c ->
      case params of
        C.CFunParamsNew params' varadic -> do
          NonVoid $ TFun (FunType c (findParams varadic params'))
        b -> notSupportedYet b ni

  findParams :: Bool -> [C.CDeclaration C.NodeInfo] -> Params
  findParams varadic = \case
    [C.CDecl [C.CTypeSpec (C.CVoidType _)] [] _] -> VoidParams
    rst -> flip Params varadic $ flip map rst \case
      C.CDecl spec' [] _ ->
        Just . nonVoid $ baseTypeOf structLookup typeDefLookup spec'
      C.CDecl spec' [C.CDeclarationItem decl _ _] _ ->
        Just . nonVoid $ typeOf structLookup typeDefLookup spec' decl
      a -> notSupportedYet' a

typeSpecs :: [C.CDeclarationSpecifier a] -> [C.CTypeSpecifier a]
typeSpecs = mapMaybe \case
  C.CTypeSpec ts -> Just ts
  _ow -> Nothing

baseTypeOf
  :: (HasCallStack)
  => StructLookup
  -> TypeDefLookup
  -> [C.CDeclarationSpecifier C.NodeInfo]
  -> Voidable
baseTypeOf structLookup typeDefLookup =
  maybe
    (error "no type in type-specs")
    ( \case
        (t, []) -> NonEmpty.head t
        (t, rs) -> error ("more than one type in type-specs: " <> show (t : rs))
    )
    . List.uncons
    . NonEmpty.group
    . map \case
      C.CVoidType _ -> Void
      C.CCharType _ -> NonVoid TNum
      C.CShortType _ -> NonVoid TNum
      C.CIntType _ -> NonVoid TNum
      C.CFloatType _ -> NonVoid TNum
      C.CDoubleType _ -> NonVoid TNum
      C.CSignedType _ -> NonVoid TNum
      C.CUnsigType _ -> NonVoid TNum
      C.CBoolType _ -> NonVoid TNum
      C.CLongType _ -> NonVoid TNum
      C.CInt128Type _ -> NonVoid TNum
      C.CFloatNType{} -> NonVoid TNum
      C.CSUType c _ -> NonVoid (TStruct $ structTypeOf structLookup typeDefLookup c)
      C.CEnumType _ _ -> NonVoid TNum
      C.CTypeDef idx _ ->
        case typeDefLookup idx of
          Just t -> NonVoid t
          Nothing -> error ("could not find typedef: " <> show (C.identToString idx))
      a -> notSupportedYet (void a) a
    . typeSpecs

structTypeOf
  :: (HasCallStack)
  => StructLookup
  -> TypeDefLookup
  -> C.CStructureUnion C.NodeInfo
  -> StructType
structTypeOf structLookup typeDefLookup (C.CStruct t mi md _ _) =
  case mi of
    Just ix ->
      case md of
        Just p -> do
          let p' = concatMap (namesAndTypeOf structLookup typeDefLookup) p
          case structLookup ix of
            Just s
              | structTypeFields s == p' -> s
              | otherwise -> error "what?"
            Nothing ->
              StructType
                { structTypeTag = t
                , structTypeName = mi
                , structTypeFields = p'
                }
        Nothing ->
          case structLookup ix of
            Just s -> s
            Nothing -> error "what!?"
    Nothing -> do
      let p' = maybe (error "what??") (concatMap (namesAndTypeOf structLookup typeDefLookup)) md
      StructType
        { structTypeTag = t
        , structTypeName = mi
        , structTypeFields = p'
        }

namesAndTypeOf
  :: (HasCallStack)
  => StructLookup
  -> TypeDefLookup
  -> C.CDeclaration C.NodeInfo
  -> [(C.Ident, Maybe Type)]
namesAndTypeOf structLookup typeDefLookup = \case
  C.CDecl spec items ni ->
    flip map items \case
      C.CDeclarationItem decl@(C.CDeclr (Just ix) _ _ _ _) _ _ ->
        (ix, Just . nonVoid $ typeOf structLookup typeDefLookup spec decl)
      a -> notSupportedYet (void a) ni
  a -> notSupportedYet' a

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