{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE Strict     #-}
-- | The types of expressions, and the names the program knows fields and
-- functions by.
module Tokstyle.C.Analysis.Types
    ( FieldKey
    , exprType
    , structTag
    , fieldKey
    , funType
    , funKey
    ) where

import           Language.C.Analysis.AstAnalysis (ExprSide (..), tExpr)
import           Language.C.Analysis.SemRep      (CompTyKind (..),
                                                  CompTypeRef (..), FunType,
                                                  Linkage (..), Storage (..),
                                                  Type (..), TypeName (..),
                                                  declStorage, declType)
import           Language.C.Analysis.TravMonad   (MonadTrav, catchTravError,
                                                  lookupObject)
import           Language.C.Analysis.TypeUtils   (canonicalType)
import           Language.C.Data.Ident           (Ident, SUERef (..),
                                                  identToString)
import           Language.C.Syntax.AST

-- | A field of a struct: the struct's tag and the field's name.
type FieldKey = (String, String)

structTag :: Type -> Maybe String
structTag :: Type -> Maybe String
structTag Type
ty = case Type -> Type
canonicalType Type
ty of
    DirectType (TyComp (CompTypeRef (NamedRef Ident
i) CompTyKind
StructTag NodeInfo
_)) TypeQuals
_ Attributes
_ -> String -> Maybe String
forall a. a -> Maybe a
Just (Ident -> String
identToString Ident
i)
    Type
_                                                              -> Maybe String
forall a. Maybe a
Nothing

-- | The field a member access reads or writes.
fieldKey :: MonadTrav m => CExpr -> m (Maybe FieldKey)
fieldKey :: forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe FieldKey)
fieldKey = \case
    CMember CExpr
e Ident
f Bool
isArrow NodeInfo
_ -> CExpr -> m (Maybe Type)
forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType CExpr
e m (Maybe Type)
-> (Maybe Type -> m (Maybe FieldKey)) -> m (Maybe FieldKey)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Maybe Type
ty -> Maybe FieldKey -> m (Maybe FieldKey)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe FieldKey -> m (Maybe FieldKey))
-> Maybe FieldKey -> m (Maybe FieldKey)
forall a b. (a -> b) -> a -> b
$ do
        Type
t <- Maybe Type
ty
        String
tag <- Type -> Maybe String
structTag (Type -> Maybe String) -> Type -> Maybe String
forall a b. (a -> b) -> a -> b
$ if Bool
isArrow then Type -> Type
pointee Type
t else Type
t
        FieldKey -> Maybe FieldKey
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
tag, Ident -> String
identToString Ident
f)
    CExpr
_ -> Maybe FieldKey -> m (Maybe FieldKey)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FieldKey
forall a. Maybe a
Nothing
  where
    pointee :: Type -> Type
pointee Type
t = case Type -> Type
canonicalType Type
t of
        PtrType Type
p TypeQuals
_ Attributes
_ -> Type
p
        Type
other         -> Type
other

-- | Type of a function, or of what a function pointer points to.
-- 'canonicalType' turns function types into function pointers.
funType :: Type -> Maybe FunType
funType :: Type -> Maybe FunType
funType Type
ty = case Type -> Type
canonicalType Type
ty of
    PtrType (FunctionType FunType
ft Attributes
_) TypeQuals
_ Attributes
_ -> FunType -> Maybe FunType
forall a. a -> Maybe a
Just FunType
ft
    FunctionType FunType
ft Attributes
_               -> FunType -> Maybe FunType
forall a. a -> Maybe a
Just FunType
ft
    Type
_                               -> Maybe FunType
forall a. Maybe a
Nothing

-- | The name the program knows a function by, which for a static function
-- includes its translation unit.
funKey :: MonadTrav m => FilePath -> Ident -> m (Maybe String)
funKey :: forall (m :: * -> *).
MonadTrav m =>
String -> Ident -> m (Maybe String)
funKey String
unit Ident
i = (Ident -> m (Maybe IdentDecl)
forall (m :: * -> *).
(MonadCError m, MonadSymtab m) =>
Ident -> m (Maybe IdentDecl)
lookupObject Ident
i m (Maybe IdentDecl)
-> (CError -> m (Maybe IdentDecl)) -> m (Maybe IdentDecl)
forall a. m a -> (CError -> m a) -> m a
forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
`catchTravError` m (Maybe IdentDecl) -> CError -> m (Maybe IdentDecl)
forall a b. a -> b -> a
const (Maybe IdentDecl -> m (Maybe IdentDecl)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe IdentDecl
forall a. Maybe a
Nothing)) m (Maybe IdentDecl)
-> (Maybe IdentDecl -> m (Maybe String)) -> m (Maybe String)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just IdentDecl
d | Just FunType
_ <- Type -> Maybe FunType
funType (IdentDecl -> Type
forall n. Declaration n => n -> Type
declType IdentDecl
d) ->
        Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> m (Maybe String))
-> (String -> Maybe String) -> String -> m (Maybe String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe String
forall a. a -> Maybe a
Just (String -> m (Maybe String)) -> String -> m (Maybe String)
forall a b. (a -> b) -> a -> b
$ if Storage -> Bool
isInternal (IdentDecl -> Storage
forall d. Declaration d => d -> Storage
declStorage IdentDecl
d) then String
unit String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Ident -> String
identToString Ident
i else Ident -> String
identToString Ident
i
    Maybe IdentDecl
_ -> Maybe String -> m (Maybe String)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
  where
    isInternal :: Storage -> Bool
isInternal = \case
        FunLinkage Linkage
InternalLinkage -> Bool
True
        Static Linkage
InternalLinkage Bool
_   -> Bool
True
        Storage
_                          -> Bool
False

exprType :: MonadTrav m => CExpr -> m (Maybe Type)
exprType :: forall (m :: * -> *). MonadTrav m => CExpr -> m (Maybe Type)
exprType CExpr
e = (Type -> Maybe Type
forall a. a -> Maybe a
Just (Type -> Maybe Type) -> m Type -> m (Maybe Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [StmtCtx] -> ExprSide -> CExpr -> m Type
forall (m :: * -> *).
MonadTrav m =>
[StmtCtx] -> ExprSide -> CExpr -> m Type
tExpr [] ExprSide
RValue CExpr
e) m (Maybe Type) -> (CError -> m (Maybe Type)) -> m (Maybe Type)
forall a. m a -> (CError -> m a) -> m a
forall (m :: * -> *) a.
MonadCError m =>
m a -> (CError -> m a) -> m a
`catchTravError` m (Maybe Type) -> CError -> m (Maybe Type)
forall a b. a -> b -> a
const (Maybe Type -> m (Maybe Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
forall a. Maybe a
Nothing)