{-# LANGUAGE ScopedTypeVariables #-}
module Language.Fortran.Analysis.Types
( analyseTypes
, analyseTypesWithEnv
, analyseAndCheckTypesWithEnv
, extractTypeEnv
, TypeEnv
, TypeError
, deriveSemTypeFromDeclaration
, deriveSemTypeFromTypeSpec
, deriveSemTypeFromBaseType
, runInfer
, inferState0
) where
import Language.Fortran.AST
import Language.Fortran.AST.RealLit
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 Control.Monad.Reader
import Data.Generics.Uniplate.Data
import Data.Data
import Language.Fortran.Analysis
import Language.Fortran.Analysis.SemanticTypes
import Language.Fortran.Intrinsics
import Language.Fortran.Util.Position
import Language.Fortran.Version (FortranVersion(..))
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 = StateT InferState (Reader InferConfig) 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
data InferConfig = InferConfig
{ InferConfig -> Bool
inferConfigAcceptNonCharLengthAsKind :: Bool
} deriving (InferConfig -> InferConfig -> Bool
(InferConfig -> InferConfig -> Bool)
-> (InferConfig -> InferConfig -> Bool) -> Eq InferConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InferConfig -> InferConfig -> Bool
$c/= :: InferConfig -> InferConfig -> Bool
== :: InferConfig -> InferConfig -> Bool
$c== :: InferConfig -> InferConfig -> Bool
Eq, Kind -> InferConfig -> ShowS
[InferConfig] -> ShowS
InferConfig -> Name
(Kind -> InferConfig -> ShowS)
-> (InferConfig -> Name)
-> ([InferConfig] -> ShowS)
-> Show InferConfig
forall a.
(Kind -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [InferConfig] -> ShowS
$cshowList :: [InferConfig] -> ShowS
show :: InferConfig -> Name
$cshow :: InferConfig -> Name
showsPrec :: Kind -> InferConfig -> ShowS
$cshowsPrec :: Kind -> InferConfig -> 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
-> Infer (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState)
forall a. FortranVersion -> TypeEnv -> Infer a -> (a, InferState)
runInfer (MetaInfo -> FortranVersion
miVersion MetaInfo
mi) TypeEnv
env (Infer (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState))
-> Infer (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState)
forall a b. (a -> b) -> a -> b
$ do
(Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> [Expression (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> [ProgramUnit (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgramUnit (Analysis a)
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> [Declarator (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Declarator (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall a. Data a => InferFunc (Declarator (Analysis a))
recordArrayDecl (UniFunc ProgramFile Declarator a
forall a. Data a => UniFunc ProgramFile Declarator a
allDeclarators ProgramFile (Analysis a)
pf)
(Statement (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> [Statement (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Statement (Analysis a) -> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) [(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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ())
-> ((Name, (Name, Maybe Name))
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
recordMType Maybe SemType
fVType Maybe ConstructType
fCType Name
eName
StateT InferState (Reader InferConfig) ()
-> (Name -> StateT InferState (Reader InferConfig) ())
-> Maybe Name
-> StateT InferState (Reader InferConfig) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> Name
-> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> Maybe ConstructType
-> Name
-> StateT InferState (Reader InferConfig) ()
recordMType Maybe SemType
fVType Maybe ConstructType
forall a. Maybe a
Nothing) Maybe Name
mRetName
Maybe IDType
_ -> () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ProgramFile (Analysis a) -> Infer (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 (Reader InferConfig) (Expression (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT
InferState (Reader InferConfig) (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 (Reader InferConfig) (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a) -> Infer (Expression (Analysis a))
annotateExpression ProgramFile (Analysis a)
pf StateT InferState (Reader InferConfig) (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a)
-> StateT
InferState (Reader InferConfig) (ProgramFile (Analysis a)))
-> StateT
InferState (Reader InferConfig) (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 (Reader InferConfig) (ProgramUnit (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT
InferState (Reader InferConfig) (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 (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *) a.
MonadState InferState m =>
Expression (Analysis a) -> m ()
intrinsicsHelper Expression (Analysis a)
nexp
intrinsicsExp (ExpFunctionCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
nexp Maybe (AList Argument (Analysis a))
_) = Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a.
MonadState InferState m =>
Expression (Analysis a) -> m ()
intrinsicsHelper Expression (Analysis a)
nexp
intrinsicsExp Expression (Analysis a)
_ = () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
intrinsicsHelper :: MonadState InferState m => Expression (Analysis a) -> m ()
intrinsicsHelper :: forall (m :: * -> *) a.
MonadState InferState m =>
Expression (Analysis a) -> m ()
intrinsicsHelper Expression (Analysis a)
nexp | Expression (Analysis a) -> Bool
forall a. Expression a -> Bool
isNamedExpression Expression (Analysis a)
nexp = do
IntrinsicsTable
itab <- (InferState -> IntrinsicsTable) -> m 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 -> m ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTIntrinsic Name
n
Maybe IntrinsicType
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
intrinsicsHelper Expression (Analysis a)
_ = () -> m ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
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)
-> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec (Analysis a)
ts
SemType -> Name -> StateT InferState (Reader InferConfig) ()
recordSemType SemType
semType Name
n StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SemType -> Name -> StateT InferState (Reader InferConfig) ()
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)
-> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec (Analysis a)
ts
SemType -> Name -> StateT InferState (Reader InferConfig) ()
recordSemType SemType
semType Name
n
(Maybe (TypeSpec (Analysis a)), Maybe (Expression (Analysis a)))
_ -> () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[Block (Analysis a)]
-> (Block (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ())
-> (Block (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ Block (Analysis a)
block ->
[StateT InferState (Reader InferConfig) ()]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Name
-> Name -> Maybe Name -> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTSubroutine Name
n
[Block (Analysis a)]
-> (Block (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ())
-> (Block (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ Block (Analysis a)
block ->
[StateT InferState (Reader InferConfig) ()]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Name
-> Name -> Maybe Name -> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
recordArrayDecl :: Data a => InferFunc (Declarator (Analysis a))
recordArrayDecl :: forall a. Data a => InferFunc (Declarator (Analysis a))
recordArrayDecl (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v (ArrayDecl AList DimensionDeclarator (Analysis a)
ddAList) Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_) =
ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
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)
recordArrayDecl Declarator (Analysis a)
_ = () -> StateT InferState (Reader InferConfig) ()
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)
_) <- 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)
_) <- 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) -> m [(Name, SemType, ConstructType)]
handler [(Name, SemType, ConstructType)]
rs = \case
Declarator Analysis a
_ SrcSpan
declSs Expression (Analysis a)
v DeclaratorType (Analysis a)
mDdAList Maybe (Expression (Analysis a))
mLenExpr Maybe (Expression (Analysis a))
_ -> do
SemType
st <- SrcSpan
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> m SemType
forall (m :: * -> *) a.
(MonadState InferState m, MonadReader InferConfig m) =>
SrcSpan
-> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m 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
ct :: ConstructType
ct = case DeclaratorType (Analysis a)
mDdAList of
DeclaratorType (Analysis a)
ScalarDecl -> Name -> ConstructType
cType Name
n
ArrayDecl AList DimensionDeclarator (Analysis a)
dims -> [(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)
dims
[(Name, SemType, ConstructType)]
-> m [(Name, SemType, ConstructType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, SemType, ConstructType)]
-> m [(Name, SemType, ConstructType)])
-> [(Name, SemType, ConstructType)]
-> m [(Name, SemType, ConstructType)]
forall a b. (a -> b) -> a -> b
$ (Name
n, SemType
st, ConstructType
ct) (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)]
forall {m :: * -> *}.
(MonadState InferState m, MonadReader InferConfig m) =>
[(Name, SemType, ConstructType)]
-> Declarator (Analysis a) -> m [(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 (Reader InferConfig) ()
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 (Reader InferConfig) ()
recordStruct TypeEnv
structEnv Name
n
Maybe Name
Nothing -> () -> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ())
-> ((Name, SemType, ConstructType)
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \(Name
n, SemType
b, ConstructType
c) -> SemType
-> ConstructType
-> Name
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> [Expression (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTExternal (Name -> StateT InferState (Reader InferConfig) ())
-> (Expression (Analysis a) -> Name)
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe IDType
_ -> ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ())
-> (Declarator (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ Declarator (Analysis a)
decl -> case Declarator (Analysis a)
decl of
Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v (ArrayDecl AList DimensionDeclarator (Analysis a)
ddAList) Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ ->
ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
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 (Reader InferConfig) ()
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 (Reader InferConfig) ()
forall a.
Data a =>
Maybe Name
-> AList StructureItem (Analysis a)
-> StateT InferState (Reader InferConfig) ()
handleStructure Maybe Name
mName AList StructureItem (Analysis a)
itemAList
statement Statement (Analysis a)
_ = () -> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) (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 (Reader InferConfig) (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 RealLit
r Maybe (Expression (Analysis a))
mkp)) = do
Kind
k <- SrcSpan -> RealLit -> Maybe (Expression (Analysis a)) -> Infer Kind
forall a. SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind SrcSpan
ss RealLit
r Maybe (Expression (Analysis a))
mkp
Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT
InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (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)
-> StateT InferState (Reader InferConfig) SemType
forall a.
SrcSpan
-> Expression a
-> Expression a
-> StateT InferState (Reader InferConfig) SemType
complexLiteralType SrcSpan
ss Expression (Analysis a)
e1 Expression (Analysis a)
e2
Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT
InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (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{}) =
Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT
InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (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{})) =
Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
-> StateT
InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> BinaryOp
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> AList Index (Analysis a)
-> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> Maybe (AList Argument (Analysis a))
-> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) (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 (Reader InferConfig) (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 (Reader InferConfig) (ProgramUnit (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return ProgramUnit (Analysis a)
pu
deriveRealLiteralKind :: SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind :: forall a. SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind SrcSpan
ss RealLit
r Maybe (Expression a)
mkp =
case Maybe (Expression a)
mkp of
Maybe (Expression a)
Nothing -> case Exponent -> ExponentLetter
exponentLetter (RealLit -> Exponent
realLitExponent RealLit
r) of
ExponentLetter
ExpLetterE -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
4
ExponentLetter
ExpLetterD -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
8
ExponentLetter
ExpLetterQ -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
16
Just Expression a
_ -> case Exponent -> ExponentLetter
exponentLetter (RealLit -> Exponent
realLitExponent RealLit
r) of
ExponentLetter
ExpLetterE -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
0
ExponentLetter
_ -> do
Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError (Name
"only real literals with exponent letter 'e'"
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
"can specify explicit kind parameter") SrcSpan
ss
Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
0
complexLiteralType :: SrcSpan -> Expression a -> Expression a -> Infer SemType
complexLiteralType :: forall a.
SrcSpan
-> Expression a
-> Expression a
-> StateT InferState (Reader InferConfig) SemType
complexLiteralType SrcSpan
ss (ExpValue a
_ SrcSpan
_ (ValReal RealLit
r Maybe (Expression a)
mkp)) Expression a
_ = do
Kind
k1 <- SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
forall a. SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind SrcSpan
ss RealLit
r Maybe (Expression a)
mkp
SemType -> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> StateT InferState (Reader InferConfig) SemType)
-> SemType -> StateT InferState (Reader InferConfig) SemType
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k1
complexLiteralType SrcSpan
_ Expression a
_ Expression a
_ = SemType -> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> StateT InferState (Reader InferConfig) SemType)
-> SemType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) 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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
(Maybe SemType
Nothing, Maybe SemType
_) -> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom binary ops not supported" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
Maybe SemType
_ -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k2
(TComplex Kind
k1, SemType
_ ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k1
(SemType
_ , TReal Kind
k2) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TReal Kind
k2
(TReal Kind
k1, SemType
_ ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TReal Kind
k1
(SemType
_ , TInteger Kind
k2) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TInteger Kind
k2
(TInteger Kind
k1, SemType
_ ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TInteger Kind
k1
(TByte Kind
k1, TByte Kind
_ ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TByte Kind
k1
(TLogical Kind
k1, TLogical Kind
_ ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TLogical Kind
k1
(TCustom Name
_, TCustom Name
_) -> do
Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom types / binary op not supported" SrcSpan
ss
Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"operation on character strings of different kinds" SrcSpan
ss
Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeLogical
| Bool
otherwise -> do Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Invalid op on character strings" SrcSpan
ss
Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Type error between operands of binary operator" SrcSpan
ss
Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
where
ret :: a -> StateT InferState (Reader InferConfig) (Maybe a)
ret = Maybe a -> StateT InferState (Reader InferConfig) (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> StateT InferState (Reader InferConfig) (Maybe a))
-> (a -> Maybe a)
-> a
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) 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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Unable to obtain type for" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom types / unary ops not supported" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom unary ops not supported" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Type error for unary operator" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) 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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ())
-> (Index (Analysis a)
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) ()
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 (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
ty
Maybe IDType
_ -> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) 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 (Reader InferConfig) 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 (Reader InferConfig) 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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeReal
IntrinsicType
ITInteger -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeInteger
IntrinsicType
ITComplex -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeComplex
IntrinsicType
ITDouble -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeDoublePrecision
IntrinsicType
ITLogical -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeLogical
IntrinsicType
ITCharacter -> BaseType -> StateT InferState (Reader InferConfig) (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
_ ArgumentExpression (Analysis a)
ae <- [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 (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (ArgumentExpression (Analysis a) -> Expression (Analysis a)
forall a. ArgumentExpression a -> Expression a
argExprNormalize ArgumentExpression (Analysis a)
ae)
| Bool
otherwise -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
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 (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (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 (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
Just SemType
_ -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) 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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"non-function invoked by call" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IDType -> StateT InferState (Reader InferConfig) 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 = []
}
inferConfig0 :: InferConfig
inferConfig0 :: InferConfig
inferConfig0 = InferConfig :: Bool -> InferConfig
InferConfig
{ inferConfigAcceptNonCharLengthAsKind :: Bool
inferConfigAcceptNonCharLengthAsKind = Bool
True
}
runInfer :: FortranVersion -> TypeEnv -> Infer a -> (a, InferState)
runInfer :: forall a. FortranVersion -> TypeEnv -> Infer a -> (a, InferState)
runInfer FortranVersion
v TypeEnv
env Infer a
f = (Reader InferConfig (a, InferState)
-> InferConfig -> (a, InferState))
-> InferConfig
-> Reader InferConfig (a, InferState)
-> (a, InferState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader InferConfig (a, InferState)
-> InferConfig -> (a, InferState)
forall r a. Reader r a -> r -> a
runReader InferConfig
inferConfig0 (Reader InferConfig (a, InferState) -> (a, InferState))
-> Reader InferConfig (a, InferState) -> (a, InferState)
forall a b. (a -> b) -> a -> b
$ (Infer a -> InferState -> Reader InferConfig (a, InferState))
-> InferState -> Infer a -> Reader InferConfig (a, InferState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Infer a -> InferState -> Reader InferConfig (a, InferState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((FortranVersion -> InferState
inferState0 FortranVersion
v) { environ :: TypeEnv
environ = TypeEnv
env }) Infer a
f
typeError :: MonadState InferState m => String -> SrcSpan -> m ()
typeError :: forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
msg SrcSpan
ss = (InferState -> InferState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> m ())
-> (InferState -> InferState) -> m ()
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 (Reader InferConfig) ()
recordType SemType
st ConstructType
ct Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
-> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
recordStruct TypeEnv
mt Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
-> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
recordMType Maybe SemType
st Maybe ConstructType
ct Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
-> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
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 :: MonadState InferState m => ConstructType -> Name -> m ()
recordCType :: forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
ct Name
n = (InferState -> InferState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> m ())
-> (InferState -> InferState) -> m ()
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 (Reader InferConfig) ()
recordSemType SemType
st Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
-> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) ()
recordEntryPoint Name
fn Name
en Maybe Name
mRetName = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
-> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
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 (Reader InferConfig) (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
:: (MonadState InferState m, MonadReader InferConfig m)
=> SrcSpan -> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m SemType
deriveSemTypeFromDeclaration :: forall (m :: * -> *) a.
(MonadState InferState m, MonadReader InferConfig m) =>
SrcSpan
-> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m SemType
deriveSemTypeFromDeclaration SrcSpan
stmtSs SrcSpan
declSs ts :: TypeSpec a
ts@(TypeSpec a
tsA SrcSpan
tsSS BaseType
bt Maybe (Selector a)
mSel) Maybe (Expression a)
mLenExpr =
case Maybe (Expression a)
mLenExpr of
Maybe (Expression a)
Nothing ->
TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts
Just Expression a
lenExpr ->
case BaseType
bt of
BaseType
TypeCharacter -> Expression a -> m SemType
forall {m :: * -> *}.
MonadState InferState m =>
Expression a -> m SemType
deriveCharWithLen Expression a
lenExpr
BaseType
_ -> do
(InferConfig -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks InferConfig -> Bool
inferConfigAcceptNonCharLengthAsKind m Bool -> (Bool -> m SemType) -> m SemType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> do
(Name -> SrcSpan -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
Name
"non-CHARACTER variable given a length @ "
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
lenExpr)
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
": ignoring"
TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts
Bool
True -> do
(Name -> SrcSpan -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
Name
"non-CHARACTER variable given a length @ "
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
lenExpr)
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
": treating as nonstandard kind parameter syntax"
case Maybe (Selector a)
mSel of
Just (Selector a
sA SrcSpan
sSS Maybe (Expression a)
sLen Maybe (Expression a)
sMKpExpr) -> do
()
_ <- case Maybe (Expression a)
sMKpExpr of
Maybe (Expression a)
Nothing -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Expression a
kpExpr -> do
(Name -> SrcSpan -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
Name
"non-CHARACTER variable"
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" given both"
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" LHS kind @ " Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
kpExpr) Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" and"
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" nonstandard RHS kind @ " Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
lenExpr)
Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
": specific RHS declarator overrides"
() -> m ()
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
sA SrcSpan
sSS Maybe (Expression a)
sLen (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
lenExpr)
ts' :: TypeSpec a
ts' = a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
TypeSpec a
tsA SrcSpan
tsSS BaseType
bt (Selector a -> Maybe (Selector a)
forall a. a -> Maybe a
Just Selector a
sel)
in TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts'
Maybe (Selector a)
Nothing ->
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
forall a. HasCallStack => a
undefined SrcSpan
forall a. HasCallStack => a
undefined Maybe (Expression a)
forall a. Maybe a
Nothing (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
lenExpr)
ts' :: TypeSpec a
ts' = a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
TypeSpec a
tsA SrcSpan
tsSS BaseType
bt (Selector a -> Maybe (Selector a)
forall a. a -> Maybe a
Just Selector a
sel)
in TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts'
where
deriveCharWithLen :: Expression a -> m 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 -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
Name
"warning: CHARACTER variable @ " Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
declSs
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)
_ -> () -> m ()
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 -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
BaseType -> Selector a -> m SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
TypeCharacter Selector a
sel'
Maybe (Selector a)
Nothing ->
let (TCharacter CharacterLen
_ Kind
k) = BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeCharacter
in SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m 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
:: MonadState InferState m => TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec :: forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec (TypeSpec a
_ SrcSpan
_ BaseType
bt Maybe (Selector a)
mSel) =
case Maybe (Selector a)
mSel of
Just Selector a
sel -> BaseType -> Selector a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
BaseType -> Selector a -> m SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
bt Selector a
sel
Maybe (Selector a)
Nothing -> SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt
deriveSemTypeFromBaseTypeAndSelector
:: MonadState InferState m => BaseType -> Selector a -> m SemType
deriveSemTypeFromBaseTypeAndSelector :: forall (m :: * -> *) a.
MonadState InferState m =>
BaseType -> Selector a -> m SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
bt (Selector a
_ SrcSpan
ss Maybe (Expression a)
mLen Maybe (Expression a)
mKindExpr) = do
SemType
st <- Maybe (Expression a) -> m SemType
forall {a}. Maybe (Expression a) -> m SemType
deriveFromBaseTypeAndKindExpr Maybe (Expression a)
mKindExpr
case Maybe (Expression a)
mLen of
Maybe (Expression a)
Nothing -> SemType -> m 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 -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> SemType
TCharacter CharacterLen
charLen Kind
kind
SemType
_ -> do
Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"only CHARACTER types can specify length (separate to kind)" SrcSpan
ss
SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return SemType
st
where
deriveFromBaseTypeAndKindExpr :: Maybe (Expression a) -> m SemType
deriveFromBaseTypeAndKindExpr = \case
Maybe (Expression a)
Nothing -> m SemType
defaultSemType
Just Expression a
kindExpr ->
case Expression a
kindExpr of
ExpValue a
_ SrcSpan
_ (ValInteger Name
k Maybe (Expression a)
_) ->
BaseType -> Kind -> m SemType
forall (m :: * -> *).
MonadState InferState m =>
BaseType -> Kind -> m SemType
deriveSemTypeFromBaseTypeAndKind BaseType
bt (Name -> Kind
forall a. Read a => Name -> a
read Name
k)
Expression a
_ -> do
Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"unsupported or invalid kind selector, only literal integers allowed" (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
kindExpr)
m SemType
defaultSemType
defaultSemType :: m SemType
defaultSemType = SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m 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
:: MonadState InferState m => BaseType -> Kind -> m SemType
deriveSemTypeFromBaseTypeAndKind :: forall (m :: * -> *).
MonadState InferState m =>
BaseType -> Kind -> m SemType
deriveSemTypeFromBaseTypeAndKind BaseType
bt Kind
k =
SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ SemType -> Kind -> SemType
setTypeKind (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt) Kind
k