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

--------------------------------------------------

-- | Mapping of names to type information.
type TypeEnv = M.Map Name IDType

-- | Information about a detected type error.
type TypeError = (String, SrcSpan)

--------------------------------------------------

-- Monad for type inference work
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 ()

--------------------------------------------------

-- | Annotate AST nodes with type information and also return a type
-- environment mapping names to type information.
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

-- | Annotate AST nodes with type information and also return a type
-- environment mapping names to type information; provided with a
-- starting type environment.
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

-- | Annotate AST nodes with type information, return a type
-- environment mapping names to type information and return any type
-- errors found; provided with a starting type environment.
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
  -- Gather information.
  (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)

  -- Gather types for known entry points.
  [(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
        -- FIXME: what about functions that return arrays?
        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              -- Annotate AST nodes with their types.

extractTypeEnv :: forall a. Data a => ProgramFile (Analysis a) -> TypeEnv
extractTypeEnv :: ProgramFile (Analysis a) -> TypeEnv
extractTypeEnv 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
      -- recordBaseType _  n -- FIXME: going to skip base types for the moment
    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
    -- record some type information that we can glean
    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 ()
    -- record entry points for later annotation
    [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
  -- record the fact that this is a subroutine
  ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTSubroutine Name
n
  -- record entry points for later annotation
  [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)
_)
  --  | any (not . isIxSingle) (aStrip ixAList) = recordCType CTArray (varName v)  -- it's an array (or a string?) FIXME
  | (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 ()                -- do nothing, it's already known to be an array
      Maybe IDType
_                                -> ConstructType -> Name -> StateT InferState Identity ()
recordCType ConstructType
CTFunction Name
n -- assume it's a function statement

-- FIXME: if StFunctions can only be identified after types analysis
-- is complete and disambiguation is performed, then how do we get
-- them in the first place? (iterate until fixed point?)
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)
-- (part of answer to above is) nullary function statement: foo() = ...
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))

-- handle the various literals
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
_))     =
    -- FIXME: in >F90, int lits can have kind info on end @_8@, same as real
    -- lits. We do parse this into the lit string, it is available to us.
    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

-- | Derive the kind of a REAL literal constant.
--
-- Logic taken from HP's F90 reference pg.33, written to gfortran's behaviour.
-- Stays in the 'Infer' monad so it can report type errors
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  -- no exponent, use kind param
          Just Exponent
expo ->
            -- can only use kind param with 'e' or no exponent
            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
                -- badly formed literal, but we'll allow and use the provided
                -- kind param (with no doubling or anything)
                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
          -- no exponent: select default real kind
          Maybe Exponent
Nothing             -> Int
4
          Just Exponent
expo           ->
            case Exponent -> ExponentLetter
expLetter Exponent
expo of
              ExponentLetter
ExpLetterE -> Int
4
              ExponentLetter
ExpLetterD -> Int
8

-- | Get the type of a COMPLEX literal constant.
--
-- The kind is derived only from the first expression, the second is ignored.
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 -- FIXME: might have to check kinds of each operand

-- | Combine two 'SemType's with a 'BinaryOp'.
--
-- No real work done here, no kind combining, just selection.
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 -- FIXME: might have to check kind of operand

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

--------------------------------------------------
-- Monadic helper combinators.

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

-- Record the type of the given name.
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) }

-- Record the type (maybe) of the given name.
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) }

-- Record the CType of the given name.
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))

-- Record the SemType of the given name.
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)

-- Set the idType annotation
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

-- Get the idType annotation
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)

-- | For all types holding an 'IDType' (in an 'Analysis'), set the 'SemType'
--   field of the 'IDType'.
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

-- Set the CType part of idType annotation
--setCType :: (Annotated f, Data a) => ConstructType -> f (Analysis a) -> f (Analysis a)
--setCType ct x
--  | a@(Analysis { idType = Nothing }) <- getAnnotation x = setAnnotation (a { idType = Just (IDType Nothing (Just ct)) }) x
--  | a@(Analysis { idType = Just it }) <- getAnnotation x = setAnnotation (a { idType = Just (it { idCType = Just ct }) }) x

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

--------------------------------------------------

