{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase #-}
module Language.Fortran.Analysis.Types
( analyseTypes
, analyseTypesWithEnv
, analyseAndCheckTypesWithEnv
, extractTypeEnv
, TypeEnv
, TypeError
, deriveSemTypeFromDeclaration
, deriveSemTypeFromTypeSpec
, deriveSemTypeFromBaseType
, runInfer
, inferState0
) where
import Language.Fortran.AST
import Prelude hiding (lookup, EQ, LT, GT)
import Data.Map (insert)
import qualified Data.Map as M
import Data.Maybe (maybeToList)
import Data.List (find, foldl')
import Control.Monad.State.Strict
import Data.Generics.Uniplate.Data
import Data.Data
import Data.Functor.Identity (Identity ())
import Language.Fortran.Analysis
import Language.Fortran.Analysis.SemanticTypes
import Language.Fortran.Intrinsics
import Language.Fortran.Util.Position
import Language.Fortran.Version (FortranVersion(..))
import Language.Fortran.Parser.Utils
type TypeEnv = M.Map Name IDType
type TypeError = (String, SrcSpan)
type StructTypeEnv = M.Map Name StructMemberTypeEnv
type StructMemberTypeEnv = M.Map Name IDType
type Infer a = State InferState a
data InferState = InferState { InferState -> FortranVersion
langVersion :: FortranVersion
, InferState -> IntrinsicsTable
intrinsics :: IntrinsicsTable
, InferState -> TypeEnv
environ :: TypeEnv
, InferState -> StructTypeEnv
structs :: StructTypeEnv
, InferState -> Map Name (Name, Maybe Name)
entryPoints :: M.Map Name (Name, Maybe Name)
, InferState -> [TypeError]
typeErrors :: [TypeError] }
deriving Kind -> InferState -> ShowS
[InferState] -> ShowS
InferState -> Name
(Kind -> InferState -> ShowS)
-> (InferState -> Name)
-> ([InferState] -> ShowS)
-> Show InferState
forall a.
(Kind -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [InferState] -> ShowS
$cshowList :: [InferState] -> ShowS
show :: InferState -> Name
$cshow :: InferState -> Name
showsPrec :: Kind -> InferState -> ShowS
$cshowsPrec :: Kind -> InferState -> ShowS
Show
type InferFunc t = t -> Infer ()
analyseTypes :: Data a => ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypes :: forall a.
Data a =>
ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypes = TypeEnv
-> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypesWithEnv TypeEnv
forall k a. Map k a
M.empty
analyseTypesWithEnv :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypesWithEnv :: forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypesWithEnv TypeEnv
env ProgramFile (Analysis a)
pf = (ProgramFile (Analysis a)
pf', TypeEnv
tenv)
where
(ProgramFile (Analysis a)
pf', InferState
endState) = TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' TypeEnv
env ProgramFile (Analysis a)
pf
tenv :: TypeEnv
tenv = InferState -> TypeEnv
environ InferState
endState
analyseAndCheckTypesWithEnv
:: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv, [TypeError])
analyseAndCheckTypesWithEnv :: forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), TypeEnv, [TypeError])
analyseAndCheckTypesWithEnv TypeEnv
env ProgramFile (Analysis a)
pf = (ProgramFile (Analysis a)
pf', TypeEnv
tenv, [TypeError]
terrs)
where
(ProgramFile (Analysis a)
pf', InferState
endState) = TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' TypeEnv
env ProgramFile (Analysis a)
pf
tenv :: TypeEnv
tenv = InferState -> TypeEnv
environ InferState
endState
terrs :: [TypeError]
terrs = InferState -> [TypeError]
typeErrors InferState
endState
analyseTypesWithEnv' :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' :: forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' TypeEnv
env pf :: ProgramFile (Analysis a)
pf@(ProgramFile MetaInfo
mi [ProgramUnit (Analysis a)]
_) = FortranVersion
-> TypeEnv
-> State InferState (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState)
forall a.
FortranVersion -> TypeEnv -> State InferState a -> (a, InferState)
runInfer (MetaInfo -> FortranVersion
miVersion MetaInfo
mi) TypeEnv
env (State InferState (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState))
-> State InferState (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState)
forall a b. (a -> b) -> a -> b
$ do
(Expression (Analysis a) -> StateT InferState Identity ())
-> [Expression (Analysis a)] -> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expression (Analysis a) -> StateT InferState Identity ()
forall a. Data a => InferFunc (Expression (Analysis a))
intrinsicsExp (UniFunc ProgramFile Expression a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Expression a
allExpressions ProgramFile (Analysis a)
pf)
(ProgramUnit (Analysis a) -> StateT InferState Identity ())
-> [ProgramUnit (Analysis a)] -> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgramUnit (Analysis a) -> StateT InferState Identity ()
forall a. Data a => InferFunc (ProgramUnit (Analysis a))
programUnit (UniFunc ProgramFile ProgramUnit a
forall a. Data a => UniFunc ProgramFile ProgramUnit a
allProgramUnits ProgramFile (Analysis a)
pf)
(Declarator (Analysis a) -> StateT InferState Identity ())
-> [Declarator (Analysis a)] -> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Declarator (Analysis a) -> StateT InferState Identity ()
forall a. Data a => InferFunc (Declarator (Analysis a))
declarator (UniFunc ProgramFile Declarator a
forall a. Data a => UniFunc ProgramFile Declarator a
allDeclarators ProgramFile (Analysis a)
pf)
(Statement (Analysis a) -> StateT InferState Identity ())
-> [Statement (Analysis a)] -> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Statement (Analysis a) -> StateT InferState Identity ()
forall a. Data a => InferFunc (Statement (Analysis a))
statement (UniFunc ProgramFile Statement a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements ProgramFile (Analysis a)
pf)
[(Name, (Name, Maybe Name))]
eps <- (InferState -> [(Name, (Name, Maybe Name))])
-> StateT InferState Identity [(Name, (Name, Maybe Name))]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Map Name (Name, Maybe Name) -> [(Name, (Name, Maybe Name))]
forall k a. Map k a -> [(k, a)]
M.toList (Map Name (Name, Maybe Name) -> [(Name, (Name, Maybe Name))])
-> (InferState -> Map Name (Name, Maybe Name))
-> InferState
-> [(Name, (Name, Maybe Name))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InferState -> Map Name (Name, Maybe Name)
entryPoints)
[(Name, (Name, Maybe Name))]
-> ((Name, (Name, Maybe Name)) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, (Name, Maybe Name))]
eps (((Name, (Name, Maybe Name)) -> StateT InferState Identity ())
-> StateT InferState Identity ())
-> ((Name, (Name, Maybe Name)) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ (Name
eName, (Name
fName, Maybe Name
mRetName)) -> do
Maybe IDType
mFType <- Name -> Infer (Maybe IDType)
getRecordedType Name
fName
case Maybe IDType
mFType of
Just (IDType Maybe SemType
fVType Maybe ConstructType
fCType) -> do
Maybe SemType
-> Maybe ConstructType -> Name -> StateT InferState Identity ()
recordMType Maybe SemType
fVType Maybe ConstructType
fCType Name
eName
StateT InferState Identity ()
-> (Name -> StateT InferState Identity ())
-> Maybe Name
-> StateT InferState Identity ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Name -> Name -> Any
forall a. HasCallStack => Name -> a
error Name
"Entry points with result variables unsupported" (Name -> Any)
-> (Name -> StateT InferState Identity ())
-> Name
-> StateT InferState Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> Maybe ConstructType -> Name -> StateT InferState Identity ()
recordMType Maybe SemType
fVType Maybe ConstructType
forall a. Maybe a
Nothing) Maybe Name
mRetName
Maybe IDType
_ -> () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ProgramFile (Analysis a)
-> State InferState (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a))
annotateTypes ProgramFile (Analysis a)
pf
extractTypeEnv :: forall a. Data a => ProgramFile (Analysis a) -> TypeEnv
ProgramFile (Analysis a)
pf = TypeEnv -> TypeEnv -> TypeEnv
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union TypeEnv
puEnv TypeEnv
expEnv
where
puEnv :: TypeEnv
puEnv = [(Name, IDType)] -> TypeEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Name
n, IDType
ty) | ProgramUnit (Analysis a)
pu <- ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf :: [ProgramUnit (Analysis a)]
, Named Name
n <- [ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu]
, IDType
ty <- Maybe IDType -> [IDType]
forall a. Maybe a -> [a]
maybeToList (Analysis a -> Maybe IDType
forall a. Analysis a -> Maybe IDType
idType (ProgramUnit (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation ProgramUnit (Analysis a)
pu)) ]
expEnv :: TypeEnv
expEnv = [(Name, IDType)] -> TypeEnv
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [ (Name
n, IDType
ty) | e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ ValVariable{}) <- ProgramFile (Analysis a) -> [Expression (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi ProgramFile (Analysis a)
pf :: [Expression (Analysis a)]
, let n :: Name
n = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e
, IDType
ty <- Maybe IDType -> [IDType]
forall a. Maybe a -> [a]
maybeToList (Analysis a -> Maybe IDType
forall a. Analysis a -> Maybe IDType
idType (Expression (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation Expression (Analysis a)
e)) ]
type TransType f g a = (f (Analysis a) -> Infer (f (Analysis a))) -> g (Analysis a) -> Infer (g (Analysis a))
annotateTypes :: Data a => ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a))
annotateTypes :: forall a.
Data a =>
ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a))
annotateTypes ProgramFile (Analysis a)
pf = (forall {a}.
Data a =>
(Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT InferState Identity (ProgramFile (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM :: Data a => TransType Expression ProgramFile a) Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a) -> Infer (Expression (Analysis a))
annotateExpression ProgramFile (Analysis a)
pf StateT InferState Identity (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a)
-> StateT InferState Identity (ProgramFile (Analysis a)))
-> StateT InferState Identity (ProgramFile (Analysis a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(forall {a}.
Data a =>
(ProgramUnit (Analysis a)
-> StateT InferState Identity (ProgramUnit (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT InferState Identity (ProgramFile (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM :: Data a => TransType ProgramUnit ProgramFile a) ProgramUnit (Analysis a)
-> StateT InferState Identity (ProgramUnit (Analysis a))
forall a.
Data a =>
ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))
annotateProgramUnit
intrinsicsExp :: Data a => InferFunc (Expression (Analysis a))
intrinsicsExp :: forall a. Data a => InferFunc (Expression (Analysis a))
intrinsicsExp (ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
nexp AList Index (Analysis a)
_) = Expression (Analysis a) -> StateT InferState Identity ()
forall a. Expression (Analysis a) -> StateT InferState Identity ()
intrinsicsHelper Expression (Analysis a)
nexp
intrinsicsExp (ExpFunctionCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
nexp Maybe (AList Argument (Analysis a))
_) = Expression (Analysis a) -> StateT InferState Identity ()
forall a. Expression (Analysis a) -> StateT InferState Identity ()
intrinsicsHelper Expression (Analysis a)
nexp
intrinsicsExp Expression (Analysis a)
_ = () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
intrinsicsHelper :: Expression (Analysis a) -> StateT InferState Identity ()
intrinsicsHelper :: forall a. Expression (Analysis a) -> StateT InferState Identity ()
intrinsicsHelper Expression (Analysis a)
nexp | Expression (Analysis a) -> Bool
forall a. Expression a -> Bool
isNamedExpression Expression (Analysis a)
nexp = do
IntrinsicsTable
itab <- (InferState -> IntrinsicsTable)
-> StateT InferState Identity IntrinsicsTable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> IntrinsicsTable
intrinsics
case Name -> IntrinsicsTable -> Maybe IntrinsicType
getIntrinsicReturnType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
nexp) IntrinsicsTable
itab of
Just IntrinsicType
_ -> do
let n :: Name
n = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
nexp
ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTIntrinsic Name
n
Maybe IntrinsicType
_ -> () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
intrinsicsHelper Expression (Analysis a)
_ = () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
programUnit :: Data a => InferFunc (ProgramUnit (Analysis a))
programUnit :: forall a. Data a => InferFunc (ProgramUnit (Analysis a))
programUnit pu :: ProgramUnit (Analysis a)
pu@(PUFunction Analysis a
_ SrcSpan
_ Maybe (TypeSpec (Analysis a))
mRetType PrefixSuffix (Analysis a)
_ Name
_ Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
mRetVar [Block (Analysis a)]
blocks Maybe [ProgramUnit (Analysis a)]
_)
| Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu = do
ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTFunction Name
n
case (Maybe (TypeSpec (Analysis a))
mRetType, Maybe (Expression (Analysis a))
mRetVar) of
(Just ts :: TypeSpec (Analysis a)
ts@(TypeSpec Analysis a
_ SrcSpan
_ BaseType
_ Maybe (Selector (Analysis a))
_), Just Expression (Analysis a)
v) -> do
SemType
semType <- TypeSpec (Analysis a) -> Infer SemType
forall a. TypeSpec a -> Infer SemType
deriveSemTypeFromTypeSpec TypeSpec (Analysis a)
ts
SemType -> Name -> StateT InferState Identity ()
recordSemType SemType
semType Name
n StateT InferState Identity ()
-> StateT InferState Identity () -> StateT InferState Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SemType -> Name -> StateT InferState Identity ()
recordSemType SemType
semType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
(Just ts :: TypeSpec (Analysis a)
ts@(TypeSpec Analysis a
_ SrcSpan
_ BaseType
_ Maybe (Selector (Analysis a))
_), Maybe (Expression (Analysis a))
_) -> do
SemType
semType <- TypeSpec (Analysis a) -> Infer SemType
forall a. TypeSpec a -> Infer SemType
deriveSemTypeFromTypeSpec TypeSpec (Analysis a)
ts
SemType -> Name -> StateT InferState Identity ()
recordSemType SemType
semType Name
n
(Maybe (TypeSpec (Analysis a)), Maybe (Expression (Analysis a)))
_ -> () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Block (Analysis a)]
-> (Block (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Block (Analysis a)]
blocks ((Block (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ())
-> (Block (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ Block (Analysis a)
block ->
[StateT InferState Identity ()] -> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Name -> Name -> Maybe Name -> StateT InferState Identity ()
recordEntryPoint Name
n (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v) ((Expression (Analysis a) -> Name)
-> Maybe (Expression (Analysis a)) -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Maybe (Expression (Analysis a))
mRetVar') | (StEntry Analysis a
_ SrcSpan
_ Expression (Analysis a)
v Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
mRetVar') <- UniFunc Block Statement a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements Block (Analysis a)
block ]
programUnit pu :: ProgramUnit (Analysis a)
pu@(PUSubroutine Analysis a
_ SrcSpan
_ PrefixSuffix (Analysis a)
_ Name
_ Maybe (AList Expression (Analysis a))
_ [Block (Analysis a)]
blocks Maybe [ProgramUnit (Analysis a)]
_) | Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu = do
ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTSubroutine Name
n
[Block (Analysis a)]
-> (Block (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Block (Analysis a)]
blocks ((Block (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ())
-> (Block (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ Block (Analysis a)
block ->
[StateT InferState Identity ()] -> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Name -> Name -> Maybe Name -> StateT InferState Identity ()
recordEntryPoint Name
n (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v) Maybe Name
forall a. Maybe a
Nothing | (StEntry Analysis a
_ SrcSpan
_ Expression (Analysis a)
v Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_) <- UniFunc Block Statement a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements Block (Analysis a)
block ]
programUnit ProgramUnit (Analysis a)
_ = () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
declarator :: Data a => InferFunc (Declarator (Analysis a))
declarator :: forall a. Data a => InferFunc (Declarator (Analysis a))
declarator (DeclArray Analysis a
_ SrcSpan
_ Expression (Analysis a)
v AList DimensionDeclarator (Analysis a)
ddAList Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_) = ConstructType -> Name -> StateT InferState Identity ()
recordCType ([(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray ([(Maybe Kind, Maybe Kind)] -> ConstructType)
-> [(Maybe Kind, Maybe Kind)] -> ConstructType
forall a b. (a -> b) -> a -> b
$ AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
ddAList) (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
declarator Declarator (Analysis a)
_ = () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
dimDeclarator :: AList DimensionDeclarator a -> [(Maybe Int, Maybe Int)]
dimDeclarator :: forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator a
ddAList = [ (Maybe Kind
lb, Maybe Kind
ub) | DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
lbExp Maybe (Expression a)
ubExp <- AList DimensionDeclarator a -> [DimensionDeclarator a]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator a
ddAList
, let lb :: Maybe Kind
lb = do ExpValue a
_ SrcSpan
_ (ValInteger Name
i) <- Maybe (Expression a)
lbExp
Kind -> Maybe Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Maybe Kind) -> Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
forall a. Read a => Name -> a
read Name
i
, let ub :: Maybe Kind
ub = do ExpValue a
_ SrcSpan
_ (ValInteger Name
i) <- Maybe (Expression a)
ubExp
Kind -> Maybe Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Maybe Kind) -> Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
forall a. Read a => Name -> a
read Name
i ]
handleDeclaration :: Data a => TypeEnv -> SrcSpan -> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handleDeclaration :: forall a.
Data a =>
TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handleDeclaration TypeEnv
env SrcSpan
stmtSs TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList
| [Attribute (Analysis a)]
mAttrs <- [Attribute (Analysis a)]
-> (AList Attribute (Analysis a) -> [Attribute (Analysis a)])
-> Maybe (AList Attribute (Analysis a))
-> [Attribute (Analysis a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] AList Attribute (Analysis a) -> [Attribute (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip Maybe (AList Attribute (Analysis a))
mAttrAList
, Maybe (Attribute (Analysis a))
attrDim <- (Attribute (Analysis a) -> Bool)
-> [Attribute (Analysis a)] -> Maybe (Attribute (Analysis a))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Attribute (Analysis a) -> Bool
forall a. Attribute a -> Bool
isAttrDimension [Attribute (Analysis a)]
mAttrs
, Bool
isParam <- (Attribute (Analysis a) -> Bool)
-> [Attribute (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Attribute (Analysis a) -> Bool
forall a. Attribute a -> Bool
isAttrParameter [Attribute (Analysis a)]
mAttrs
, Bool
isExtrn <- (Attribute (Analysis a) -> Bool)
-> [Attribute (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Attribute (Analysis a) -> Bool
forall a. Attribute a -> Bool
isAttrExternal [Attribute (Analysis a)]
mAttrs
, [Declarator (Analysis a)]
decls <- AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
declAList =
let cType :: Name -> ConstructType
cType Name
n | Bool
isExtrn = ConstructType
CTExternal
| Just (AttrDimension Analysis a
_ SrcSpan
_ AList DimensionDeclarator (Analysis a)
ddAList) <- Maybe (Attribute (Analysis a))
attrDim = [(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray (AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
ddAList)
| Bool
isParam = ConstructType
CTParameter
| Just (IDType Maybe SemType
_ (Just ConstructType
ct)) <- Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n TypeEnv
env
, ConstructType
ct ConstructType -> ConstructType -> Bool
forall a. Eq a => a -> a -> Bool
/= ConstructType
CTIntrinsic = ConstructType
ct
| Bool
otherwise = ConstructType
CTVariable
handler :: [(Name, SemType, ConstructType)]
-> Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handler [(Name, SemType, ConstructType)]
rs = \case
DeclArray Analysis a
_ SrcSpan
declSs Expression (Analysis a)
v AList DimensionDeclarator (Analysis a)
ddAList Maybe (Expression (Analysis a))
mLenExpr Maybe (Expression (Analysis a))
_ -> do
SemType
st <- SrcSpan
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Infer SemType
forall a.
SrcSpan
-> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> Infer SemType
deriveSemTypeFromDeclaration SrcSpan
stmtSs SrcSpan
declSs TypeSpec (Analysis a)
ts Maybe (Expression (Analysis a))
mLenExpr
[(Name, SemType, ConstructType)]
-> Infer [(Name, SemType, ConstructType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, SemType, ConstructType)]
-> Infer [(Name, SemType, ConstructType)])
-> [(Name, SemType, ConstructType)]
-> Infer [(Name, SemType, ConstructType)]
forall a b. (a -> b) -> a -> b
$ (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v, SemType
st, [(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray ([(Maybe Kind, Maybe Kind)] -> ConstructType)
-> [(Maybe Kind, Maybe Kind)] -> ConstructType
forall a b. (a -> b) -> a -> b
$ AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
ddAList) (Name, SemType, ConstructType)
-> [(Name, SemType, ConstructType)]
-> [(Name, SemType, ConstructType)]
forall a. a -> [a] -> [a]
: [(Name, SemType, ConstructType)]
rs
DeclVariable Analysis a
_ SrcSpan
declSs Expression (Analysis a)
v Maybe (Expression (Analysis a))
mLenExpr Maybe (Expression (Analysis a))
_ -> do
SemType
st <- SrcSpan
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Infer SemType
forall a.
SrcSpan
-> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> Infer SemType
deriveSemTypeFromDeclaration SrcSpan
stmtSs SrcSpan
declSs TypeSpec (Analysis a)
ts Maybe (Expression (Analysis a))
mLenExpr
let n :: Name
n = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v
[(Name, SemType, ConstructType)]
-> Infer [(Name, SemType, ConstructType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, SemType, ConstructType)]
-> Infer [(Name, SemType, ConstructType)])
-> [(Name, SemType, ConstructType)]
-> Infer [(Name, SemType, ConstructType)]
forall a b. (a -> b) -> a -> b
$ (Name
n, SemType
st, Name -> ConstructType
cType Name
n) (Name, SemType, ConstructType)
-> [(Name, SemType, ConstructType)]
-> [(Name, SemType, ConstructType)]
forall a. a -> [a] -> [a]
: [(Name, SemType, ConstructType)]
rs
in ([(Name, SemType, ConstructType)]
-> Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)])
-> [(Name, SemType, ConstructType)]
-> [Declarator (Analysis a)]
-> Infer [(Name, SemType, ConstructType)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(Name, SemType, ConstructType)]
-> Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handler [] [Declarator (Analysis a)]
decls
handleStructureItem :: Data a => StructMemberTypeEnv -> StructureItem (Analysis a) -> Infer StructMemberTypeEnv
handleStructureItem :: forall a.
Data a =>
TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv
handleStructureItem TypeEnv
mt (StructFields Analysis a
_ SrcSpan
src TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList) = do
TypeEnv
env <- (InferState -> TypeEnv) -> Infer TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> TypeEnv
environ
[(Name, SemType, ConstructType)]
ds <- TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
forall a.
Data a =>
TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handleDeclaration TypeEnv
env SrcSpan
src TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList
TypeEnv -> Infer TypeEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeEnv -> Infer TypeEnv) -> TypeEnv -> Infer TypeEnv
forall a b. (a -> b) -> a -> b
$ (TypeEnv -> (Name, SemType, ConstructType) -> TypeEnv)
-> TypeEnv -> [(Name, SemType, ConstructType)] -> TypeEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\TypeEnv
m (Name
n, SemType
s, ConstructType
c) -> Name -> IDType -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n (Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
s) (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
c)) TypeEnv
m) TypeEnv
mt [(Name, SemType, ConstructType)]
ds
handleStructureItem TypeEnv
mt StructUnion{} = TypeEnv -> Infer TypeEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeEnv
mt
handleStructureItem TypeEnv
mt StructStructure{} = TypeEnv -> Infer TypeEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeEnv
mt
handleStructure ::Data a => Maybe String -> AList StructureItem (Analysis a) -> Infer ()
handleStructure :: forall a.
Data a =>
Maybe Name
-> AList StructureItem (Analysis a)
-> StateT InferState Identity ()
handleStructure Maybe Name
mName AList StructureItem (Analysis a)
itemAList = do
case Maybe Name
mName of
Just Name
n -> do
TypeEnv
structEnv <- (TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv)
-> TypeEnv -> [StructureItem (Analysis a)] -> Infer TypeEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv
forall a.
Data a =>
TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv
handleStructureItem TypeEnv
forall k a. Map k a
M.empty (AList StructureItem (Analysis a) -> [StructureItem (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList StructureItem (Analysis a)
itemAList)
TypeEnv -> Name -> StateT InferState Identity ()
recordStruct TypeEnv
structEnv Name
n
Maybe Name
Nothing -> () -> StateT InferState Identity ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
statement :: Data a => InferFunc (Statement (Analysis a))
statement :: forall a. Data a => InferFunc (Statement (Analysis a))
statement (StDeclaration Analysis a
_ SrcSpan
stmtSs TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList) = do
TypeEnv
env <- (InferState -> TypeEnv) -> Infer TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> TypeEnv
environ
[(Name, SemType, ConstructType)]
decls <- TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
forall a.
Data a =>
TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handleDeclaration TypeEnv
env SrcSpan
stmtSs TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList
[(Name, SemType, ConstructType)]
-> ((Name, SemType, ConstructType)
-> StateT InferState Identity ())
-> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, SemType, ConstructType)]
decls (((Name, SemType, ConstructType) -> StateT InferState Identity ())
-> StateT InferState Identity ())
-> ((Name, SemType, ConstructType)
-> StateT InferState Identity ())
-> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \(Name
n, SemType
b, ConstructType
c) -> SemType -> ConstructType -> Name -> StateT InferState Identity ()
recordType SemType
b ConstructType
c Name
n
statement (StExternal Analysis a
_ SrcSpan
_ AList Expression (Analysis a)
varAList) = do
let vars :: [Expression (Analysis a)]
vars = AList Expression (Analysis a) -> [Expression (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression (Analysis a)
varAList
(Expression (Analysis a) -> StateT InferState Identity ())
-> [Expression (Analysis a)] -> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTExternal (Name -> StateT InferState Identity ())
-> (Expression (Analysis a) -> Name)
-> Expression (Analysis a)
-> StateT InferState Identity ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName) [Expression (Analysis a)]
vars
statement (StExpressionAssign Analysis a
_ SrcSpan
_ (ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
v AList Index (Analysis a)
ixAList) Expression (Analysis a)
_)
| (Index (Analysis a) -> Bool) -> [Index (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Index (Analysis a) -> Bool
forall a. Index a -> Bool
isIxSingle (AList Index (Analysis a) -> [Index (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Index (Analysis a)
ixAList) = do
Maybe IDType
mIDType <- Expression (Analysis a) -> Infer (Maybe IDType)
forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType Expression (Analysis a)
v
case Maybe IDType
mIDType of
Just (IDType Maybe SemType
_ (Just CTArray{})) -> () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe IDType
_ -> ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTFunction (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
statement (StFunction Analysis a
_ SrcSpan
_ Expression (Analysis a)
v AList Expression (Analysis a)
_ Expression (Analysis a)
_) = ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTFunction (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
statement (StExpressionAssign Analysis a
_ SrcSpan
_ (ExpFunctionCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
v Maybe (AList Argument (Analysis a))
Nothing) Expression (Analysis a)
_) = ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTFunction (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
statement (StDimension Analysis a
_ SrcSpan
_ AList Declarator (Analysis a)
declAList) = do
let decls :: [Declarator (Analysis a)]
decls = AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
declAList
[Declarator (Analysis a)]
-> (Declarator (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Declarator (Analysis a)]
decls ((Declarator (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ())
-> (Declarator (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ Declarator (Analysis a)
decl -> case Declarator (Analysis a)
decl of
DeclArray Analysis a
_ SrcSpan
_ Expression (Analysis a)
v AList DimensionDeclarator (Analysis a)
ddAList Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ -> ConstructType -> Name -> StateT InferState Identity ()
recordCType ([(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray ([(Maybe Kind, Maybe Kind)] -> ConstructType)
-> [(Maybe Kind, Maybe Kind)] -> ConstructType
forall a b. (a -> b) -> a -> b
$ AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
ddAList) (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
Declarator (Analysis a)
_ -> () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
statement (StStructure Analysis a
_ SrcSpan
_ Maybe Name
mName AList StructureItem (Analysis a)
itemAList) = Maybe Name
-> AList StructureItem (Analysis a)
-> StateT InferState Identity ()
forall a.
Data a =>
Maybe Name
-> AList StructureItem (Analysis a)
-> StateT InferState Identity ()
handleStructure Maybe Name
mName AList StructureItem (Analysis a)
itemAList
statement Statement (Analysis a)
_ = () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a))
annotateExpression :: forall a.
Data a =>
Expression (Analysis a) -> Infer (Expression (Analysis a))
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_)) = Expression (Analysis a)
-> (IDType -> Expression (Analysis a))
-> Maybe IDType
-> Expression (Analysis a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expression (Analysis a)
e (IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
`setIDType` Expression (Analysis a)
e) (Maybe IDType -> Expression (Analysis a))
-> Infer (Maybe IDType)
-> StateT InferState Identity (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Infer (Maybe IDType)
getRecordedType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e)
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValIntrinsic Name
_)) = Expression (Analysis a)
-> (IDType -> Expression (Analysis a))
-> Maybe IDType
-> Expression (Analysis a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expression (Analysis a)
e (IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
`setIDType` Expression (Analysis a)
e) (Maybe IDType -> Expression (Analysis a))
-> Infer (Maybe IDType)
-> StateT InferState Identity (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Infer (Maybe IDType)
getRecordedType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e)
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
ss (ValReal Name
r)) = do
Kind
k <- SrcSpan -> Name -> Infer Kind
deriveRealLiteralKind SrcSpan
ss Name
r
Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType (Kind -> SemType
TReal Kind
k) Expression (Analysis a)
e
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
ss (ValComplex Expression (Analysis a)
e1 Expression (Analysis a)
e2)) = do
SemType
st <- SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> Infer SemType
forall a. SrcSpan -> Expression a -> Expression a -> Infer SemType
complexLiteralType SrcSpan
ss Expression (Analysis a)
e1 Expression (Analysis a)
e2
Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType SemType
st Expression (Analysis a)
e
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValInteger Name
_)) =
Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeInteger) Expression (Analysis a)
e
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValLogical Name
_)) =
Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeLogical) Expression (Analysis a)
e
annotateExpression e :: Expression (Analysis a)
e@(ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
op Expression (Analysis a)
e1 Expression (Analysis a)
e2) = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState Identity IDType
-> StateT InferState Identity (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> BinaryOp
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState Identity IDType
forall a.
Data a =>
SrcSpan
-> BinaryOp
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState Identity IDType
binaryOpType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) BinaryOp
op Expression (Analysis a)
e1 Expression (Analysis a)
e2
annotateExpression e :: Expression (Analysis a)
e@(ExpUnary Analysis a
_ SrcSpan
_ UnaryOp
op Expression (Analysis a)
e1) = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState Identity IDType
-> StateT InferState Identity (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState Identity IDType
forall a.
Data a =>
SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState Identity IDType
unaryOpType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e1) UnaryOp
op Expression (Analysis a)
e1
annotateExpression e :: Expression (Analysis a)
e@(ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
e1 AList Index (Analysis a)
idxAList) = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState Identity IDType
-> StateT InferState Identity (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> Expression (Analysis a)
-> AList Index (Analysis a)
-> StateT InferState Identity IDType
forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> AList Index (Analysis a)
-> StateT InferState Identity IDType
subscriptType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) Expression (Analysis a)
e1 AList Index (Analysis a)
idxAList
annotateExpression e :: Expression (Analysis a)
e@(ExpFunctionCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
e1 Maybe (AList Argument (Analysis a))
parAList) = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState Identity IDType
-> StateT InferState Identity (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> Expression (Analysis a)
-> Maybe (AList Argument (Analysis a))
-> StateT InferState Identity IDType
forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> Maybe (AList Argument (Analysis a))
-> StateT InferState Identity IDType
functionCallType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) Expression (Analysis a)
e1 Maybe (AList Argument (Analysis a))
parAList
annotateExpression Expression (Analysis a)
e = Expression (Analysis a)
-> StateT InferState Identity (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
e
annotateProgramUnit :: Data a => ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))
annotateProgramUnit :: forall a.
Data a =>
ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))
annotateProgramUnit ProgramUnit (Analysis a)
pu | Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu = ProgramUnit (Analysis a)
-> (IDType -> ProgramUnit (Analysis a))
-> Maybe IDType
-> ProgramUnit (Analysis a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ProgramUnit (Analysis a)
pu (IDType -> ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
`setIDType` ProgramUnit (Analysis a)
pu) (Maybe IDType -> ProgramUnit (Analysis a))
-> Infer (Maybe IDType)
-> StateT InferState Identity (ProgramUnit (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Infer (Maybe IDType)
getRecordedType Name
n
annotateProgramUnit ProgramUnit (Analysis a)
pu = ProgramUnit (Analysis a)
-> StateT InferState Identity (ProgramUnit (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return ProgramUnit (Analysis a)
pu
deriveRealLiteralKind :: SrcSpan -> String -> Infer Kind
deriveRealLiteralKind :: SrcSpan -> Name -> Infer Kind
deriveRealLiteralKind SrcSpan
ss Name
r =
case RealLit -> Maybe Kind
realLitKindParam RealLit
realLit of
Maybe Kind
Nothing -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
kindFromExpOrDefault
Just Kind
k ->
case RealLit -> Maybe Exponent
realLitExponent RealLit
realLit of
Maybe Exponent
Nothing -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
k
Just Exponent
expo ->
case Exponent -> ExponentLetter
expLetter Exponent
expo of
ExponentLetter
ExpLetterE -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
k
ExponentLetter
_ -> do
Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"only real literals with exponent letter 'e' can specify explicit kind parameter" SrcSpan
ss
Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
k
where
realLit :: RealLit
realLit = Name -> RealLit
parseRealLiteral Name
r
kindFromExpOrDefault :: Kind
kindFromExpOrDefault =
case RealLit -> Maybe Exponent
realLitExponent RealLit
realLit of
Maybe Exponent
Nothing -> Kind
4
Just Exponent
expo ->
case Exponent -> ExponentLetter
expLetter Exponent
expo of
ExponentLetter
ExpLetterE -> Kind
4
ExponentLetter
ExpLetterD -> Kind
8
complexLiteralType :: SrcSpan -> Expression a -> Expression a -> Infer SemType
complexLiteralType :: forall a. SrcSpan -> Expression a -> Expression a -> Infer SemType
complexLiteralType SrcSpan
ss (ExpValue a
_ SrcSpan
_ (ValReal Name
r)) Expression a
_ = do
Kind
k1 <- SrcSpan -> Name -> Infer Kind
deriveRealLiteralKind SrcSpan
ss Name
r
SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> Infer SemType) -> SemType -> Infer SemType
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k1
complexLiteralType SrcSpan
_ Expression a
_ Expression a
_ = SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> Infer SemType) -> SemType -> Infer SemType
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeComplex
binaryOpType :: Data a => SrcSpan -> BinaryOp -> Expression (Analysis a) -> Expression (Analysis a) -> Infer IDType
binaryOpType :: forall a.
Data a =>
SrcSpan
-> BinaryOp
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState Identity IDType
binaryOpType SrcSpan
ss BinaryOp
op Expression (Analysis a)
e1 Expression (Analysis a)
e2 = do
Maybe SemType
mst1 <- case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e1 of
Just (IDType (Just SemType
st) Maybe ConstructType
_) -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Unable to obtain type for first operand" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e1) StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
Maybe SemType
mst2 <- case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e2 of
Just (IDType (Just SemType
st) Maybe ConstructType
_) -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Unable to obtain type for second operand" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e2) StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
case (Maybe SemType
mst1, Maybe SemType
mst2) of
(Maybe SemType
_, Maybe SemType
Nothing) -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
(Maybe SemType
Nothing, Maybe SemType
_) -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
(Just SemType
st1, Just SemType
st2) -> do
Maybe SemType
mst <- SrcSpan
-> BinaryOp
-> SemType
-> SemType
-> StateT InferState Identity (Maybe SemType)
binopSimpleCombineSemTypes SrcSpan
ss BinaryOp
op SemType
st1 SemType
st2
Maybe SemType
mst' <- case Maybe SemType
mst of
Just SemType
st
| BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ BinaryOp
Addition, BinaryOp
Subtraction, BinaryOp
Multiplication, BinaryOp
Division
, BinaryOp
Exponentiation, BinaryOp
Concatenation, BinaryOp
Or, BinaryOp
XOr, BinaryOp
And ] -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
| BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
GT, BinaryOp
GTE, BinaryOp
LT, BinaryOp
LTE, BinaryOp
EQ, BinaryOp
NE, BinaryOp
Equivalent, BinaryOp
NotEquivalent] -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeLogical)
| BinCustom{} <- BinaryOp
op -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"custom binary ops not supported" SrcSpan
ss StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
Maybe SemType
_ -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState Identity IDType)
-> IDType -> StateT InferState Identity IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst' Maybe ConstructType
forall a. Maybe a
Nothing
binopSimpleCombineSemTypes :: SrcSpan -> BinaryOp -> SemType -> SemType -> Infer (Maybe SemType)
binopSimpleCombineSemTypes :: SrcSpan
-> BinaryOp
-> SemType
-> SemType
-> StateT InferState Identity (Maybe SemType)
binopSimpleCombineSemTypes SrcSpan
ss BinaryOp
op SemType
st1 SemType
st2 = do
case (SemType
st1, SemType
st2) of
(SemType
_ , TComplex Kind
k2) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k2
(TComplex Kind
k1, SemType
_ ) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k1
(SemType
_ , TReal Kind
k2) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TReal Kind
k2
(TReal Kind
k1, SemType
_ ) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TReal Kind
k1
(SemType
_ , TInteger Kind
k2) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TInteger Kind
k2
(TInteger Kind
k1, SemType
_ ) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TInteger Kind
k1
(TByte Kind
k1, TByte Kind
_ ) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TByte Kind
k1
(TLogical Kind
k1, TLogical Kind
_ ) -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TLogical Kind
k1
(TCustom Name
_, TCustom Name
_) -> do
Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"custom types / binary op not supported" SrcSpan
ss
Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
(TCharacter CharacterLen
l1 Kind
k1, TCharacter CharacterLen
l2 Kind
k2)
| Kind
k1 Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
/= Kind
k2 -> do Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"operation on character strings of different kinds" SrcSpan
ss
Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
| BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
Concatenation -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> SemType
TCharacter (CharacterLen -> CharacterLen -> CharacterLen
charLenConcat CharacterLen
l1 CharacterLen
l2) Kind
k1
| BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
EQ, BinaryOp
NE] -> SemType -> StateT InferState Identity (Maybe SemType)
forall {a}. a -> StateT InferState Identity (Maybe a)
ret (SemType -> StateT InferState Identity (Maybe SemType))
-> SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeLogical
| Bool
otherwise -> do Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Invalid op on character strings" SrcSpan
ss
Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
(SemType, SemType)
_ -> do Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Type error between operands of binary operator" SrcSpan
ss
Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
where
ret :: a -> StateT InferState Identity (Maybe a)
ret = Maybe a -> StateT InferState Identity (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> StateT InferState Identity (Maybe a))
-> (a -> Maybe a) -> a -> StateT InferState Identity (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just
unaryOpType :: Data a => SrcSpan -> UnaryOp -> Expression (Analysis a) -> Infer IDType
unaryOpType :: forall a.
Data a =>
SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState Identity IDType
unaryOpType SrcSpan
ss UnaryOp
op Expression (Analysis a)
e = do
Maybe SemType
mst <- case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e of
Just (IDType (Just SemType
st) Maybe ConstructType
_) -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Unable to obtain type for" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
Maybe SemType
mst' <- case (Maybe SemType
mst, UnaryOp
op) of
(Maybe SemType
Nothing, UnaryOp
_) -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
(Just TCustom{}, UnaryOp
_) -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"custom types / unary ops not supported" SrcSpan
ss StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
(Maybe SemType
_, UnCustom{}) -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"custom unary ops not supported" SrcSpan
ss StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
(Just st :: SemType
st@(TLogical Kind
_), UnaryOp
Not) -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
(Just SemType
st, UnaryOp
_)
| UnaryOp
op UnaryOp -> [UnaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnaryOp
Plus, UnaryOp
Minus] Bool -> Bool -> Bool
&&
SemType -> Bool
isNumericType SemType
st -> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
(Maybe SemType, UnaryOp)
_ -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Type error for unary operator" SrcSpan
ss StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState Identity IDType)
-> IDType -> StateT InferState Identity IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst' Maybe ConstructType
forall a. Maybe a
Nothing
subscriptType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Index (Analysis a) -> Infer IDType
subscriptType :: forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> AList Index (Analysis a)
-> StateT InferState Identity IDType
subscriptType SrcSpan
ss Expression (Analysis a)
e1 (AList Analysis a
_ SrcSpan
_ [Index (Analysis a)]
idxs) = do
let isInteger :: f (Analysis a) -> Bool
isInteger f (Analysis a)
ie | Just (IDType (Just (TInteger Kind
_)) Maybe ConstructType
_) <- f (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType f (Analysis a)
ie = Bool
True
| Bool
otherwise = Bool
False
[Index (Analysis a)]
-> (Index (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Index (Analysis a)]
idxs ((Index (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ())
-> (Index (Analysis a) -> StateT InferState Identity ())
-> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ Index (Analysis a)
idx -> case Index (Analysis a)
idx of
IxSingle Analysis a
_ SrcSpan
_ Maybe Name
_ Expression (Analysis a)
ie
| Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie) -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie)
IxRange Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mie1 Maybe (Expression (Analysis a))
mie2 Maybe (Expression (Analysis a))
mie3
| Just Expression (Analysis a)
ie1 <- Maybe (Expression (Analysis a))
mie1, Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie1) -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie1)
| Just Expression (Analysis a)
ie2 <- Maybe (Expression (Analysis a))
mie2, Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie2) -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie2)
| Just Expression (Analysis a)
ie3 <- Maybe (Expression (Analysis a))
mie3, Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie3) -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie3)
Index (Analysis a)
_ -> () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e1 of
Just ty :: IDType
ty@(IDType Maybe SemType
mst (Just (CTArray [(Maybe Kind, Maybe Kind)]
dds))) -> do
Bool
-> StateT InferState Identity () -> StateT InferState Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Index (Analysis a)] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Index (Analysis a)]
idxs Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Maybe Kind, Maybe Kind)] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [(Maybe Kind, Maybe Kind)]
dds) (StateT InferState Identity () -> StateT InferState Identity ())
-> StateT InferState Identity () -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"Length of indices does not match rank of array." SrcSpan
ss
let isSingle :: Index a -> Bool
isSingle (IxSingle{}) = Bool
True; isSingle Index a
_ = Bool
False
if (Index (Analysis a) -> Bool) -> [Index (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Index (Analysis a) -> Bool
forall a. Index a -> Bool
isSingle [Index (Analysis a)]
idxs
then IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState Identity IDType)
-> IDType -> StateT InferState Identity IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst Maybe ConstructType
forall a. Maybe a
Nothing
else IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
ty
Maybe IDType
_ -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
functionCallType :: Data a => SrcSpan -> Expression (Analysis a) -> Maybe (AList Argument (Analysis a)) -> Infer IDType
functionCallType :: forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> Maybe (AList Argument (Analysis a))
-> StateT InferState Identity IDType
functionCallType SrcSpan
ss (ExpValue Analysis a
_ SrcSpan
_ (ValIntrinsic Name
n)) (Just (AList Analysis a
_ SrcSpan
_ [Argument (Analysis a)]
params)) = do
IntrinsicsTable
itab <- (InferState -> IntrinsicsTable)
-> StateT InferState Identity IntrinsicsTable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> IntrinsicsTable
intrinsics
let mRetType :: Maybe IntrinsicType
mRetType = Name -> IntrinsicsTable -> Maybe IntrinsicType
getIntrinsicReturnType Name
n IntrinsicsTable
itab
case Maybe IntrinsicType
mRetType of
Maybe IntrinsicType
Nothing -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
Just IntrinsicType
retType -> do
Maybe SemType
mst <- case IntrinsicType
retType of
IntrinsicType
ITReal -> BaseType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeReal
IntrinsicType
ITInteger -> BaseType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeInteger
IntrinsicType
ITComplex -> BaseType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeComplex
IntrinsicType
ITDouble -> BaseType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeDoublePrecision
IntrinsicType
ITLogical -> BaseType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeLogical
IntrinsicType
ITCharacter -> BaseType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeCharacter
ITParam Kind
i
| [Argument (Analysis a)] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Argument (Analysis a)]
params Kind -> Kind -> Bool
forall a. Ord a => a -> a -> Bool
>= Kind
i, Argument Analysis a
_ SrcSpan
_ Maybe Name
_ Expression (Analysis a)
e <- [Argument (Analysis a)]
params [Argument (Analysis a)] -> Kind -> Argument (Analysis a)
forall a. [a] -> Kind -> a
!! (Kind
iKind -> Kind -> Kind
forall a. Num a => a -> a -> a
-Kind
1)
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> StateT InferState Identity (Maybe SemType))
-> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ IDType -> Maybe SemType
idVType (IDType -> Maybe SemType) -> Maybe IDType -> Maybe SemType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e
| Bool
otherwise -> Name -> SrcSpan -> StateT InferState Identity ()
typeError (Name
"Invalid parameter list to intrinsic '" Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
n Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
"'") SrcSpan
ss StateT InferState Identity ()
-> StateT InferState Identity (Maybe SemType)
-> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType -> StateT InferState Identity (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
case Maybe SemType
mst of
Maybe SemType
Nothing -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
Just SemType
_ -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState Identity IDType)
-> IDType -> StateT InferState Identity IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst Maybe ConstructType
forall a. Maybe a
Nothing
where
wrapBaseType :: Monad m => BaseType -> m (Maybe SemType)
wrapBaseType :: forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType = Maybe SemType -> m (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> m (Maybe SemType))
-> (BaseType -> Maybe SemType) -> BaseType -> m (Maybe SemType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SemType -> Maybe SemType
forall a. a -> Maybe a
Just (SemType -> Maybe SemType)
-> (BaseType -> SemType) -> BaseType -> Maybe SemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseType -> SemType
deriveSemTypeFromBaseType
functionCallType SrcSpan
ss Expression (Analysis a)
e1 Maybe (AList Argument (Analysis a))
_ = case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e1 of
Just (IDType (Just SemType
st) (Just ConstructType
CTFunction)) -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState Identity IDType)
-> IDType -> StateT InferState Identity IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
forall a. Maybe a
Nothing
Just (IDType (Just SemType
st) (Just ConstructType
CTExternal)) -> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState Identity IDType)
-> IDType -> StateT InferState Identity IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
forall a. Maybe a
Nothing
Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"non-function invoked by call" SrcSpan
ss StateT InferState Identity ()
-> StateT InferState Identity IDType
-> StateT InferState Identity IDType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IDType -> StateT InferState Identity IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
isNumericType :: SemType -> Bool
isNumericType :: SemType -> Bool
isNumericType = \case
TComplex{} -> Bool
True
TReal{} -> Bool
True
TInteger{} -> Bool
True
TByte{} -> Bool
True
SemType
_ -> Bool
False
inferState0 :: FortranVersion -> InferState
inferState0 :: FortranVersion -> InferState
inferState0 FortranVersion
v = InferState :: FortranVersion
-> IntrinsicsTable
-> TypeEnv
-> StructTypeEnv
-> Map Name (Name, Maybe Name)
-> [TypeError]
-> InferState
InferState { environ :: TypeEnv
environ = TypeEnv
forall k a. Map k a
M.empty, structs :: StructTypeEnv
structs = StructTypeEnv
forall k a. Map k a
M.empty, entryPoints :: Map Name (Name, Maybe Name)
entryPoints = Map Name (Name, Maybe Name)
forall k a. Map k a
M.empty, langVersion :: FortranVersion
langVersion = FortranVersion
v
, intrinsics :: IntrinsicsTable
intrinsics = FortranVersion -> IntrinsicsTable
getVersionIntrinsics FortranVersion
v, typeErrors :: [TypeError]
typeErrors = [] }
runInfer :: FortranVersion -> TypeEnv -> State InferState a -> (a, InferState)
runInfer :: forall a.
FortranVersion -> TypeEnv -> State InferState a -> (a, InferState)
runInfer FortranVersion
v TypeEnv
env = (State InferState a -> InferState -> (a, InferState))
-> InferState -> State InferState a -> (a, InferState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip State InferState a -> InferState -> (a, InferState)
forall s a. State s a -> s -> (a, s)
runState ((FortranVersion -> InferState
inferState0 FortranVersion
v) { environ :: TypeEnv
environ = TypeEnv
env })
typeError :: String -> SrcSpan -> Infer ()
typeError :: Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
msg SrcSpan
ss = (InferState -> InferState) -> StateT InferState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> StateT InferState Identity ())
-> (InferState -> InferState) -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { typeErrors :: [TypeError]
typeErrors = (Name
msg, SrcSpan
ss)TypeError -> [TypeError] -> [TypeError]
forall a. a -> [a] -> [a]
:InferState -> [TypeError]
typeErrors InferState
s }
emptyType :: IDType
emptyType :: IDType
emptyType = Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
forall a. Maybe a
Nothing Maybe ConstructType
forall a. Maybe a
Nothing
recordType :: SemType -> ConstructType -> Name -> Infer ()
recordType :: SemType -> ConstructType -> Name -> StateT InferState Identity ()
recordType SemType
st ConstructType
ct Name
n = (InferState -> InferState) -> StateT InferState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> StateT InferState Identity ())
-> (InferState -> InferState) -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = Name -> IDType -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Name
n (Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
ct)) (InferState -> TypeEnv
environ InferState
s) }
recordStruct :: StructMemberTypeEnv -> Name -> Infer ()
recordStruct :: TypeEnv -> Name -> StateT InferState Identity ()
recordStruct TypeEnv
mt Name
n = (InferState -> InferState) -> StateT InferState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> StateT InferState Identity ())
-> (InferState -> InferState) -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \InferState
s -> InferState
s { structs :: StructTypeEnv
structs = Name -> TypeEnv -> StructTypeEnv -> StructTypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Name
n TypeEnv
mt (InferState -> StructTypeEnv
structs InferState
s) }
recordMType :: Maybe SemType -> Maybe ConstructType -> Name -> Infer ()
recordMType :: Maybe SemType
-> Maybe ConstructType -> Name -> StateT InferState Identity ()
recordMType Maybe SemType
st Maybe ConstructType
ct Name
n = (InferState -> InferState) -> StateT InferState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> StateT InferState Identity ())
-> (InferState -> InferState) -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = Name -> IDType -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Name
n (Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
st Maybe ConstructType
ct) (InferState -> TypeEnv
environ InferState
s) }
recordCType :: ConstructType -> Name -> Infer ()
recordCType :: ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
ct Name
n = (InferState -> InferState) -> StateT InferState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> StateT InferState Identity ())
-> (InferState -> InferState) -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = (Maybe IDType -> Maybe IDType) -> Name -> TypeEnv -> TypeEnv
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe IDType -> Maybe IDType
changeFunc Name
n (InferState -> TypeEnv
environ InferState
s) }
where changeFunc :: Maybe IDType -> Maybe IDType
changeFunc Maybe IDType
mIDType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just (Maybe SemType -> Maybe ConstructType -> IDType
IDType (Maybe IDType
mIDType Maybe IDType -> (IDType -> Maybe SemType) -> Maybe SemType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IDType -> Maybe SemType
idVType) (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
ct))
recordSemType :: SemType -> Name -> Infer ()
recordSemType :: SemType -> Name -> StateT InferState Identity ()
recordSemType SemType
st Name
n = (InferState -> InferState) -> StateT InferState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> StateT InferState Identity ())
-> (InferState -> InferState) -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = (Maybe IDType -> Maybe IDType) -> Name -> TypeEnv -> TypeEnv
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe IDType -> Maybe IDType
changeFunc Name
n (InferState -> TypeEnv
environ InferState
s) }
where changeFunc :: Maybe IDType -> Maybe IDType
changeFunc Maybe IDType
mIDType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just (Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) (Maybe IDType
mIDType Maybe IDType
-> (IDType -> Maybe ConstructType) -> Maybe ConstructType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IDType -> Maybe ConstructType
idCType))
recordEntryPoint :: Name -> Name -> Maybe Name -> Infer ()
recordEntryPoint :: Name -> Name -> Maybe Name -> StateT InferState Identity ()
recordEntryPoint Name
fn Name
en Maybe Name
mRetName = (InferState -> InferState) -> StateT InferState Identity ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> StateT InferState Identity ())
-> (InferState -> InferState) -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { entryPoints :: Map Name (Name, Maybe Name)
entryPoints = Name
-> (Name, Maybe Name)
-> Map Name (Name, Maybe Name)
-> Map Name (Name, Maybe Name)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
en (Name
fn, Maybe Name
mRetName) (InferState -> Map Name (Name, Maybe Name)
entryPoints InferState
s) }
getRecordedType :: Name -> Infer (Maybe IDType)
getRecordedType :: Name -> Infer (Maybe IDType)
getRecordedType Name
n = (InferState -> Maybe IDType) -> Infer (Maybe IDType)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (TypeEnv -> Maybe IDType)
-> (InferState -> TypeEnv) -> InferState -> Maybe IDType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InferState -> TypeEnv
environ)
getExprRecordedType :: Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType :: forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_)) = Name -> Infer (Maybe IDType)
getRecordedType (Name -> Infer (Maybe IDType)) -> Name -> Infer (Maybe IDType)
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e
getExprRecordedType (ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
base AList Index (Analysis a)
_) = do
Maybe IDType
mTy <- Expression (Analysis a) -> Infer (Maybe IDType)
forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType Expression (Analysis a)
base
case Maybe IDType
mTy of
Just (IDType Maybe SemType
semTy (Just CTArray{})) -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IDType -> Infer (Maybe IDType))
-> (IDType -> Maybe IDType) -> IDType -> Infer (Maybe IDType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IDType -> Maybe IDType
forall a. a -> Maybe a
Just (IDType -> Infer (Maybe IDType)) -> IDType -> Infer (Maybe IDType)
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
semTy (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
CTVariable)
Maybe IDType
_ -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
forall a. Maybe a
Nothing
getExprRecordedType (ExpDataRef Analysis a
_ SrcSpan
_ Expression (Analysis a)
base Expression (Analysis a)
ref) = do
Maybe IDType
mTy <- Expression (Analysis a) -> Infer (Maybe IDType)
forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType Expression (Analysis a)
base
case Maybe IDType
mTy of
Just (IDType (Just (TCustom Name
n)) Maybe ConstructType
_) -> do
Maybe TypeEnv
mStructEnv <- (InferState -> Maybe TypeEnv)
-> StateT InferState Identity (Maybe TypeEnv)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Name -> StructTypeEnv -> Maybe TypeEnv
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (StructTypeEnv -> Maybe TypeEnv)
-> (InferState -> StructTypeEnv) -> InferState -> Maybe TypeEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InferState -> StructTypeEnv
structs)
case Maybe TypeEnv
mStructEnv of
Maybe TypeEnv
Nothing -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
forall a. Maybe a
Nothing
Just TypeEnv
env -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IDType -> Infer (Maybe IDType))
-> Maybe IDType -> Infer (Maybe IDType)
forall a b. (a -> b) -> a -> b
$ Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
ref) TypeEnv
env
Maybe IDType
x -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
x
getExprRecordedType Expression (Analysis a)
_ = Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
forall a. Maybe a
Nothing
setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a)
setIDType :: forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType IDType
ty f (Analysis a)
x =
let a :: Analysis a
a = f (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation f (Analysis a)
x
in Analysis a -> f (Analysis a) -> f (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { idType :: Maybe IDType
idType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just IDType
ty }) f (Analysis a)
x
getIDType :: (Annotated f, Data a) => f (Analysis a) -> Maybe IDType
getIDType :: forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType f (Analysis a)
x = Analysis a -> Maybe IDType
forall a. Analysis a -> Maybe IDType
idType (f (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation f (Analysis a)
x)
setSemType :: (Annotated f, Data a) => SemType -> f (Analysis a) -> f (Analysis a)
setSemType :: forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType SemType
st f (Analysis a)
x =
let anno :: Analysis a
anno = f (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation f (Analysis a)
x
idt :: Maybe IDType
idt = Analysis a -> Maybe IDType
forall a. Analysis a -> Maybe IDType
idType Analysis a
anno
anno' :: Analysis a
anno' = Analysis a
anno { idType :: Maybe IDType
idType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just (Maybe IDType -> IDType
setIDTypeSemType Maybe IDType
idt) }
in Analysis a -> f (Analysis a) -> f (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation Analysis a
anno' f (Analysis a)
x
where
setIDTypeSemType :: Maybe IDType -> IDType
setIDTypeSemType :: Maybe IDType -> IDType
setIDTypeSemType (Just (IDType Maybe SemType
_ Maybe ConstructType
mCt)) = Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
mCt
setIDTypeSemType Maybe IDType
Nothing = Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
forall a. Maybe a
Nothing
type UniFunc f g a = f (Analysis a) -> [g (Analysis a)]
allProgramUnits :: Data a => UniFunc ProgramFile ProgramUnit a
allProgramUnits :: forall a. Data a => UniFunc ProgramFile ProgramUnit a
allProgramUnits = ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi
allDeclarators :: Data a => UniFunc ProgramFile Declarator a
allDeclarators :: forall a. Data a => UniFunc ProgramFile Declarator a
allDeclarators = ProgramFile (Analysis a) -> [Declarator (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi
allStatements :: (Data a, Data (f (Analysis a))) => UniFunc f Statement a
allStatements :: forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements = f (Analysis a) -> [Statement (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi
allExpressions :: (Data a, Data (f (Analysis a))) => UniFunc f Expression a
allExpressions :: forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Expression a
allExpressions = f (Analysis a) -> [Expression (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi
isAttrDimension :: Attribute a -> Bool
isAttrDimension :: forall a. Attribute a -> Bool
isAttrDimension AttrDimension {} = Bool
True
isAttrDimension Attribute a
_ = Bool
False
isAttrParameter :: Attribute a -> Bool
isAttrParameter :: forall a. Attribute a -> Bool
isAttrParameter AttrParameter {} = Bool
True
isAttrParameter Attribute a
_ = Bool
False
isAttrExternal :: Attribute a -> Bool
isAttrExternal :: forall a. Attribute a -> Bool
isAttrExternal AttrExternal {} = Bool
True
isAttrExternal Attribute a
_ = Bool
False
isIxSingle :: Index a -> Bool
isIxSingle :: forall a. Index a -> Bool
isIxSingle IxSingle {} = Bool
True
isIxSingle Index a
_ = Bool
False
deriveSemTypeFromDeclaration
:: SrcSpan -> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> Infer SemType
deriveSemTypeFromDeclaration :: forall a.
SrcSpan
-> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> Infer SemType
deriveSemTypeFromDeclaration SrcSpan
stmtSs SrcSpan
declSs ts :: TypeSpec a
ts@(TypeSpec a
_ SrcSpan
_ BaseType
bt Maybe (Selector a)
mSel) Maybe (Expression a)
mLenExpr =
case Maybe (Expression a)
mLenExpr of
Maybe (Expression a)
Nothing ->
TypeSpec a -> Infer SemType
forall a. TypeSpec a -> Infer SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts
Just Expression a
lenExpr ->
case BaseType
bt of
BaseType
TypeCharacter -> Expression a -> Infer SemType
deriveCharWithLen Expression a
lenExpr
BaseType
_ -> do
(Name -> SrcSpan -> StateT InferState Identity ())
-> SrcSpan -> Name -> StateT InferState Identity ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> StateT InferState Identity ()
typeError SrcSpan
declSs (Name -> StateT InferState Identity ())
-> Name -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$
Name
"non-CHARACTER variable at declaration "
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
stmtSs
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" given a length"
TypeSpec a -> Infer SemType
forall a. TypeSpec a -> Infer SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts
where
deriveCharWithLen :: Expression a -> Infer SemType
deriveCharWithLen Expression a
lenExpr =
case Maybe (Selector a)
mSel of
Just (Selector a
selA SrcSpan
selSs Maybe (Expression a)
mSelLenExpr Maybe (Expression a)
mKindExpr) -> do
()
_ <- case Maybe (Expression a)
mSelLenExpr of
Just Expression a
_ -> do
(Name -> SrcSpan -> StateT InferState Identity ())
-> SrcSpan -> Name -> StateT InferState Identity ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> StateT InferState Identity ()
typeError SrcSpan
declSs (Name -> StateT InferState Identity ())
-> Name -> StateT InferState Identity ()
forall a b. (a -> b) -> a -> b
$
Name
"warning: CHARACTER variable at declaration "
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
stmtSs
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" has length in LHS type spec and RHS declarator"
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" -- specific RHS declarator overrides"
Maybe (Expression a)
_ -> () -> StateT InferState Identity ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
let sel' :: Selector a
sel' = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
Selector a
selA SrcSpan
selSs (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
lenExpr) Maybe (Expression a)
mKindExpr
BaseType -> Selector a -> Infer SemType
forall a. BaseType -> Selector a -> Infer SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
TypeCharacter Selector a
sel'
Maybe (Selector a)
Nothing ->
let (TCharacter CharacterLen
_ Kind
k) = BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeCharacter
in SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> Infer SemType) -> SemType -> Infer SemType
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> SemType
TCharacter (Expression a -> CharacterLen
forall a. Expression a -> CharacterLen
charLenSelector' Expression a
lenExpr) Kind
k
deriveSemTypeFromTypeSpec :: TypeSpec a -> Infer SemType
deriveSemTypeFromTypeSpec :: forall a. TypeSpec a -> Infer SemType
deriveSemTypeFromTypeSpec (TypeSpec a
_ SrcSpan
_ BaseType
bt Maybe (Selector a)
mSel) =
case Maybe (Selector a)
mSel of
Just Selector a
sel -> BaseType -> Selector a -> Infer SemType
forall a. BaseType -> Selector a -> Infer SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
bt Selector a
sel
Maybe (Selector a)
Nothing -> SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> Infer SemType) -> SemType -> Infer SemType
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt
deriveSemTypeFromBaseTypeAndSelector :: BaseType -> Selector a -> Infer SemType
deriveSemTypeFromBaseTypeAndSelector :: forall a. BaseType -> Selector a -> Infer SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
bt (Selector a
_ SrcSpan
ss Maybe (Expression a)
mLen Maybe (Expression a)
mKindExpr) = do
SemType
st <- Maybe (Expression a) -> Infer SemType
forall a. Maybe (Expression a) -> Infer SemType
deriveFromBaseTypeAndKindExpr Maybe (Expression a)
mKindExpr
case Maybe (Expression a)
mLen of
Maybe (Expression a)
Nothing -> SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return SemType
st
Just Expression a
lenExpr ->
case SemType
st of
TCharacter CharacterLen
_ Kind
kind ->
let charLen :: CharacterLen
charLen = Expression a -> CharacterLen
forall a. Expression a -> CharacterLen
charLenSelector' Expression a
lenExpr
in SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> Infer SemType) -> SemType -> Infer SemType
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> SemType
TCharacter CharacterLen
charLen Kind
kind
SemType
_ -> do
Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"only CHARACTER types can specify length (separate to kind)" SrcSpan
ss
SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return SemType
st
where
deriveFromBaseTypeAndKindExpr :: Maybe (Expression a) -> Infer SemType
deriveFromBaseTypeAndKindExpr :: forall a. Maybe (Expression a) -> Infer SemType
deriveFromBaseTypeAndKindExpr = \case
Maybe (Expression a)
Nothing -> Infer SemType
defaultSemType
Just Expression a
kindExpr ->
case Expression a
kindExpr of
ExpValue a
_ SrcSpan
_ (ValInteger Name
k) ->
BaseType -> Kind -> Infer SemType
deriveSemTypeFromBaseTypeAndKind BaseType
bt (Name -> Kind
forall a. Read a => Name -> a
read Name
k)
Expression a
_ -> do
Name -> SrcSpan -> StateT InferState Identity ()
typeError Name
"unsupported or invalid kind selector, only literal integers allowed" (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
kindExpr)
Infer SemType
defaultSemType
defaultSemType :: Infer SemType
defaultSemType = SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> Infer SemType) -> SemType -> Infer SemType
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt
deriveSemTypeFromBaseType :: BaseType -> SemType
deriveSemTypeFromBaseType :: BaseType -> SemType
deriveSemTypeFromBaseType = \case
BaseType
TypeInteger -> Kind -> SemType
TInteger Kind
4
BaseType
TypeReal -> Kind -> SemType
TReal Kind
4
BaseType
TypeComplex -> Kind -> SemType
TComplex Kind
4
BaseType
TypeLogical -> Kind -> SemType
TLogical Kind
4
BaseType
TypeDoublePrecision -> Kind -> SemType
TReal Kind
8
BaseType
TypeDoubleComplex -> Kind -> SemType
TComplex Kind
8
BaseType
TypeByte -> Kind -> SemType
TByte Kind
noKind
BaseType
TypeCharacter -> CharacterLen -> Kind -> SemType
TCharacter (Kind -> CharacterLen
CharLenInt Kind
1) Kind
1
BaseType
ClassStar -> Name -> SemType
TCustom Name
"ClassStar"
TypeCustom Name
str -> Name -> SemType
TCustom Name
str
ClassCustom Name
str -> Name -> SemType
TCustom Name
str
noKind :: Kind
noKind :: Kind
noKind = -Kind
1
deriveSemTypeFromBaseTypeAndKind :: BaseType -> Kind -> Infer SemType
deriveSemTypeFromBaseTypeAndKind :: BaseType -> Kind -> Infer SemType
deriveSemTypeFromBaseTypeAndKind BaseType
bt Kind
k =
SemType -> Infer SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> Infer SemType) -> SemType -> Infer SemType
forall a b. (a -> b) -> a -> b
$ SemType -> Kind -> SemType
setTypeKind (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt) Kind
k