{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE FlexibleContexts    #-}

module Language.Fortran.Analysis.Types
  ( analyseTypes
  , analyseTypesWithEnv
  , analyseAndCheckTypesWithEnv
  , extractTypeEnv
  , TypeEnv
  , TypeError
  , deriveSemTypeFromDeclaration
  , deriveSemTypeFromTypeSpec
  , deriveSemTypeFromBaseType
  , runInfer
  , inferState0
  ) where

import Language.Fortran.AST
import Language.Fortran.AST.RealLit

import Prelude hiding (lookup, EQ, LT, GT)
import Data.Map (insert)
import qualified Data.Map as M
import Data.Maybe (maybeToList)
import Data.List (find, foldl')
import Control.Monad.State.Strict
import Control.Monad.Reader
import Data.Generics.Uniplate.Data
import Data.Data
import Language.Fortran.Analysis
import Language.Fortran.Analysis.SemanticTypes
import Language.Fortran.Intrinsics
import Language.Fortran.Util.Position
import Language.Fortran.Version (FortranVersion(..))

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

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

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

-- | Mapping of structures to field types
type StructTypeEnv = M.Map Name StructMemberTypeEnv
type StructMemberTypeEnv = M.Map Name IDType

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

-- Monad for type inference work
type Infer a = StateT InferState (Reader InferConfig) a
data InferState = InferState { InferState -> FortranVersion
langVersion :: FortranVersion
                             , InferState -> IntrinsicsTable
intrinsics  :: IntrinsicsTable
                             , InferState -> TypeEnv
environ     :: TypeEnv
                             , InferState -> StructTypeEnv
structs     :: StructTypeEnv
                             , InferState -> Map Name (Name, Maybe Name)
entryPoints :: M.Map Name (Name, Maybe Name)
                             , InferState -> [TypeError]
typeErrors  :: [TypeError] }
  deriving Kind -> InferState -> ShowS
[InferState] -> ShowS
InferState -> Name
(Kind -> InferState -> ShowS)
-> (InferState -> Name)
-> ([InferState] -> ShowS)
-> Show InferState
forall a.
(Kind -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [InferState] -> ShowS
$cshowList :: [InferState] -> ShowS
show :: InferState -> Name
$cshow :: InferState -> Name
showsPrec :: Kind -> InferState -> ShowS
$cshowsPrec :: Kind -> InferState -> ShowS
Show
data InferConfig = InferConfig
  { InferConfig -> Bool
inferConfigAcceptNonCharLengthAsKind :: Bool
  -- ^ How to handle declarations like @INTEGER x*8@. If true, providing a
  --   character length for a non-character data type will treat it as a kind
  --   parameter. In both cases, a warning is logged (nonstandard syntax).
  } deriving (InferConfig -> InferConfig -> Bool
(InferConfig -> InferConfig -> Bool)
-> (InferConfig -> InferConfig -> Bool) -> Eq InferConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InferConfig -> InferConfig -> Bool
$c/= :: InferConfig -> InferConfig -> Bool
== :: InferConfig -> InferConfig -> Bool
$c== :: InferConfig -> InferConfig -> Bool
Eq, Kind -> InferConfig -> ShowS
[InferConfig] -> ShowS
InferConfig -> Name
(Kind -> InferConfig -> ShowS)
-> (InferConfig -> Name)
-> ([InferConfig] -> ShowS)
-> Show InferConfig
forall a.
(Kind -> a -> ShowS) -> (a -> Name) -> ([a] -> ShowS) -> Show a
showList :: [InferConfig] -> ShowS
$cshowList :: [InferConfig] -> ShowS
show :: InferConfig -> Name
$cshow :: InferConfig -> Name
showsPrec :: Kind -> InferConfig -> ShowS
$cshowsPrec :: Kind -> InferConfig -> ShowS
Show)
type InferFunc t = t -> Infer ()

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

-- | 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 :: forall a.
Data a =>
ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypes = TypeEnv
-> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypesWithEnv TypeEnv
forall k a. Map k a
M.empty

-- | 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 :: forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), TypeEnv)
analyseTypesWithEnv TypeEnv
env ProgramFile (Analysis a)
pf = (ProgramFile (Analysis a)
pf', TypeEnv
tenv)
  where
    (ProgramFile (Analysis a)
pf', InferState
endState) = TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' TypeEnv
env ProgramFile (Analysis a)
pf
    tenv :: TypeEnv
tenv            = InferState -> TypeEnv
environ InferState
endState

-- | 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 :: forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), TypeEnv, [TypeError])
analyseAndCheckTypesWithEnv TypeEnv
env ProgramFile (Analysis a)
pf = (ProgramFile (Analysis a)
pf', TypeEnv
tenv, [TypeError]
terrs)
  where
    (ProgramFile (Analysis a)
pf', InferState
endState) = TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' TypeEnv
env ProgramFile (Analysis a)
pf
    tenv :: TypeEnv
tenv            = InferState -> TypeEnv
environ InferState
endState
    terrs :: [TypeError]
terrs           = InferState -> [TypeError]
typeErrors InferState
endState

analyseTypesWithEnv' :: Data a => TypeEnv -> ProgramFile (Analysis a) -> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' :: forall a.
Data a =>
TypeEnv
-> ProgramFile (Analysis a)
-> (ProgramFile (Analysis a), InferState)
analyseTypesWithEnv' TypeEnv
env pf :: ProgramFile (Analysis a)
pf@(ProgramFile MetaInfo
mi [ProgramUnit (Analysis a)]
_) = FortranVersion
-> TypeEnv
-> Infer (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState)
forall a. FortranVersion -> TypeEnv -> Infer a -> (a, InferState)
runInfer (MetaInfo -> FortranVersion
miVersion MetaInfo
mi) TypeEnv
env (Infer (ProgramFile (Analysis a))
 -> (ProgramFile (Analysis a), InferState))
-> Infer (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a), InferState)
forall a b. (a -> b) -> a -> b
$ do
  -- Gather information.
  (Expression (Analysis a)
 -> StateT InferState (Reader InferConfig) ())
-> [Expression (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall a. Data a => InferFunc (Expression (Analysis a))
intrinsicsExp (UniFunc ProgramFile Expression a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Expression a
allExpressions ProgramFile (Analysis a)
pf)
  (ProgramUnit (Analysis a)
 -> StateT InferState (Reader InferConfig) ())
-> [ProgramUnit (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProgramUnit (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall a. Data a => InferFunc (ProgramUnit (Analysis a))
programUnit (UniFunc ProgramFile ProgramUnit a
forall a. Data a => UniFunc ProgramFile ProgramUnit a
allProgramUnits ProgramFile (Analysis a)
pf)
  (Declarator (Analysis a)
 -> StateT InferState (Reader InferConfig) ())
-> [Declarator (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Declarator (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall a. Data a => InferFunc (Declarator (Analysis a))
recordArrayDecl (UniFunc ProgramFile Declarator a
forall a. Data a => UniFunc ProgramFile Declarator a
allDeclarators ProgramFile (Analysis a)
pf)
  (Statement (Analysis a)
 -> StateT InferState (Reader InferConfig) ())
-> [Statement (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Statement (Analysis a) -> StateT InferState (Reader InferConfig) ()
forall a. Data a => InferFunc (Statement (Analysis a))
statement (UniFunc ProgramFile Statement a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements ProgramFile (Analysis a)
pf)

  -- Gather types for known entry points.
  [(Name, (Name, Maybe Name))]
eps <- (InferState -> [(Name, (Name, Maybe Name))])
-> StateT
     InferState (Reader InferConfig) [(Name, (Name, Maybe Name))]
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Map Name (Name, Maybe Name) -> [(Name, (Name, Maybe Name))]
forall k a. Map k a -> [(k, a)]
M.toList (Map Name (Name, Maybe Name) -> [(Name, (Name, Maybe Name))])
-> (InferState -> Map Name (Name, Maybe Name))
-> InferState
-> [(Name, (Name, Maybe Name))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InferState -> Map Name (Name, Maybe Name)
entryPoints)
  [(Name, (Name, Maybe Name))]
-> ((Name, (Name, Maybe Name))
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, (Name, Maybe Name))]
eps (((Name, (Name, Maybe Name))
  -> StateT InferState (Reader InferConfig) ())
 -> StateT InferState (Reader InferConfig) ())
-> ((Name, (Name, Maybe Name))
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ (Name
eName, (Name
fName, Maybe Name
mRetName)) -> do
    Maybe IDType
mFType <- Name -> Infer (Maybe IDType)
getRecordedType Name
fName
    case Maybe IDType
mFType of
      Just (IDType Maybe SemType
fVType Maybe ConstructType
fCType) -> do
        Maybe SemType
-> Maybe ConstructType
-> Name
-> StateT InferState (Reader InferConfig) ()
recordMType Maybe SemType
fVType Maybe ConstructType
fCType Name
eName
        -- FIXME: what about functions that return arrays?
        StateT InferState (Reader InferConfig) ()
-> (Name -> StateT InferState (Reader InferConfig) ())
-> Maybe Name
-> StateT InferState (Reader InferConfig) ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (Name -> Name -> Any
forall a. HasCallStack => Name -> a
error Name
"Entry points with result variables unsupported" (Name -> Any)
-> (Name -> StateT InferState (Reader InferConfig) ())
-> Name
-> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> Maybe ConstructType
-> Name
-> StateT InferState (Reader InferConfig) ()
recordMType Maybe SemType
fVType Maybe ConstructType
forall a. Maybe a
Nothing) Maybe Name
mRetName
      Maybe IDType
_                           -> () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

  ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a))
forall a.
Data a =>
ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a))
annotateTypes ProgramFile (Analysis a)
pf              -- Annotate AST nodes with their types.

extractTypeEnv :: forall a. Data a => ProgramFile (Analysis a) -> TypeEnv
extractTypeEnv :: forall a. Data a => 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 :: forall a.
Data a =>
ProgramFile (Analysis a) -> Infer (ProgramFile (Analysis a))
annotateTypes ProgramFile (Analysis a)
pf = (forall {a}.
Data a =>
(Expression (Analysis a)
 -> StateT
      InferState (Reader InferConfig) (Expression (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT
     InferState (Reader InferConfig) (ProgramFile (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM :: Data a => TransType Expression ProgramFile a) Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall a.
Data a =>
Expression (Analysis a) -> Infer (Expression (Analysis a))
annotateExpression ProgramFile (Analysis a)
pf StateT InferState (Reader InferConfig) (ProgramFile (Analysis a))
-> (ProgramFile (Analysis a)
    -> StateT
         InferState (Reader InferConfig) (ProgramFile (Analysis a)))
-> StateT
     InferState (Reader InferConfig) (ProgramFile (Analysis a))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                   (forall {a}.
Data a =>
(ProgramUnit (Analysis a)
 -> StateT
      InferState (Reader InferConfig) (ProgramUnit (Analysis a)))
-> ProgramFile (Analysis a)
-> StateT
     InferState (Reader InferConfig) (ProgramFile (Analysis a))
forall (m :: * -> *) from to.
(Monad m, Applicative m, Biplate from to) =>
(to -> m to) -> from -> m from
transformBiM :: Data a => TransType ProgramUnit ProgramFile a) ProgramUnit (Analysis a)
-> StateT
     InferState (Reader InferConfig) (ProgramUnit (Analysis a))
forall a.
Data a =>
ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))
annotateProgramUnit

intrinsicsExp :: Data a => InferFunc (Expression (Analysis a))
intrinsicsExp :: forall a. Data a => InferFunc (Expression (Analysis a))
intrinsicsExp (ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
nexp AList Index (Analysis a)
_)    = Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a.
MonadState InferState m =>
Expression (Analysis a) -> m ()
intrinsicsHelper Expression (Analysis a)
nexp
intrinsicsExp (ExpFunctionCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
nexp Maybe (AList Argument (Analysis a))
_) = Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a.
MonadState InferState m =>
Expression (Analysis a) -> m ()
intrinsicsHelper Expression (Analysis a)
nexp
intrinsicsExp Expression (Analysis a)
_                            = () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

intrinsicsHelper :: MonadState InferState m => Expression (Analysis a) -> m ()
intrinsicsHelper :: forall (m :: * -> *) a.
MonadState InferState m =>
Expression (Analysis a) -> m ()
intrinsicsHelper Expression (Analysis a)
nexp | Expression (Analysis a) -> Bool
forall a. Expression a -> Bool
isNamedExpression Expression (Analysis a)
nexp = do
  IntrinsicsTable
itab <- (InferState -> IntrinsicsTable) -> m IntrinsicsTable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> IntrinsicsTable
intrinsics
  case Name -> IntrinsicsTable -> Maybe IntrinsicType
getIntrinsicReturnType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
srcName Expression (Analysis a)
nexp) IntrinsicsTable
itab of
    Just IntrinsicType
_ -> do
      let n :: Name
n = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
nexp
      ConstructType -> Name -> m ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTIntrinsic Name
n
      -- recordBaseType _  n -- FIXME: going to skip base types for the moment
    Maybe IntrinsicType
_             -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
intrinsicsHelper Expression (Analysis a)
_ = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

programUnit :: Data a => InferFunc (ProgramUnit (Analysis a))
programUnit :: forall a. Data a => InferFunc (ProgramUnit (Analysis a))
programUnit pu :: ProgramUnit (Analysis a)
pu@(PUFunction Analysis a
_ SrcSpan
_ Maybe (TypeSpec (Analysis a))
mRetType PrefixSuffix (Analysis a)
_ Name
_ Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
mRetVar [Block (Analysis a)]
blocks Maybe [ProgramUnit (Analysis a)]
_)
  | Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu   = do
    -- record some type information that we can glean
    ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTFunction Name
n
    case (Maybe (TypeSpec (Analysis a))
mRetType, Maybe (Expression (Analysis a))
mRetVar) of
      (Just ts :: TypeSpec (Analysis a)
ts@(TypeSpec Analysis a
_ SrcSpan
_ BaseType
_ Maybe (Selector (Analysis a))
_), Just Expression (Analysis a)
v) -> do
        SemType
semType <- TypeSpec (Analysis a)
-> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec (Analysis a)
ts
        SemType -> Name -> StateT InferState (Reader InferConfig) ()
recordSemType SemType
semType Name
n StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SemType -> Name -> StateT InferState (Reader InferConfig) ()
recordSemType SemType
semType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
      (Just ts :: TypeSpec (Analysis a)
ts@(TypeSpec Analysis a
_ SrcSpan
_ BaseType
_ Maybe (Selector (Analysis a))
_), Maybe (Expression (Analysis a))
_)      -> do
        SemType
semType <- TypeSpec (Analysis a)
-> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec (Analysis a)
ts
        SemType -> Name -> StateT InferState (Reader InferConfig) ()
recordSemType SemType
semType Name
n
      (Maybe (TypeSpec (Analysis a)), Maybe (Expression (Analysis a)))
_                                        -> () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- record entry points for later annotation
    [Block (Analysis a)]
-> (Block (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Block (Analysis a)]
blocks ((Block (Analysis a) -> StateT InferState (Reader InferConfig) ())
 -> StateT InferState (Reader InferConfig) ())
-> (Block (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ Block (Analysis a)
block ->
      [StateT InferState (Reader InferConfig) ()]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Name
-> Name -> Maybe Name -> StateT InferState (Reader InferConfig) ()
recordEntryPoint Name
n (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v) ((Expression (Analysis a) -> Name)
-> Maybe (Expression (Analysis a)) -> Maybe Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Maybe (Expression (Analysis a))
mRetVar') | (StEntry Analysis a
_ SrcSpan
_ Expression (Analysis a)
v Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
mRetVar') <- UniFunc Block Statement a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements Block (Analysis a)
block ]
programUnit pu :: ProgramUnit (Analysis a)
pu@(PUSubroutine Analysis a
_ SrcSpan
_ PrefixSuffix (Analysis a)
_ Name
_ Maybe (AList Expression (Analysis a))
_ [Block (Analysis a)]
blocks Maybe [ProgramUnit (Analysis a)]
_) | Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu = do
  -- record the fact that this is a subroutine
  ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTSubroutine Name
n
  -- record entry points for later annotation
  [Block (Analysis a)]
-> (Block (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Block (Analysis a)]
blocks ((Block (Analysis a) -> StateT InferState (Reader InferConfig) ())
 -> StateT InferState (Reader InferConfig) ())
-> (Block (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ Block (Analysis a)
block ->
    [StateT InferState (Reader InferConfig) ()]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [ Name
-> Name -> Maybe Name -> StateT InferState (Reader InferConfig) ()
recordEntryPoint Name
n (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v) Maybe Name
forall a. Maybe a
Nothing | (StEntry Analysis a
_ SrcSpan
_ Expression (Analysis a)
v Maybe (AList Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_) <- UniFunc Block Statement a
forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements Block (Analysis a)
block ]
programUnit ProgramUnit (Analysis a)
_                                           = () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Records array type information from a 'Declarator'. (Scalar type info is
--   processed elsewhere.)
--
--   Note that 'ConstructType' is rewritten for 'Declarator's in
--   'handleDeclaration' later. TODO how does this assist exactly? disabling
--   apparently doesn't impact tests
recordArrayDecl :: Data a => InferFunc (Declarator (Analysis a))
recordArrayDecl :: forall a. Data a => InferFunc (Declarator (Analysis a))
recordArrayDecl (Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v (ArrayDecl AList DimensionDeclarator (Analysis a)
ddAList) Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_) =
    ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ([(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray ([(Maybe Kind, Maybe Kind)] -> ConstructType)
-> [(Maybe Kind, Maybe Kind)] -> ConstructType
forall a b. (a -> b) -> a -> b
$ AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
ddAList) (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
recordArrayDecl Declarator (Analysis a)
_ = () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

dimDeclarator :: AList DimensionDeclarator a -> [(Maybe Int, Maybe Int)]
dimDeclarator :: forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator a
ddAList = [ (Maybe Kind
lb, Maybe Kind
ub) | DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
lbExp Maybe (Expression a)
ubExp <- AList DimensionDeclarator a -> [DimensionDeclarator a]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList DimensionDeclarator a
ddAList
                                   , let lb :: Maybe Kind
lb = do ExpValue a
_ SrcSpan
_ (ValInteger Name
i Maybe (Expression a)
_) <- Maybe (Expression a)
lbExp
                                                 Kind -> Maybe Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Maybe Kind) -> Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
forall a. Read a => Name -> a
read Name
i
                                   , let ub :: Maybe Kind
ub = do ExpValue a
_ SrcSpan
_ (ValInteger Name
i Maybe (Expression a)
_) <- Maybe (Expression a)
ubExp
                                                 Kind -> Maybe Kind
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Maybe Kind) -> Kind -> Maybe Kind
forall a b. (a -> b) -> a -> b
$ Name -> Kind
forall a. Read a => Name -> a
read Name
i ]

-- | Auxiliary function for getting semantic and construct type of a declaration.
-- Used in standard declarations and structures
handleDeclaration :: Data a => TypeEnv -> SrcSpan -> TypeSpec (Analysis a)
  -> Maybe (AList Attribute (Analysis a))
  -> AList Declarator (Analysis a)
  -> Infer [(Name, SemType, ConstructType)]
handleDeclaration :: forall a.
Data a =>
TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handleDeclaration TypeEnv
env SrcSpan
stmtSs TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList
  | [Attribute (Analysis a)]
mAttrs  <- [Attribute (Analysis a)]
-> (AList Attribute (Analysis a) -> [Attribute (Analysis a)])
-> Maybe (AList Attribute (Analysis a))
-> [Attribute (Analysis a)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] AList Attribute (Analysis a) -> [Attribute (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip Maybe (AList Attribute (Analysis a))
mAttrAList
  , Maybe (Attribute (Analysis a))
attrDim <- (Attribute (Analysis a) -> Bool)
-> [Attribute (Analysis a)] -> Maybe (Attribute (Analysis a))
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find Attribute (Analysis a) -> Bool
forall a. Attribute a -> Bool
isAttrDimension [Attribute (Analysis a)]
mAttrs
  , Bool
isParam <- (Attribute (Analysis a) -> Bool)
-> [Attribute (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Attribute (Analysis a) -> Bool
forall a. Attribute a -> Bool
isAttrParameter [Attribute (Analysis a)]
mAttrs
  , Bool
isExtrn <- (Attribute (Analysis a) -> Bool)
-> [Attribute (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Attribute (Analysis a) -> Bool
forall a. Attribute a -> Bool
isAttrExternal [Attribute (Analysis a)]
mAttrs
  , [Declarator (Analysis a)]
decls   <- AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
declAList =
    let cType :: Name -> ConstructType
cType Name
n | Bool
isExtrn                                     = ConstructType
CTExternal
                | Just (AttrDimension Analysis a
_ SrcSpan
_ AList DimensionDeclarator (Analysis a)
ddAList) <- Maybe (Attribute (Analysis a))
attrDim = [(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray (AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
ddAList)
                | Bool
isParam                                     = ConstructType
CTParameter
                | Just (IDType Maybe SemType
_ (Just ConstructType
ct)) <- Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n TypeEnv
env
                , ConstructType
ct ConstructType -> ConstructType -> Bool
forall a. Eq a => a -> a -> Bool
/= ConstructType
CTIntrinsic                           = ConstructType
ct
                | Bool
otherwise                                   = ConstructType
CTVariable
        handler :: [(Name, SemType, ConstructType)]
-> Declarator (Analysis a) -> m [(Name, SemType, ConstructType)]
handler [(Name, SemType, ConstructType)]
rs = \case
          Declarator Analysis a
_ SrcSpan
declSs Expression (Analysis a)
v DeclaratorType (Analysis a)
mDdAList Maybe (Expression (Analysis a))
mLenExpr Maybe (Expression (Analysis a))
_ -> do
            SemType
st <- SrcSpan
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> m SemType
forall (m :: * -> *) a.
(MonadState InferState m, MonadReader InferConfig m) =>
SrcSpan
-> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m SemType
deriveSemTypeFromDeclaration SrcSpan
stmtSs SrcSpan
declSs TypeSpec (Analysis a)
ts Maybe (Expression (Analysis a))
mLenExpr
            let n :: Name
n  = Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v
                ct :: ConstructType
ct = case DeclaratorType (Analysis a)
mDdAList of
                       DeclaratorType (Analysis a)
ScalarDecl -> Name -> ConstructType
cType Name
n
                       ArrayDecl AList DimensionDeclarator (Analysis a)
dims -> [(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray ([(Maybe Kind, Maybe Kind)] -> ConstructType)
-> [(Maybe Kind, Maybe Kind)] -> ConstructType
forall a b. (a -> b) -> a -> b
$ AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
dims
            [(Name, SemType, ConstructType)]
-> m [(Name, SemType, ConstructType)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(Name, SemType, ConstructType)]
 -> m [(Name, SemType, ConstructType)])
-> [(Name, SemType, ConstructType)]
-> m [(Name, SemType, ConstructType)]
forall a b. (a -> b) -> a -> b
$ (Name
n, SemType
st, ConstructType
ct) (Name, SemType, ConstructType)
-> [(Name, SemType, ConstructType)]
-> [(Name, SemType, ConstructType)]
forall a. a -> [a] -> [a]
: [(Name, SemType, ConstructType)]
rs
    in ([(Name, SemType, ConstructType)]
 -> Declarator (Analysis a)
 -> Infer [(Name, SemType, ConstructType)])
-> [(Name, SemType, ConstructType)]
-> [Declarator (Analysis a)]
-> Infer [(Name, SemType, ConstructType)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM [(Name, SemType, ConstructType)]
-> Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
forall {m :: * -> *}.
(MonadState InferState m, MonadReader InferConfig m) =>
[(Name, SemType, ConstructType)]
-> Declarator (Analysis a) -> m [(Name, SemType, ConstructType)]
handler [] [Declarator (Analysis a)]
decls

handleStructureItem :: Data a => StructMemberTypeEnv -> StructureItem (Analysis a) -> Infer StructMemberTypeEnv
handleStructureItem :: forall a.
Data a =>
TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv
handleStructureItem TypeEnv
mt (StructFields Analysis a
_ SrcSpan
src TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList) = do
  TypeEnv
env <- (InferState -> TypeEnv) -> Infer TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> TypeEnv
environ
  [(Name, SemType, ConstructType)]
ds <- TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
forall a.
Data a =>
TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handleDeclaration TypeEnv
env SrcSpan
src TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList
  TypeEnv -> Infer TypeEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeEnv -> Infer TypeEnv) -> TypeEnv -> Infer TypeEnv
forall a b. (a -> b) -> a -> b
$ (TypeEnv -> (Name, SemType, ConstructType) -> TypeEnv)
-> TypeEnv -> [(Name, SemType, ConstructType)] -> TypeEnv
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\TypeEnv
m (Name
n, SemType
s, ConstructType
c) -> Name -> IDType -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
n (Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
s) (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
c)) TypeEnv
m) TypeEnv
mt [(Name, SemType, ConstructType)]
ds
-- TODO: These should eventually be implemented
handleStructureItem TypeEnv
mt StructUnion{} = TypeEnv -> Infer TypeEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeEnv
mt
handleStructureItem TypeEnv
mt StructStructure{} = TypeEnv -> Infer TypeEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure TypeEnv
mt

-- | Create a structure env from the list of fields and add it to the InferState
handleStructure ::Data a => Maybe String -> AList StructureItem (Analysis a) -> Infer ()
handleStructure :: forall a.
Data a =>
Maybe Name
-> AList StructureItem (Analysis a)
-> StateT InferState (Reader InferConfig) ()
handleStructure Maybe Name
mName AList StructureItem (Analysis a)
itemAList = do
  case Maybe Name
mName of
    Just Name
n -> do
      TypeEnv
structEnv <- (TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv)
-> TypeEnv -> [StructureItem (Analysis a)] -> Infer TypeEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv
forall a.
Data a =>
TypeEnv -> StructureItem (Analysis a) -> Infer TypeEnv
handleStructureItem TypeEnv
forall k a. Map k a
M.empty (AList StructureItem (Analysis a) -> [StructureItem (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList StructureItem (Analysis a)
itemAList)
      TypeEnv -> Name -> StateT InferState (Reader InferConfig) ()
recordStruct TypeEnv
structEnv Name
n
    Maybe Name
Nothing -> () -> StateT InferState (Reader InferConfig) ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

statement :: Data a => InferFunc (Statement (Analysis a))

statement :: forall a. Data a => InferFunc (Statement (Analysis a))
statement (StDeclaration Analysis a
_ SrcSpan
stmtSs TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList) = do
  TypeEnv
env <- (InferState -> TypeEnv) -> Infer TypeEnv
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> TypeEnv
environ
  [(Name, SemType, ConstructType)]
decls <- TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
forall a.
Data a =>
TypeEnv
-> SrcSpan
-> TypeSpec (Analysis a)
-> Maybe (AList Attribute (Analysis a))
-> AList Declarator (Analysis a)
-> Infer [(Name, SemType, ConstructType)]
handleDeclaration TypeEnv
env SrcSpan
stmtSs TypeSpec (Analysis a)
ts Maybe (AList Attribute (Analysis a))
mAttrAList AList Declarator (Analysis a)
declAList
  [(Name, SemType, ConstructType)]
-> ((Name, SemType, ConstructType)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Name, SemType, ConstructType)]
decls (((Name, SemType, ConstructType)
  -> StateT InferState (Reader InferConfig) ())
 -> StateT InferState (Reader InferConfig) ())
-> ((Name, SemType, ConstructType)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \(Name
n, SemType
b, ConstructType
c) -> SemType
-> ConstructType
-> Name
-> StateT InferState (Reader InferConfig) ()
recordType SemType
b ConstructType
c Name
n
statement (StExternal Analysis a
_ SrcSpan
_ AList Expression (Analysis a)
varAList) = do
  let vars :: [Expression (Analysis a)]
vars = AList Expression (Analysis a) -> [Expression (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression (Analysis a)
varAList
  (Expression (Analysis a)
 -> StateT InferState (Reader InferConfig) ())
-> [Expression (Analysis a)]
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTExternal (Name -> StateT InferState (Reader InferConfig) ())
-> (Expression (Analysis a) -> Name)
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName) [Expression (Analysis a)]
vars
statement (StExpressionAssign Analysis a
_ SrcSpan
_ (ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
v AList Index (Analysis a)
ixAList) Expression (Analysis a)
_)
  --  | 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
    Maybe IDType
mIDType <- Expression (Analysis a) -> Infer (Maybe IDType)
forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType Expression (Analysis a)
v
    case Maybe IDType
mIDType of
      Just (IDType Maybe SemType
_ (Just CTArray{})) -> () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()                -- do nothing, it's already known to be an array
      Maybe IDType
_                                -> ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTFunction (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v) -- 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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTFunction (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
-- (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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
CTFunction (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)

statement (StDimension Analysis a
_ SrcSpan
_ AList Declarator (Analysis a)
declAList) = do
  let decls :: [Declarator (Analysis a)]
decls = AList Declarator (Analysis a) -> [Declarator (Analysis a)]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Declarator (Analysis a)
declAList
  [Declarator (Analysis a)]
-> (Declarator (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Declarator (Analysis a)]
decls ((Declarator (Analysis a)
  -> StateT InferState (Reader InferConfig) ())
 -> StateT InferState (Reader InferConfig) ())
-> (Declarator (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ Declarator (Analysis a)
decl -> case Declarator (Analysis a)
decl of
    Declarator Analysis a
_ SrcSpan
_ Expression (Analysis a)
v (ArrayDecl AList DimensionDeclarator (Analysis a)
ddAList) Maybe (Expression (Analysis a))
_ Maybe (Expression (Analysis a))
_ ->
      ConstructType -> Name -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ([(Maybe Kind, Maybe Kind)] -> ConstructType
CTArray ([(Maybe Kind, Maybe Kind)] -> ConstructType)
-> [(Maybe Kind, Maybe Kind)] -> ConstructType
forall a b. (a -> b) -> a -> b
$ AList DimensionDeclarator (Analysis a)
-> [(Maybe Kind, Maybe Kind)]
forall a. AList DimensionDeclarator a -> [(Maybe Kind, Maybe Kind)]
dimDeclarator AList DimensionDeclarator (Analysis a)
ddAList) (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
v)
    Declarator (Analysis a)
_ -> () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

statement (StStructure Analysis a
_ SrcSpan
_ Maybe Name
mName AList StructureItem (Analysis a)
itemAList) = Maybe Name
-> AList StructureItem (Analysis a)
-> StateT InferState (Reader InferConfig) ()
forall a.
Data a =>
Maybe Name
-> AList StructureItem (Analysis a)
-> StateT InferState (Reader InferConfig) ()
handleStructure Maybe Name
mName AList StructureItem (Analysis a)
itemAList

statement Statement (Analysis a)
_ = () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

annotateExpression :: Data a => Expression (Analysis a) -> Infer (Expression (Analysis a))

-- handle the various literals
annotateExpression :: forall a.
Data a =>
Expression (Analysis a) -> Infer (Expression (Analysis a))
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_))    = Expression (Analysis a)
-> (IDType -> Expression (Analysis a))
-> Maybe IDType
-> Expression (Analysis a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expression (Analysis a)
e (IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
`setIDType` Expression (Analysis a)
e) (Maybe IDType -> Expression (Analysis a))
-> Infer (Maybe IDType)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Infer (Maybe IDType)
getRecordedType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e)
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValIntrinsic Name
_))   = Expression (Analysis a)
-> (IDType -> Expression (Analysis a))
-> Maybe IDType
-> Expression (Analysis a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Expression (Analysis a)
e (IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
`setIDType` Expression (Analysis a)
e) (Maybe IDType -> Expression (Analysis a))
-> Infer (Maybe IDType)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Infer (Maybe IDType)
getRecordedType (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e)
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
ss (ValReal RealLit
r Maybe (Expression (Analysis a))
mkp))        = do
    Kind
k <- SrcSpan -> RealLit -> Maybe (Expression (Analysis a)) -> Infer Kind
forall a. SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind SrcSpan
ss RealLit
r Maybe (Expression (Analysis a))
mkp
    Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> StateT
      InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType (Kind -> SemType
TReal Kind
k) Expression (Analysis a)
e
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
ss (ValComplex Expression (Analysis a)
e1 Expression (Analysis a)
e2)) = do
    SemType
st <- SrcSpan
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) SemType
forall a.
SrcSpan
-> Expression a
-> Expression a
-> StateT InferState (Reader InferConfig) SemType
complexLiteralType SrcSpan
ss Expression (Analysis a)
e1 Expression (Analysis a)
e2
    Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> StateT
      InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType SemType
st Expression (Analysis a)
e
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ ValInteger{})     =
    -- 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)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> StateT
      InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeInteger) Expression (Analysis a)
e
annotateExpression e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValLogical{}))     =
    Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return (Expression (Analysis a)
 -> StateT
      InferState (Reader InferConfig) (Expression (Analysis a)))
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall a b. (a -> b) -> a -> b
$ SemType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeLogical) Expression (Analysis a)
e

annotateExpression e :: Expression (Analysis a)
e@(ExpBinary Analysis a
_ SrcSpan
_ BinaryOp
op Expression (Analysis a)
e1 Expression (Analysis a)
e2)          = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> BinaryOp
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> BinaryOp
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
binaryOpType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) BinaryOp
op Expression (Analysis a)
e1 Expression (Analysis a)
e2
annotateExpression e :: Expression (Analysis a)
e@(ExpUnary Analysis a
_ SrcSpan
_ UnaryOp
op Expression (Analysis a)
e1)              = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
unaryOpType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e1) UnaryOp
op Expression (Analysis a)
e1
annotateExpression e :: Expression (Analysis a)
e@(ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
e1 AList Index (Analysis a)
idxAList)    = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> Expression (Analysis a)
-> AList Index (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> AList Index (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
subscriptType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) Expression (Analysis a)
e1 AList Index (Analysis a)
idxAList
annotateExpression e :: Expression (Analysis a)
e@(ExpFunctionCall Analysis a
_ SrcSpan
_ Expression (Analysis a)
e1 Maybe (AList Argument (Analysis a))
parAList) = (IDType -> Expression (Analysis a) -> Expression (Analysis a))
-> Expression (Analysis a) -> IDType -> Expression (Analysis a)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IDType -> Expression (Analysis a) -> Expression (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType Expression (Analysis a)
e (IDType -> Expression (Analysis a))
-> StateT InferState (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` SrcSpan
-> Expression (Analysis a)
-> Maybe (AList Argument (Analysis a))
-> StateT InferState (Reader InferConfig) IDType
forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> Maybe (AList Argument (Analysis a))
-> StateT InferState (Reader InferConfig) IDType
functionCallType (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) Expression (Analysis a)
e1 Maybe (AList Argument (Analysis a))
parAList
annotateExpression Expression (Analysis a)
e                                   = Expression (Analysis a)
-> StateT InferState (Reader InferConfig) (Expression (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return Expression (Analysis a)
e

annotateProgramUnit :: Data a => ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))
annotateProgramUnit :: forall a.
Data a =>
ProgramUnit (Analysis a) -> Infer (ProgramUnit (Analysis a))
annotateProgramUnit ProgramUnit (Analysis a)
pu | Named Name
n <- ProgramUnit (Analysis a) -> ProgramUnitName
forall a. ProgramUnit (Analysis a) -> ProgramUnitName
puName ProgramUnit (Analysis a)
pu = ProgramUnit (Analysis a)
-> (IDType -> ProgramUnit (Analysis a))
-> Maybe IDType
-> ProgramUnit (Analysis a)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ProgramUnit (Analysis a)
pu (IDType -> ProgramUnit (Analysis a) -> ProgramUnit (Analysis a)
forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
`setIDType` ProgramUnit (Analysis a)
pu) (Maybe IDType -> ProgramUnit (Analysis a))
-> Infer (Maybe IDType)
-> StateT
     InferState (Reader InferConfig) (ProgramUnit (Analysis a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> Infer (Maybe IDType)
getRecordedType Name
n
annotateProgramUnit ProgramUnit (Analysis a)
pu                        = ProgramUnit (Analysis a)
-> StateT
     InferState (Reader InferConfig) (ProgramUnit (Analysis a))
forall (m :: * -> *) a. Monad m => a -> m a
return ProgramUnit (Analysis a)
pu

-- | 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 -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind :: forall a. SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind SrcSpan
ss RealLit
r Maybe (Expression a)
mkp =
    case Maybe (Expression a)
mkp of
      Maybe (Expression a)
Nothing -> case Exponent -> ExponentLetter
exponentLetter (RealLit -> Exponent
realLitExponent RealLit
r) of
                   ExponentLetter
ExpLetterE -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return  Kind
4
                   ExponentLetter
ExpLetterD -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return  Kind
8
                   ExponentLetter
ExpLetterQ -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
16
      Just Expression a
_ {- kp -} -> case Exponent -> ExponentLetter
exponentLetter (RealLit -> Exponent
realLitExponent RealLit
r) of
                   ExponentLetter
ExpLetterE -> Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
0 -- TODO return 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 (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError (Name
"only real literals with exponent letter 'e'"
                             Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
"can specify explicit kind parameter") SrcSpan
ss
                     Kind -> Infer Kind
forall (m :: * -> *) a. Monad m => a -> m a
return Kind
0 -- TODO return k

-- | 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 :: forall a.
SrcSpan
-> Expression a
-> Expression a
-> StateT InferState (Reader InferConfig) SemType
complexLiteralType SrcSpan
ss (ExpValue a
_ SrcSpan
_ (ValReal RealLit
r Maybe (Expression a)
mkp)) Expression a
_ = do
    Kind
k1 <- SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
forall a. SrcSpan -> RealLit -> Maybe (Expression a) -> Infer Kind
deriveRealLiteralKind SrcSpan
ss RealLit
r Maybe (Expression a)
mkp
    SemType -> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> StateT InferState (Reader InferConfig) SemType)
-> SemType -> StateT InferState (Reader InferConfig) SemType
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k1
complexLiteralType SrcSpan
_ Expression a
_ Expression a
_ = SemType -> StateT InferState (Reader InferConfig) SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> StateT InferState (Reader InferConfig) SemType)
-> SemType -> StateT InferState (Reader InferConfig) SemType
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeComplex

binaryOpType :: Data a => SrcSpan -> BinaryOp -> Expression (Analysis a) -> Expression (Analysis a) -> Infer IDType
binaryOpType :: forall a.
Data a =>
SrcSpan
-> BinaryOp
-> Expression (Analysis a)
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
binaryOpType SrcSpan
ss BinaryOp
op Expression (Analysis a)
e1 Expression (Analysis a)
e2 = do
  Maybe SemType
mst1 <- case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e1 of
            Just (IDType (Just SemType
st) Maybe ConstructType
_) -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
            Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Unable to obtain type for first operand" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e1) StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
  Maybe SemType
mst2 <- case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e2 of
            Just (IDType (Just SemType
st) Maybe ConstructType
_) -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
            Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Unable to obtain type for second operand" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e2) StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
  case (Maybe SemType
mst1, Maybe SemType
mst2) of
    (Maybe SemType
_, Maybe SemType
Nothing) -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
    (Maybe SemType
Nothing, Maybe SemType
_) -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
    (Just SemType
st1, Just SemType
st2) -> do
      Maybe SemType
mst  <- SrcSpan
-> BinaryOp
-> SemType
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
binopSimpleCombineSemTypes SrcSpan
ss BinaryOp
op SemType
st1 SemType
st2
      Maybe SemType
mst' <- case Maybe SemType
mst of
        Just SemType
st
          | BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ BinaryOp
Addition, BinaryOp
Subtraction, BinaryOp
Multiplication, BinaryOp
Division
                      , BinaryOp
Exponentiation, BinaryOp
Concatenation, BinaryOp
Or, BinaryOp
XOr, BinaryOp
And ]       -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
          | BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
GT, BinaryOp
GTE, BinaryOp
LT, BinaryOp
LTE, BinaryOp
EQ, BinaryOp
NE, BinaryOp
Equivalent, BinaryOp
NotEquivalent] -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeLogical)
          | BinCustom{} <- BinaryOp
op -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom binary ops not supported" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
        Maybe SemType
_ -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing

      IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst' Maybe ConstructType
forall a. Maybe a
Nothing -- 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 (Reader InferConfig) (Maybe SemType)
binopSimpleCombineSemTypes SrcSpan
ss BinaryOp
op SemType
st1 SemType
st2 = do
    case (SemType
st1, SemType
st2) of
      (SemType
_           , TComplex Kind
k2) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k2
      (TComplex Kind
k1, SemType
_           ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TComplex Kind
k1
      (SemType
_           , TReal    Kind
k2) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TReal Kind
k2
      (TReal    Kind
k1, SemType
_           ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TReal Kind
k1
      (SemType
_           , TInteger Kind
k2) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TInteger Kind
k2
      (TInteger Kind
k1, SemType
_           ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TInteger Kind
k1
      (TByte    Kind
k1, TByte     Kind
_ ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TByte Kind
k1
      (TLogical Kind
k1, TLogical  Kind
_ ) -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ Kind -> SemType
TLogical Kind
k1
      (TCustom  Name
_, TCustom   Name
_) -> do
        Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom types / binary op not supported" SrcSpan
ss
        Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
      (TCharacter CharacterLen
l1 Kind
k1, TCharacter CharacterLen
l2 Kind
k2)
        | Kind
k1 Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
/= Kind
k2 -> do Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"operation on character strings of different kinds" SrcSpan
ss
                         Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
        | BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
Concatenation -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> SemType
TCharacter (CharacterLen -> CharacterLen -> CharacterLen
charLenConcat CharacterLen
l1 CharacterLen
l2) Kind
k1
        | BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
EQ, BinaryOp
NE]  -> SemType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall {a}. a -> StateT InferState (Reader InferConfig) (Maybe a)
ret (SemType -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeLogical
        | Bool
otherwise -> do Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Invalid op on character strings" SrcSpan
ss
                          Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
      (SemType, SemType)
_ -> do Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Type error between operands of binary operator" SrcSpan
ss
              Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
  where
    ret :: a -> StateT InferState (Reader InferConfig) (Maybe a)
ret = Maybe a -> StateT InferState (Reader InferConfig) (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe a -> StateT InferState (Reader InferConfig) (Maybe a))
-> (a -> Maybe a)
-> a
-> StateT InferState (Reader InferConfig) (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just

unaryOpType :: Data a => SrcSpan -> UnaryOp -> Expression (Analysis a) -> Infer IDType
unaryOpType :: forall a.
Data a =>
SrcSpan
-> UnaryOp
-> Expression (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
unaryOpType SrcSpan
ss UnaryOp
op Expression (Analysis a)
e = do
  Maybe SemType
mst <- case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e of
           Just (IDType (Just SemType
st) Maybe ConstructType
_) -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
           Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Unable to obtain type for" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
e) StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
  Maybe SemType
mst' <- case (Maybe SemType
mst, UnaryOp
op) of
    (Maybe SemType
Nothing, UnaryOp
_)               -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
    (Just TCustom{}, UnaryOp
_)        -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom types / unary ops not supported" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
    (Maybe SemType
_, UnCustom{})            -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"custom unary ops not supported" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
    (Just st :: SemType
st@(TLogical Kind
_), UnaryOp
Not)    -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
    (Just SemType
st, UnaryOp
_)
      | UnaryOp
op UnaryOp -> [UnaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UnaryOp
Plus, UnaryOp
Minus] Bool -> Bool -> Bool
&&
        SemType -> Bool
isNumericType SemType
st -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st
    (Maybe SemType, UnaryOp)
_ -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Type error for unary operator" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
  IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst' Maybe ConstructType
forall a. Maybe a
Nothing -- FIXME: might have to check kind of operand

subscriptType :: Data a => SrcSpan -> Expression (Analysis a) -> AList Index (Analysis a) -> Infer IDType
subscriptType :: forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> AList Index (Analysis a)
-> StateT InferState (Reader InferConfig) IDType
subscriptType SrcSpan
ss Expression (Analysis a)
e1 (AList Analysis a
_ SrcSpan
_ [Index (Analysis a)]
idxs) = do
  let isInteger :: f (Analysis a) -> Bool
isInteger f (Analysis a)
ie | Just (IDType (Just (TInteger Kind
_)) Maybe ConstructType
_) <- f (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType f (Analysis a)
ie = Bool
True
                   | Bool
otherwise = Bool
False
  [Index (Analysis a)]
-> (Index (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Index (Analysis a)]
idxs ((Index (Analysis a) -> StateT InferState (Reader InferConfig) ())
 -> StateT InferState (Reader InferConfig) ())
-> (Index (Analysis a)
    -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ Index (Analysis a)
idx -> case Index (Analysis a)
idx of
    IxSingle Analysis a
_ SrcSpan
_ Maybe Name
_ Expression (Analysis a)
ie
      | Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie) -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie)
    IxRange Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
mie1 Maybe (Expression (Analysis a))
mie2 Maybe (Expression (Analysis a))
mie3
      | Just Expression (Analysis a)
ie1 <- Maybe (Expression (Analysis a))
mie1, Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie1) -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie1)
      | Just Expression (Analysis a)
ie2 <- Maybe (Expression (Analysis a))
mie2, Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie2) -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie2)
      | Just Expression (Analysis a)
ie3 <- Maybe (Expression (Analysis a))
mie3, Bool -> Bool
not (Expression (Analysis a) -> Bool
forall {f :: * -> *} {a}.
(Annotated f, Data a) =>
f (Analysis a) -> Bool
isInteger Expression (Analysis a)
ie3) -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Invalid or unknown type for index" (Expression (Analysis a) -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression (Analysis a)
ie3)
    Index (Analysis a)
_ -> () -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e1 of
    Just ty :: IDType
ty@(IDType Maybe SemType
mst (Just (CTArray [(Maybe Kind, Maybe Kind)]
dds))) -> do
      Bool
-> StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([Index (Analysis a)] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Index (Analysis a)]
idxs Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
/= [(Maybe Kind, Maybe Kind)] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [(Maybe Kind, Maybe Kind)]
dds) (StateT InferState (Reader InferConfig) ()
 -> StateT InferState (Reader InferConfig) ())
-> StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"Length of indices does not match rank of array." SrcSpan
ss
      let isSingle :: Index a -> Bool
isSingle (IxSingle{}) = Bool
True; isSingle Index a
_ = Bool
False
      if (Index (Analysis a) -> Bool) -> [Index (Analysis a)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Index (Analysis a) -> Bool
forall a. Index a -> Bool
isSingle [Index (Analysis a)]
idxs
        then IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst Maybe ConstructType
forall a. Maybe a
Nothing
        else IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
ty
    Maybe IDType
_ -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType

functionCallType :: Data a => SrcSpan -> Expression (Analysis a) -> Maybe (AList Argument (Analysis a)) -> Infer IDType
functionCallType :: forall a.
Data a =>
SrcSpan
-> Expression (Analysis a)
-> Maybe (AList Argument (Analysis a))
-> StateT InferState (Reader InferConfig) IDType
functionCallType SrcSpan
ss (ExpValue Analysis a
_ SrcSpan
_ (ValIntrinsic Name
n)) (Just (AList Analysis a
_ SrcSpan
_ [Argument (Analysis a)]
params)) = do
  IntrinsicsTable
itab <- (InferState -> IntrinsicsTable)
-> StateT InferState (Reader InferConfig) IntrinsicsTable
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets InferState -> IntrinsicsTable
intrinsics
  let mRetType :: Maybe IntrinsicType
mRetType = Name -> IntrinsicsTable -> Maybe IntrinsicType
getIntrinsicReturnType Name
n IntrinsicsTable
itab
  case Maybe IntrinsicType
mRetType of
    Maybe IntrinsicType
Nothing -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
    Just IntrinsicType
retType -> do
      Maybe SemType
mst <- case IntrinsicType
retType of
            IntrinsicType
ITReal      -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeReal
            IntrinsicType
ITInteger   -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeInteger
            IntrinsicType
ITComplex   -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeComplex
            IntrinsicType
ITDouble    -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeDoublePrecision
            IntrinsicType
ITLogical   -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeLogical
            IntrinsicType
ITCharacter -> BaseType -> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType BaseType
TypeCharacter
            ITParam Kind
i
              | [Argument (Analysis a)] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Argument (Analysis a)]
params Kind -> Kind -> Bool
forall a. Ord a => a -> a -> Bool
>= Kind
i, Argument Analysis a
_ SrcSpan
_ Maybe Name
_ Expression (Analysis a)
e <- [Argument (Analysis a)]
params [Argument (Analysis a)] -> Kind -> Argument (Analysis a)
forall a. [a] -> Kind -> a
!! (Kind
iKind -> Kind -> Kind
forall a. Num a => a -> a -> a
-Kind
1)
                -> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType
 -> StateT InferState (Reader InferConfig) (Maybe SemType))
-> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall a b. (a -> b) -> a -> b
$ IDType -> Maybe SemType
idVType (IDType -> Maybe SemType) -> Maybe IDType -> Maybe SemType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e
              | Bool
otherwise -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError (Name
"Invalid parameter list to intrinsic '" Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
n Name -> ShowS
forall a. [a] -> [a] -> [a]
++ Name
"'") SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) (Maybe SemType)
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe SemType
-> StateT InferState (Reader InferConfig) (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SemType
forall a. Maybe a
Nothing
      case Maybe SemType
mst of
        Maybe SemType
Nothing -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType
        Just SemType
_ -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
mst Maybe ConstructType
forall a. Maybe a
Nothing
  where
    wrapBaseType :: Monad m => BaseType -> m (Maybe SemType)
    wrapBaseType :: forall (m :: * -> *). Monad m => BaseType -> m (Maybe SemType)
wrapBaseType = Maybe SemType -> m (Maybe SemType)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SemType -> m (Maybe SemType))
-> (BaseType -> Maybe SemType) -> BaseType -> m (Maybe SemType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SemType -> Maybe SemType
forall a. a -> Maybe a
Just (SemType -> Maybe SemType)
-> (BaseType -> SemType) -> BaseType -> Maybe SemType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BaseType -> SemType
deriveSemTypeFromBaseType

functionCallType SrcSpan
ss Expression (Analysis a)
e1 Maybe (AList Argument (Analysis a))
_ = case Expression (Analysis a) -> Maybe IDType
forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType Expression (Analysis a)
e1 of
  Just (IDType (Just SemType
st) (Just ConstructType
CTFunction)) -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
forall a. Maybe a
Nothing
  Just (IDType (Just SemType
st) (Just ConstructType
CTExternal)) -> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return (IDType -> StateT InferState (Reader InferConfig) IDType)
-> IDType -> StateT InferState (Reader InferConfig) IDType
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
forall a. Maybe a
Nothing
  Maybe IDType
_ -> Name -> SrcSpan -> StateT InferState (Reader InferConfig) ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"non-function invoked by call" SrcSpan
ss StateT InferState (Reader InferConfig) ()
-> StateT InferState (Reader InferConfig) IDType
-> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IDType -> StateT InferState (Reader InferConfig) IDType
forall (m :: * -> *) a. Monad m => a -> m a
return IDType
emptyType

isNumericType :: SemType -> Bool
isNumericType :: SemType -> Bool
isNumericType = \case
  TComplex{} -> Bool
True
  TReal{}    -> Bool
True
  TInteger{} -> Bool
True
  TByte{}    -> Bool
True
  SemType
_            -> Bool
False

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

inferState0 :: FortranVersion -> InferState
inferState0 :: FortranVersion -> InferState
inferState0 FortranVersion
v = InferState :: FortranVersion
-> IntrinsicsTable
-> TypeEnv
-> StructTypeEnv
-> Map Name (Name, Maybe Name)
-> [TypeError]
-> InferState
InferState
  { environ :: TypeEnv
environ     = TypeEnv
forall k a. Map k a
M.empty
  , structs :: StructTypeEnv
structs     = StructTypeEnv
forall k a. Map k a
M.empty
  , entryPoints :: Map Name (Name, Maybe Name)
entryPoints = Map Name (Name, Maybe Name)
forall k a. Map k a
M.empty
  , langVersion :: FortranVersion
langVersion = FortranVersion
v
  , intrinsics :: IntrinsicsTable
intrinsics  = FortranVersion -> IntrinsicsTable
getVersionIntrinsics FortranVersion
v
  , typeErrors :: [TypeError]
typeErrors  = []
  }

inferConfig0 :: InferConfig
inferConfig0 :: InferConfig
inferConfig0 = InferConfig :: Bool -> InferConfig
InferConfig
  { inferConfigAcceptNonCharLengthAsKind :: Bool
inferConfigAcceptNonCharLengthAsKind = Bool
True
  }

runInfer :: FortranVersion -> TypeEnv -> Infer a -> (a, InferState)
runInfer :: forall a. FortranVersion -> TypeEnv -> Infer a -> (a, InferState)
runInfer FortranVersion
v TypeEnv
env Infer a
f = (Reader InferConfig (a, InferState)
 -> InferConfig -> (a, InferState))
-> InferConfig
-> Reader InferConfig (a, InferState)
-> (a, InferState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Reader InferConfig (a, InferState)
-> InferConfig -> (a, InferState)
forall r a. Reader r a -> r -> a
runReader InferConfig
inferConfig0 (Reader InferConfig (a, InferState) -> (a, InferState))
-> Reader InferConfig (a, InferState) -> (a, InferState)
forall a b. (a -> b) -> a -> b
$ (Infer a -> InferState -> Reader InferConfig (a, InferState))
-> InferState -> Infer a -> Reader InferConfig (a, InferState)
forall a b c. (a -> b -> c) -> b -> a -> c
flip Infer a -> InferState -> Reader InferConfig (a, InferState)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ((FortranVersion -> InferState
inferState0 FortranVersion
v) { environ :: TypeEnv
environ = TypeEnv
env }) Infer a
f

typeError :: MonadState InferState m => String -> SrcSpan -> m ()
typeError :: forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
msg SrcSpan
ss = (InferState -> InferState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> m ())
-> (InferState -> InferState) -> m ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { typeErrors :: [TypeError]
typeErrors = (Name
msg, SrcSpan
ss)TypeError -> [TypeError] -> [TypeError]
forall a. a -> [a] -> [a]
:InferState -> [TypeError]
typeErrors InferState
s }

emptyType :: IDType
emptyType :: IDType
emptyType = Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
forall a. Maybe a
Nothing Maybe ConstructType
forall a. Maybe a
Nothing

-- Record the type of the given name.
recordType :: SemType -> ConstructType -> Name -> Infer ()
recordType :: SemType
-> ConstructType
-> Name
-> StateT InferState (Reader InferConfig) ()
recordType SemType
st ConstructType
ct Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
 -> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = Name -> IDType -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Name
n (Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
ct)) (InferState -> TypeEnv
environ InferState
s) }

recordStruct :: StructMemberTypeEnv -> Name -> Infer ()
recordStruct :: TypeEnv -> Name -> StateT InferState (Reader InferConfig) ()
recordStruct TypeEnv
mt Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
 -> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \InferState
s -> InferState
s { structs :: StructTypeEnv
structs = Name -> TypeEnv -> StructTypeEnv -> StructTypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Name
n TypeEnv
mt (InferState -> StructTypeEnv
structs InferState
s) }

-- Record the type (maybe) of the given name.
recordMType :: Maybe SemType -> Maybe ConstructType -> Name -> Infer ()
recordMType :: Maybe SemType
-> Maybe ConstructType
-> Name
-> StateT InferState (Reader InferConfig) ()
recordMType Maybe SemType
st Maybe ConstructType
ct Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
 -> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = Name -> IDType -> TypeEnv -> TypeEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
insert Name
n (Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
st Maybe ConstructType
ct) (InferState -> TypeEnv
environ InferState
s) }

-- Record the CType of the given name.
recordCType :: MonadState InferState m => ConstructType -> Name -> m ()
recordCType :: forall (m :: * -> *).
MonadState InferState m =>
ConstructType -> Name -> m ()
recordCType ConstructType
ct Name
n = (InferState -> InferState) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState) -> m ())
-> (InferState -> InferState) -> m ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = (Maybe IDType -> Maybe IDType) -> Name -> TypeEnv -> TypeEnv
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe IDType -> Maybe IDType
changeFunc Name
n (InferState -> TypeEnv
environ InferState
s) }
  where changeFunc :: Maybe IDType -> Maybe IDType
changeFunc Maybe IDType
mIDType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just (Maybe SemType -> Maybe ConstructType -> IDType
IDType (Maybe IDType
mIDType Maybe IDType -> (IDType -> Maybe SemType) -> Maybe SemType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IDType -> Maybe SemType
idVType) (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
ct))

-- Record the SemType of the given name.
recordSemType :: SemType -> Name -> Infer ()
recordSemType :: SemType -> Name -> StateT InferState (Reader InferConfig) ()
recordSemType SemType
st Name
n = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
 -> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { environ :: TypeEnv
environ = (Maybe IDType -> Maybe IDType) -> Name -> TypeEnv -> TypeEnv
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
M.alter Maybe IDType -> Maybe IDType
changeFunc Name
n (InferState -> TypeEnv
environ InferState
s) }
  where changeFunc :: Maybe IDType -> Maybe IDType
changeFunc Maybe IDType
mIDType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just (Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) (Maybe IDType
mIDType Maybe IDType
-> (IDType -> Maybe ConstructType) -> Maybe ConstructType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IDType -> Maybe ConstructType
idCType))

recordEntryPoint :: Name -> Name -> Maybe Name -> Infer ()
recordEntryPoint :: Name
-> Name -> Maybe Name -> StateT InferState (Reader InferConfig) ()
recordEntryPoint Name
fn Name
en Maybe Name
mRetName = (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((InferState -> InferState)
 -> StateT InferState (Reader InferConfig) ())
-> (InferState -> InferState)
-> StateT InferState (Reader InferConfig) ()
forall a b. (a -> b) -> a -> b
$ \ InferState
s -> InferState
s { entryPoints :: Map Name (Name, Maybe Name)
entryPoints = Name
-> (Name, Maybe Name)
-> Map Name (Name, Maybe Name)
-> Map Name (Name, Maybe Name)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Name
en (Name
fn, Maybe Name
mRetName) (InferState -> Map Name (Name, Maybe Name)
entryPoints InferState
s) }

getRecordedType :: Name -> Infer (Maybe IDType)
getRecordedType :: Name -> Infer (Maybe IDType)
getRecordedType Name
n = (InferState -> Maybe IDType) -> Infer (Maybe IDType)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (TypeEnv -> Maybe IDType)
-> (InferState -> TypeEnv) -> InferState -> Maybe IDType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InferState -> TypeEnv
environ)

getExprRecordedType :: Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType :: forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType e :: Expression (Analysis a)
e@(ExpValue Analysis a
_ SrcSpan
_ (ValVariable Name
_)) = Name -> Infer (Maybe IDType)
getRecordedType (Name -> Infer (Maybe IDType)) -> Name -> Infer (Maybe IDType)
forall a b. (a -> b) -> a -> b
$ Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
e
getExprRecordedType (ExpSubscript Analysis a
_ SrcSpan
_ Expression (Analysis a)
base AList Index (Analysis a)
_) = do
  Maybe IDType
mTy <- Expression (Analysis a) -> Infer (Maybe IDType)
forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType Expression (Analysis a)
base
  case Maybe IDType
mTy of
    Just (IDType Maybe SemType
semTy (Just CTArray{})) -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IDType -> Infer (Maybe IDType))
-> (IDType -> Maybe IDType) -> IDType -> Infer (Maybe IDType)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IDType -> Maybe IDType
forall a. a -> Maybe a
Just (IDType -> Infer (Maybe IDType)) -> IDType -> Infer (Maybe IDType)
forall a b. (a -> b) -> a -> b
$ Maybe SemType -> Maybe ConstructType -> IDType
IDType Maybe SemType
semTy (ConstructType -> Maybe ConstructType
forall a. a -> Maybe a
Just ConstructType
CTVariable)
    Maybe IDType
_ -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
forall a. Maybe a
Nothing
getExprRecordedType (ExpDataRef Analysis a
_ SrcSpan
_ Expression (Analysis a)
base Expression (Analysis a)
ref) = do
  Maybe IDType
mTy <- Expression (Analysis a) -> Infer (Maybe IDType)
forall a. Data a => Expression (Analysis a) -> Infer (Maybe IDType)
getExprRecordedType Expression (Analysis a)
base
  case Maybe IDType
mTy of
    Just (IDType (Just (TCustom Name
n)) Maybe ConstructType
_) -> do
      Maybe TypeEnv
mStructEnv <- (InferState -> Maybe TypeEnv)
-> StateT InferState (Reader InferConfig) (Maybe TypeEnv)
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets (Name -> StructTypeEnv -> Maybe TypeEnv
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
n (StructTypeEnv -> Maybe TypeEnv)
-> (InferState -> StructTypeEnv) -> InferState -> Maybe TypeEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InferState -> StructTypeEnv
structs)
      case Maybe TypeEnv
mStructEnv of
        Maybe TypeEnv
Nothing -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
forall a. Maybe a
Nothing
        Just TypeEnv
env -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe IDType -> Infer (Maybe IDType))
-> Maybe IDType -> Infer (Maybe IDType)
forall a b. (a -> b) -> a -> b
$ Name -> TypeEnv -> Maybe IDType
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup (Expression (Analysis a) -> Name
forall a. Expression (Analysis a) -> Name
varName Expression (Analysis a)
ref) TypeEnv
env
    Maybe IDType
x -> Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
x
getExprRecordedType Expression (Analysis a)
_ = Maybe IDType -> Infer (Maybe IDType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe IDType
forall a. Maybe a
Nothing

-- Set the idType annotation
setIDType :: Annotated f => IDType -> f (Analysis a) -> f (Analysis a)
setIDType :: forall (f :: * -> *) a.
Annotated f =>
IDType -> f (Analysis a) -> f (Analysis a)
setIDType IDType
ty f (Analysis a)
x =
    let a :: Analysis a
a = f (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation f (Analysis a)
x
     in Analysis a -> f (Analysis a) -> f (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation (Analysis a
a { idType :: Maybe IDType
idType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just IDType
ty }) f (Analysis a)
x

-- Get the idType annotation
getIDType :: (Annotated f, Data a) => f (Analysis a) -> Maybe IDType
getIDType :: forall (f :: * -> *) a.
(Annotated f, Data a) =>
f (Analysis a) -> Maybe IDType
getIDType f (Analysis a)
x = Analysis a -> Maybe IDType
forall a. Analysis a -> Maybe IDType
idType (f (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation f (Analysis a)
x)

-- | 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 :: forall (f :: * -> *) a.
(Annotated f, Data a) =>
SemType -> f (Analysis a) -> f (Analysis a)
setSemType SemType
st f (Analysis a)
x =
    let anno :: Analysis a
anno  = f (Analysis a) -> Analysis a
forall (f :: * -> *) a. Annotated f => f a -> a
getAnnotation f (Analysis a)
x
        idt :: Maybe IDType
idt   = Analysis a -> Maybe IDType
forall a. Analysis a -> Maybe IDType
idType Analysis a
anno
        anno' :: Analysis a
anno' = Analysis a
anno { idType :: Maybe IDType
idType = IDType -> Maybe IDType
forall a. a -> Maybe a
Just (Maybe IDType -> IDType
setIDTypeSemType Maybe IDType
idt) }
     in Analysis a -> f (Analysis a) -> f (Analysis a)
forall (f :: * -> *) a. Annotated f => a -> f a -> f a
setAnnotation Analysis a
anno' f (Analysis a)
x
  where
    setIDTypeSemType :: Maybe IDType -> IDType
    setIDTypeSemType :: Maybe IDType -> IDType
setIDTypeSemType (Just (IDType Maybe SemType
_ Maybe ConstructType
mCt)) = Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
mCt
    setIDTypeSemType Maybe IDType
Nothing               = Maybe SemType -> Maybe ConstructType -> IDType
IDType (SemType -> Maybe SemType
forall a. a -> Maybe a
Just SemType
st) Maybe ConstructType
forall a. Maybe a
Nothing

-- 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 :: forall a. Data a => UniFunc ProgramFile ProgramUnit a
allProgramUnits = ProgramFile (Analysis a) -> [ProgramUnit (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

allDeclarators :: Data a => UniFunc ProgramFile Declarator a
allDeclarators :: forall a. Data a => UniFunc ProgramFile Declarator a
allDeclarators = ProgramFile (Analysis a) -> [Declarator (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

allStatements :: (Data a, Data (f (Analysis a))) => UniFunc f Statement a
allStatements :: forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Statement a
allStatements = f (Analysis a) -> [Statement (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

allExpressions :: (Data a, Data (f (Analysis a))) => UniFunc f Expression a
allExpressions :: forall a (f :: * -> *).
(Data a, Data (f (Analysis a))) =>
UniFunc f Expression a
allExpressions = f (Analysis a) -> [Expression (Analysis a)]
forall from to. Biplate from to => from -> [to]
universeBi

isAttrDimension :: Attribute a -> Bool
isAttrDimension :: forall a. Attribute a -> Bool
isAttrDimension AttrDimension {} = Bool
True
isAttrDimension Attribute a
_                = Bool
False

isAttrParameter :: Attribute a -> Bool
isAttrParameter :: forall a. Attribute a -> Bool
isAttrParameter AttrParameter {} = Bool
True
isAttrParameter Attribute a
_                = Bool
False

isAttrExternal :: Attribute a -> Bool
isAttrExternal :: forall a. Attribute a -> Bool
isAttrExternal AttrExternal {} = Bool
True
isAttrExternal Attribute a
_               = Bool
False

isIxSingle :: Index a -> Bool
isIxSingle :: forall a. Index a -> Bool
isIxSingle IxSingle {} = Bool
True
isIxSingle Index a
_           = Bool
False

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

-- 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
    :: (MonadState InferState m, MonadReader InferConfig m)
    => SrcSpan -> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m SemType
deriveSemTypeFromDeclaration :: forall (m :: * -> *) a.
(MonadState InferState m, MonadReader InferConfig m) =>
SrcSpan
-> SrcSpan -> TypeSpec a -> Maybe (Expression a) -> m SemType
deriveSemTypeFromDeclaration SrcSpan
stmtSs SrcSpan
declSs ts :: TypeSpec a
ts@(TypeSpec a
tsA SrcSpan
tsSS BaseType
bt Maybe (Selector a)
mSel) Maybe (Expression a)
mLenExpr =
    case Maybe (Expression a)
mLenExpr of
      Maybe (Expression a)
Nothing ->
        -- no RHS length, can continue with regular deriving
        TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m 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 -> m SemType
forall {m :: * -> *}.
MonadState InferState m =>
Expression a -> m SemType
deriveCharWithLen Expression a
lenExpr

          BaseType
_ -> do
            -- oh dear! probably the nonstandard kind param syntax @INTEGER x*2@
            (InferConfig -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks InferConfig -> Bool
inferConfigAcceptNonCharLengthAsKind m Bool -> (Bool -> m SemType) -> m SemType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Bool
False -> do
                (Name -> SrcSpan -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
                    Name
"non-CHARACTER variable given a length @ "
                 Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
lenExpr)
                 Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
": ignoring"
                TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts
              Bool
True -> do
                (Name -> SrcSpan -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
                    Name
"non-CHARACTER variable given a length @ "
                 Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
lenExpr)
                 Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
": treating as nonstandard kind parameter syntax"

                -- silly check to give an in-depth type error
                case Maybe (Selector a)
mSel of
                  Just (Selector a
sA SrcSpan
sSS Maybe (Expression a)
sLen Maybe (Expression a)
sMKpExpr) -> do
                    ()
_ <- case Maybe (Expression a)
sMKpExpr of
                           Maybe (Expression a)
Nothing     -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                           Just Expression a
kpExpr -> do
                             -- also got a LHS kind param, inform that we are
                             -- overriding
                             (Name -> SrcSpan -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
                                 Name
"non-CHARACTER variable"
                              Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" given both"
                              Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" LHS kind @ " Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
kpExpr) Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" and"
                              Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" nonstandard RHS kind @ " Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
lenExpr)
                              Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
": specific RHS declarator overrides"
                             () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    let sel :: Selector a
sel = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
Selector a
sA SrcSpan
sSS Maybe (Expression a)
sLen (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
lenExpr)
                        ts' :: TypeSpec a
ts' = a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
TypeSpec a
tsA SrcSpan
tsSS BaseType
bt (Selector a -> Maybe (Selector a)
forall a. a -> Maybe a
Just Selector a
sel)
                     in TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts'
                  Maybe (Selector a)
Nothing ->
                    let sel :: Selector a
sel = a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
Selector a
forall a. HasCallStack => a
undefined SrcSpan
forall a. HasCallStack => a
undefined Maybe (Expression a)
forall a. Maybe a
Nothing (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
lenExpr)
                        ts' :: TypeSpec a
ts' = a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
TypeSpec a
tsA SrcSpan
tsSS BaseType
bt (Selector a -> Maybe (Selector a)
forall a. a -> Maybe a
Just Selector a
sel)
                     in TypeSpec a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec TypeSpec a
ts'

  where
    -- 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 -> m SemType
deriveCharWithLen Expression a
lenExpr =
        case Maybe (Selector a)
mSel of
          Just (Selector a
selA SrcSpan
selSs Maybe (Expression a)
mSelLenExpr Maybe (Expression a)
mKindExpr) -> do
            ()
_ <- case Maybe (Expression a)
mSelLenExpr of
                   Just Expression a
_ -> do
                      -- 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 -> m ()) -> SrcSpan -> Name -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError SrcSpan
stmtSs (Name -> m ()) -> Name -> m ()
forall a b. (a -> b) -> a -> b
$
                         Name
"warning: CHARACTER variable @ " Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
declSs
                      Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" has length in LHS type spec and RHS declarator"
                      Name -> ShowS
forall a. Semigroup a => a -> a -> a
<> Name
" -- specific RHS declarator overrides"
                   Maybe (Expression a)
_ -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- 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 -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
BaseType -> Selector a -> m 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
_ Kind
k) = BaseType -> SemType
deriveSemTypeFromBaseType BaseType
TypeCharacter
             in SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> SemType
TCharacter (Expression a -> CharacterLen
forall a. Expression a -> CharacterLen
charLenSelector' Expression a
lenExpr) Kind
k

-- | Attempt to derive a 'SemType' from a 'TypeSpec'.
deriveSemTypeFromTypeSpec
    :: MonadState InferState m => TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec :: forall (m :: * -> *) a.
MonadState InferState m =>
TypeSpec a -> m SemType
deriveSemTypeFromTypeSpec (TypeSpec a
_ SrcSpan
_ BaseType
bt Maybe (Selector a)
mSel) =
    case Maybe (Selector a)
mSel of
      -- Selector present: we might have kind/other info provided
      Just Selector a
sel -> BaseType -> Selector a -> m SemType
forall (m :: * -> *) a.
MonadState InferState m =>
BaseType -> Selector a -> m SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
bt Selector a
sel
      -- no Selector: derive using default kinds etc.
      Maybe (Selector a)
Nothing  -> SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt

-- | Attempt to derive a SemType from a 'BaseType' and a 'Selector'.
deriveSemTypeFromBaseTypeAndSelector
    :: MonadState InferState m => BaseType -> Selector a -> m SemType
deriveSemTypeFromBaseTypeAndSelector :: forall (m :: * -> *) a.
MonadState InferState m =>
BaseType -> Selector a -> m SemType
deriveSemTypeFromBaseTypeAndSelector BaseType
bt (Selector a
_ SrcSpan
ss Maybe (Expression a)
mLen Maybe (Expression a)
mKindExpr) = do
    SemType
st <- Maybe (Expression a) -> m SemType
forall {a}. Maybe (Expression a) -> m SemType
deriveFromBaseTypeAndKindExpr Maybe (Expression a)
mKindExpr
    case Maybe (Expression a)
mLen of
      Maybe (Expression a)
Nothing      -> SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return SemType
st
      Just Expression a
lenExpr ->
        case SemType
st of
          TCharacter CharacterLen
_ Kind
kind ->
            let charLen :: CharacterLen
charLen = Expression a -> CharacterLen
forall a. Expression a -> CharacterLen
charLenSelector' Expression a
lenExpr
             in SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> SemType
TCharacter CharacterLen
charLen Kind
kind
          SemType
_ -> do
            -- (unreachable code path in correct parser operation)
            Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"only CHARACTER types can specify length (separate to kind)" SrcSpan
ss
            SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return SemType
st
  where
    deriveFromBaseTypeAndKindExpr :: Maybe (Expression a) -> m SemType
deriveFromBaseTypeAndKindExpr = \case
      Maybe (Expression a)
Nothing -> m SemType
defaultSemType
      Just Expression a
kindExpr ->
        case Expression a
kindExpr of
          -- FIXME: only support integer kind selectors for now, no params/exprs
          -- (would require a wide change across codebase)
          ExpValue a
_ SrcSpan
_ (ValInteger Name
k Maybe (Expression a)
_) ->
            BaseType -> Kind -> m SemType
forall (m :: * -> *).
MonadState InferState m =>
BaseType -> Kind -> m SemType
deriveSemTypeFromBaseTypeAndKind BaseType
bt (Name -> Kind
forall a. Read a => Name -> a
read Name
k)
          Expression a
_ -> do
            Name -> SrcSpan -> m ()
forall (m :: * -> *).
MonadState InferState m =>
Name -> SrcSpan -> m ()
typeError Name
"unsupported or invalid kind selector, only literal integers allowed" (Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
kindExpr)
            m SemType
defaultSemType
    defaultSemType :: m SemType
defaultSemType = SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt

-- | Derive 'SemType' directly from 'BaseType', using relevant default kinds.
deriveSemTypeFromBaseType :: BaseType -> SemType
deriveSemTypeFromBaseType :: BaseType -> SemType
deriveSemTypeFromBaseType = \case
  BaseType
TypeInteger         -> Kind -> SemType
TInteger Kind
4
  BaseType
TypeReal            -> Kind -> SemType
TReal    Kind
4
  BaseType
TypeComplex         -> Kind -> SemType
TComplex Kind
4
  BaseType
TypeLogical         -> Kind -> SemType
TLogical Kind
4

  -- 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 -> Kind -> SemType
TReal    Kind
8
  BaseType
TypeDoubleComplex   -> Kind -> SemType
TComplex Kind
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            -> Kind -> SemType
TByte    Kind
noKind

  -- CHARACTERs default to len=1, kind=1 (non-1 is rare)
  BaseType
TypeCharacter       -> CharacterLen -> Kind -> SemType
TCharacter (Kind -> CharacterLen
CharLenInt Kind
1) Kind
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 :: Kind
noKind = -Kind
1

deriveSemTypeFromBaseTypeAndKind
    :: MonadState InferState m => BaseType -> Kind -> m SemType
deriveSemTypeFromBaseTypeAndKind :: forall (m :: * -> *).
MonadState InferState m =>
BaseType -> Kind -> m SemType
deriveSemTypeFromBaseTypeAndKind BaseType
bt Kind
k =
    SemType -> m SemType
forall (m :: * -> *) a. Monad m => a -> m a
return (SemType -> m SemType) -> SemType -> m SemType
forall a b. (a -> b) -> a -> b
$ SemType -> Kind -> SemType
setTypeKind (BaseType -> SemType
deriveSemTypeFromBaseType BaseType
bt) Kind
k

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

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