-- Most, but not all deriving functions can report type errors. So most of these
-- functions are in the Infer monad.

-- | Attempt to derive the 'SemType' of a variable from the relevant parts of
--   its surrounding 'StDeclaration'.
--
-- This is an example of a simple declaration:
--
--     INTEGER(8) :: var_name
--
-- A declaration holds a 'TypeSpec' (left of the double colon; LHS) and a list
-- of 'Declarator's (right of the double colon; RHS). However, CHARACTER
-- variable are allowed to specify their length via special syntax on the RHS:
--
--     CHARACTER :: string*10
--
-- so to handle that, this function takes that length as a Maybe Expression (as
-- provided in 'StDeclaration').
--
-- If a length was defined on both sides, the declaration length (RHS) is used.
-- This matches gfortran's behaviour, though even with -Wall they don't warn on
-- this rather confusing syntax usage. We report a (soft) type error.
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 ->
        -- no RHS length, can continue with regular deriving
        TypeSpec a -> Infer SemType
forall a. TypeSpec a -> Infer SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts

      Just Expression a
lenExpr ->
        -- we got a RHS length; only CHARACTERs permit this
        case BaseType
bt of
          BaseType
TypeCharacter -> Expression a -> Infer SemType
deriveCharWithLen Expression a
lenExpr
          BaseType
_ -> do
            -- can't use RHS @var*length = x@ syntax on non-CHARACTER: complain,
            -- continue regular deriving without length
            (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
    -- Function called when we have a TypeCharacter and a RHS declarator length.
    -- (no function signature due to type variable scoping)
    --deriveCharWithLen :: Expression a -> Infer SemType
    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
                      -- both LHS & RHS lengths: surprising syntax, notify user
                      -- Ben has seen this IRL: a high-ranking Fortran
                      -- tutorial site uses it (2021-04-30):
                      -- http://web.archive.org/web/20210118202503/https://www.tutorialspoint.com/fortran/fortran_strings.htm
                     (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 ()
            -- overwrite the Selector with RHS length expr & continue
            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 ->
            -- got RHS len, no Selector (e.g. @CHARACTER :: x*3 = "sup"@)
            -- naughty let binding to avoid re-hardcoding default char kind
            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

-- | Attempt to derive a 'SemType' from a 'TypeSpec'.
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
      -- Selector present: we might have kind/other info provided
      Just Selector a
sel -> BaseType -> Selector a -> Infer SemType
forall a. BaseType -> Selector a -> Infer SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
bt Selector a
sel
      -- no Selector: derive using default kinds etc.
      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

-- | Attempt to derive a SemType from a 'BaseType' and a 'Selector'.
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
            -- (unreachable code path in correct parser operation)
            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
          -- FIXME: only support integer kind selectors for now, no params/exprs
          -- (would require a wide change across codebase)
          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

-- | Derive 'SemType' directly from 'BaseType', using relevant default kinds.
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

  -- Fortran specs & compilers seem to agree on equating these intrinsic types
  -- to others with a larger kind, so we drop the extra syntactic info here.
  BaseType
TypeDoublePrecision -> Int -> SemType
TReal    Int
8
  BaseType
TypeDoubleComplex   -> Int -> SemType
TComplex Int
8

  -- BYTE: HP's Fortran 90 reference says that BYTE is an HP extension, equates
  -- it to INTEGER(1), and indicates that it doesn't take a kind selector.
  -- Don't know how BYTEs are used in the wild. I wonder if we could safely
  -- equate BYTE to (TInteger 1)?
  BaseType
TypeByte            -> Int -> SemType
TByte    Int
noKind

  -- CHARACTERs default to len=1, kind=1 (non-1 is rare)
  BaseType
TypeCharacter       -> CharacterLen -> Int -> SemType
TCharacter (Int -> CharacterLen
CharLenInt Int
1) Int
1

  -- FIXME: this is where Fortran specs diverge, and fortran-vars doesn't
  -- support beyond F77e. Sticking with what passes the fortran-vars tests.
  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

--------------------------------------------------

-- Local variables:
-- mode: haskell
-- haskell-program-name: "cabal repl"
-- End: