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