{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}

module Language.Fortran.Vars.TypeCheck
  ( Kind
  , TypeError(..)
  , TypeOf
  , typeOf
  )
where
import           Prelude                 hiding ( GT
                                                , EQ
                                                , LT
                                                )
import qualified Data.Map                      as M
import           Data.Char                      ( toUpper )
import           Data.Data                      ( toConstr )
import           Data.Maybe                     ( fromJust )
import           Text.Read                      ( readMaybe )
import           Language.Fortran.AST           ( Expression(..)
                                                , Value(..)
                                                , AList(..)
                                                , aStrip
                                                , aStrip'
                                                , Argument(..)
                                                , DoSpecification(..)
                                                , Statement(..)
                                                , Name
                                                , BinaryOp(..)
                                                , Index(..)
                                                )
import           Language.Fortran.Intrinsics    ( getVersionIntrinsics
                                                , getIntrinsicReturnType
                                                , IntrinsicType(..)
                                                )
import           Language.Fortran.ParserMonad   ( FortranVersion(..) )

import           Language.Fortran.Util.Position ( SrcSpan
                                                , getSpan
                                                )
import           Language.Fortran.Vars.Types
                                                ( SymbolTableEntry(..)
                                                , ExpVal(..)
                                                , SymbolTable
                                                , StructureTable
                                                , Kind
                                                , Type(..)
                                                , SemType(..)
                                                , CharacterLen(..)
                                                , TypeError(..)
                                                , TypeOf
                                                , typeError
                                                )
import           Language.Fortran.Vars.Kind
                                                ( getTypeKind
                                                , setTypeKind
                                                )
import           Language.Fortran.Vars.Eval
                                                ( eval' )
import           Language.Fortran.Vars.StructureTable
                                                ( lookupField )

import           Language.Fortran.Analysis.SemanticTypes
                                                ( charLenConcat )


-- | Given 'SymbolTable' of a 'ProgramUnit', and an 'Expression' within
-- the 'ProgramUnit', determines the 'Type' of the 'Exression'
typeOf :: StructureTable -> SymbolTable -> Expression a -> Either TypeError Type
typeOf :: StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
expr = case Expression a
expr of
  ExpValue a
_ SrcSpan
_ (ValVariable Name
name) -> SymbolTable -> Name -> Either TypeError Type
typeOfSymbol SymbolTable
symTable Name
name
  ExpValue a
_ SrcSpan
s Value a
val                -> SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue SrcSpan
s StructureTable
strTable SymbolTable
symTable Value a
val
  ExpUnary a
_ SrcSpan
_ UnaryOp
_ Expression a
e                -> StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
e
  ExpBinary a
_ SrcSpan
s BinaryOp
op Expression a
e1 Expression a
e2 -> SrcSpan
-> StructureTable
-> SymbolTable
-> BinaryOp
-> Expression a
-> Expression a
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> BinaryOp
-> Expression a
-> Expression a
-> Either TypeError Type
typeOfBinaryExp SrcSpan
s StructureTable
strTable SymbolTable
symTable BinaryOp
op Expression a
e1 Expression a
e2
  ExpFunctionCall a
_ SrcSpan
_ (ExpValue a
_ SrcSpan
s (ValVariable Name
name)) Maybe (AList Argument a)
margs ->
    SrcSpan
-> StructureTable
-> SymbolTable
-> Name
-> [Argument a]
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Name
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
s StructureTable
strTable SymbolTable
symTable Name
name (Maybe (AList Argument a) -> [Argument a]
forall (t :: * -> *) a. Maybe (AList t a) -> [t a]
aStrip' Maybe (AList Argument a)
margs)
  ExpFunctionCall a
_ SrcSpan
_ (ExpValue a
_ SrcSpan
s (ValIntrinsic Name
name)) Maybe (AList Argument a)
margs ->
    SrcSpan
-> StructureTable
-> SymbolTable
-> Name
-> [Argument a]
-> Either TypeError Type
forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Name
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
s StructureTable
strTable SymbolTable
symTable Name
name (Maybe (AList Argument a) -> [Argument a]
forall (t :: * -> *) a. Maybe (AList t a) -> [t a]
aStrip' Maybe (AList Argument a)
margs)
  ExpSubscript a
_ SrcSpan
s Expression a
arr (AList a
_ SrcSpan
_ args :: [Index a]
args@(IxSingle{} : [Index a]
_)) ->
    let isIxRange :: Index a -> Bool
isIxRange = \case
          IxRange{} -> Bool
True
          Index a
_         -> Bool
False
    in  if (Index a -> Bool) -> [Index a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Index a -> Bool
forall a. Index a -> Bool
isIxRange [Index a]
args
          then TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> (Name -> TypeError) -> Name -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Name -> TypeError
typeError SrcSpan
s (Name -> Either TypeError Type) -> Name -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Name
"Unexpected array range"
          else case StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
arr of
            Right (TArray Type
ty Maybe Dimensions
_) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
ty
            Right Type
_ ->
              TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> (Name -> TypeError) -> Name -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Name -> TypeError
typeError SrcSpan
s (Name -> Either TypeError Type) -> Name -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Name
"Tried to access elements of scalar"
            Either TypeError Type
err -> Either TypeError Type
err
  ExpSubscript a
_ SrcSpan
s Expression a
arr (AList a
_ SrcSpan
_ (r :: Index a
r@IxRange{} : [Index a]
_)) -> do
    Type
ty <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
arr
    case Type
ty of
      TCharacter CharacterLen
_ Kind
_ -> SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
forall a.
SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
typeOfSubString SrcSpan
s SymbolTable
symTable StructureTable
strTable Type
ty Index a
r
      Type
_              -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
ty
  ExpImpliedDo a
_ SrcSpan
_ AList Expression a
es DoSpecification a
doSpec -> do
    Kind
dim <- SymbolTable -> DoSpecification a -> Either TypeError Kind
forall a. SymbolTable -> DoSpecification a -> Either TypeError Kind
specToDim SymbolTable
symTable DoSpecification a
doSpec
    Type
ty  <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable (Expression a -> Either TypeError Type)
-> ([Expression a] -> Expression a)
-> [Expression a]
-> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Expression a] -> Expression a
forall a. [a] -> a
head ([Expression a] -> Either TypeError Type)
-> [Expression a] -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ AList Expression a -> [Expression a]
forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression a
es
    Type -> Either TypeError Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ case Type
ty of
      TArray Type
ty' (Just [(Kind
1, Kind
dim')]) -> Type -> Maybe Dimensions -> Type
TArray Type
ty' (Dimensions -> Maybe Dimensions
forall a. a -> Maybe a
Just [(Kind
1, Kind
dim Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
* Kind
dim')])
      TArray Type
_ Maybe Dimensions
_ -> Name -> Type
forall a. HasCallStack => Name -> a
error Name
"Unexpected array type in implied do"
      Type
_ -> Type -> Maybe Dimensions -> Type
TArray Type
ty (Dimensions -> Maybe Dimensions
forall a. a -> Maybe a
Just [(Kind
1, Kind
dim)])

  ExpDataRef a
_ SrcSpan
_ Expression a
es (ExpValue a
_ SrcSpan
_ (ValVariable Name
name)) -> do
    Type
ty <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
es
    StructureTable -> Type -> Name -> Either TypeError Type
lookupField StructureTable
strTable Type
ty Name
name
  Expression a
_ -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> (SrcSpan -> TypeError) -> SrcSpan -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> TypeError
UnknownType (SrcSpan -> Either TypeError Type)
-> SrcSpan -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Expression a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Expression a
expr

-- | Internal function to get array size out of a DoSpecification
specToDim :: SymbolTable -> DoSpecification a -> Either TypeError Int
specToDim :: SymbolTable -> DoSpecification a -> Either TypeError Kind
specToDim SymbolTable
symt (DoSpecification a
_ SrcSpan
s (StExpressionAssign a
_ SrcSpan
_ Expression a
_ Expression a
start) Expression a
end Maybe (Expression a)
step)
  = let evalInt :: Expression a -> Either TypeError Kind
evalInt Expression a
x = case SymbolTable -> Expression a -> Either Name ExpVal
forall a. SymbolTable -> Expression a -> Either Name ExpVal
eval' SymbolTable
symt Expression a
x of
          Right (Int Kind
y) -> Kind -> Either TypeError Kind
forall a b. b -> Either a b
Right Kind
y
          Right ExpVal
_ -> TypeError -> Either TypeError Kind
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Kind)
-> (Name -> TypeError) -> Name -> Either TypeError Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Name -> TypeError
typeError SrcSpan
s (Name -> Either TypeError Kind) -> Name -> Either TypeError Kind
forall a b. (a -> b) -> a -> b
$ Name
"non int value in do spec " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> SrcSpan -> Name
forall a. Show a => a -> Name
show SrcSpan
s
          Left Name
err -> TypeError -> Either TypeError Kind
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Kind)
-> (Name -> TypeError) -> Name -> Either TypeError Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Name -> TypeError
typeError SrcSpan
s (Name -> Either TypeError Kind) -> Name -> Either TypeError Kind
forall a b. (a -> b) -> a -> b
$ Name
err
    in  do
          Kind
start' <- Expression a -> Either TypeError Kind
forall a. Expression a -> Either TypeError Kind
evalInt Expression a
start
          Kind
end'   <- Expression a -> Either TypeError Kind
forall a. Expression a -> Either TypeError Kind
evalInt Expression a
end
          case Maybe (Expression a)
step of
            Just Expression a
x -> do
              Kind
step' <- Expression a -> Either TypeError Kind
forall a. Expression a -> Either TypeError Kind
evalInt Expression a
x
              Kind -> Either TypeError Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Either TypeError Kind) -> Kind -> Either TypeError Kind
forall a b. (a -> b) -> a -> b
$ ((Kind
end' Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
- Kind
start') Kind -> Kind -> Kind
forall a. Integral a => a -> a -> a
`div` Kind
step') Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
+ Kind
1
            Maybe (Expression a)
Nothing -> Kind -> Either TypeError Kind
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Kind -> Either TypeError Kind) -> Kind -> Either TypeError Kind
forall a b. (a -> b) -> a -> b
$ (Kind
end' Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
- Kind
start') Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
+ Kind
1
specToDim SymbolTable
_ DoSpecification a
_ = Name -> Either TypeError Kind
forall a. HasCallStack => Name -> a
error Name
"Unexpected do specification structure"

-- | Internal function to determine the 'Type' of a symbol
typeOfSymbol :: SymbolTable -> Name -> Either TypeError Type
typeOfSymbol :: SymbolTable -> Name -> Either TypeError Type
typeOfSymbol SymbolTable
symTable Name
name = case Name -> SymbolTable -> Maybe SymbolTableEntry
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
name SymbolTable
symTable of
  Just SymbolTableEntry
entry -> case SymbolTableEntry
entry of
    SParameter Type
t ExpVal
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
    SVariable  Type
t Location
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
    SDummy    Type
t    -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
    SExternal Type
t    -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right Type
t
  Maybe SymbolTableEntry
Nothing -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Name -> TypeError
UnboundVariable Name
name

-- | Internal function to determine the 'Type' of a constant
typeOfValue
  :: SrcSpan
  -> StructureTable
  -> SymbolTable
  -> Value a
  -> Either TypeError Type
typeOfValue :: SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue SrcSpan
sp StructureTable
strTable SymbolTable
symTable Value a
v = case Value a
v of
  ValInteger Name
i -> case Name -> Maybe Kind
forall a. Read a => Name -> Maybe a
readMaybe @Int Name
i of
    Just Kind
_  -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Kind -> Type
TInteger Kind
4
    Maybe Kind
Nothing -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Kind -> Type
TByte Kind
4
  ValReal Name
r | Char
'D' Char -> Name -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (Char -> Char) -> Name -> Name
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toUpper Name
r -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TReal Kind
8)
            | Bool
otherwise                -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TReal Kind
4)
  ValComplex Expression a
real Expression a
imaginary -> do
    Type
tr <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
real
    Type
ti <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
imaginary
    if Type
tr Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Kind -> Type
TReal Kind
8 Bool -> Bool -> Bool
|| Type
ti Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Kind -> Type
TReal Kind
8
      then Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Type
TComplex Kind
16)
      else Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Kind -> Type
TComplex Kind
8)
  ValString    Name
s -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> Type
TCharacter (Kind -> CharacterLen
CharLenInt (Name -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length Name
s)) Kind
1
  ValHollerith Name
s -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Kind -> Type) -> Kind -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Type
TByte (Kind -> Either TypeError Type) -> Kind -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Name -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length Name
s
  ValLogical   Name
_ -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Kind -> Type
TLogical Kind
4
  Value a
_              -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType SrcSpan
sp


promote :: Type -> Type -> Type
promote :: Type -> Type -> Type
promote Type
t1 Type
t2
  | Type -> Constr
forall a. Data a => a -> Constr
toConstr Type
t1 Constr -> Constr -> Bool
forall a. Eq a => a -> a -> Bool
== Type -> Constr
forall a. Data a => a -> Constr
toConstr Type
t2 = case
      Kind -> Kind -> Kind
forall a. Ord a => a -> a -> a
max (Kind -> Kind -> Kind) -> Maybe Kind -> Maybe (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Maybe Kind
getTypeKind Type
t1 Maybe (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Maybe Kind
getTypeKind Type
t2
    of
      Just Kind
k -> Type -> Maybe Kind -> Type
setTypeKind Type
t1 (Maybe Kind -> Type) -> Maybe Kind -> Type
forall a b. (a -> b) -> a -> b
$ Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
      Maybe Kind
Nothing ->
        Name -> Type
forall a. HasCallStack => Name -> a
error
          (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$  Name
"dynamic type in promotion between: "
          Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Type -> Name
forall a. Show a => a -> Name
show Type
t1
          Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" and "
          Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Type -> Name
forall a. Show a => a -> Name
show Type
t2
  | Bool
otherwise = case (Type
t1, Type
t2) of
    (TComplex Kind
k , Type
_          ) -> Kind -> Type
TComplex Kind
k
    (Type
_          , TComplex Kind
k ) -> Kind -> Type
TComplex Kind
k
    (TReal Kind
k    , Type
_          ) -> Kind -> Type
TReal Kind
k
    (Type
_          , TReal Kind
k    ) -> Kind -> Type
TReal Kind
k
    (TLogical Kind
k1, TInteger Kind
k2) -> Kind -> Type
TInteger (Kind -> Type) -> Kind -> Type
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> Kind
forall a. Ord a => a -> a -> a
max Kind
k1 Kind
k2
    (TInteger Kind
k1, TLogical Kind
k2) -> Kind -> Type
TInteger (Kind -> Type) -> Kind -> Type
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> Kind
forall a. Ord a => a -> a -> a
max Kind
k1 Kind
k2
    (TInteger Kind
k , Type
_          ) -> Kind -> Type
TInteger Kind
k
    (Type
_          , TInteger Kind
k ) -> Kind -> Type
TInteger Kind
k
    (TLogical Kind
k , Type
_          ) -> Kind -> Type
TLogical Kind
k
    (Type
_          , TLogical Kind
k ) -> Kind -> Type
TLogical Kind
k
    (Type, Type)
_ -> Name -> Type
forall a. HasCallStack => Name -> a
error (Name -> Type) -> Name -> Type
forall a b. (a -> b) -> a -> b
$ Name
"Incompatible types: " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Type -> Name
forall a. Show a => a -> Name
show Type
t1 Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Type -> Name
forall a. Show a => a -> Name
show Type
t2

-- | Internal function fo determine type of binary expression
typeOfBinaryExp
  :: SrcSpan
  -> StructureTable
  -> SymbolTable
  -> BinaryOp
  -> Expression a
  -> Expression a
  -> Either TypeError Type
typeOfBinaryExp :: SrcSpan
-> StructureTable
-> SymbolTable
-> BinaryOp
-> Expression a
-> Expression a
-> Either TypeError Type
typeOfBinaryExp SrcSpan
sp StructureTable
strTable SymbolTable
symTable BinaryOp
op Expression a
e1 Expression a
e2
  |
  -- Relational
    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] = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TLogical Kind
4)
  | Bool
otherwise = do
    Type
st1 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
e1
    Type
st2 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
e2
    SrcSpan -> BinaryOp -> Type -> Type -> Either TypeError Type
typeOfBinaryExp' SrcSpan
sp BinaryOp
op Type
st1 Type
st2

-- | Internal funciton for determining type of binary expression.
typeOfBinaryExp' :: SrcSpan -> BinaryOp -> Type -> Type -> Either TypeError Type
typeOfBinaryExp' :: SrcSpan -> BinaryOp -> Type -> Type -> Either TypeError Type
typeOfBinaryExp' SrcSpan
sp BinaryOp
op Type
t1 Type
t2
  |
  -- Character
    BinaryOp
op BinaryOp -> BinaryOp -> Bool
forall a. Eq a => a -> a -> Bool
== BinaryOp
Concatenation
  -- TODO
  -- = Right . TCharacter $ (+) <$> k1 <*> k2
  = case Type
t1 of
      TCharacter CharacterLen
l1 Kind
k1 ->
        case Type
t2 of
          TCharacter CharacterLen
l2 Kind
k2 -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> Type
TCharacter (CharacterLen -> CharacterLen -> CharacterLen
charLenConcat CharacterLen
l1 CharacterLen
l2) Kind
k1
          Type
_ -> Name -> Either TypeError Type
forall a. HasCallStack => Name -> a
error Name
"shit 1"
      Type
_ -> Name -> Either TypeError Type
forall a. HasCallStack => Name -> a
error Name
"shit 2"
  |
  -- Logical
    BinaryOp
op BinaryOp -> [BinaryOp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
And, BinaryOp
Or, BinaryOp
Equivalent, BinaryOp
NotEquivalent, BinaryOp
XOr]
  = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type)
-> (Maybe Kind -> Type) -> Maybe Kind -> Either TypeError Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> Type
TLogical (Kind -> Type) -> (Maybe Kind -> Kind) -> Maybe Kind -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe Kind -> Kind
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Kind -> Either TypeError Type)
-> Maybe Kind -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> Kind
forall a. Ord a => a -> a -> a
max (Kind -> Kind -> Kind) -> Maybe Kind -> Maybe (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Kind
k1 Maybe (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Kind
k2
  |
  -- Arithmetic
    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]
  = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
promote Type
t1 Type
t2
  | Bool
otherwise
  = TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType SrcSpan
sp
 where
  k1 :: Maybe Kind
k1 = Type -> Maybe Kind
getTypeKind Type
t1
  k2 :: Maybe Kind
k2 = Type -> Maybe Kind
getTypeKind Type
t2


-- | Internal function to determine the type of a substring
-- If either of the indexes cannot be evaluated then we return a dynamically
-- sized character type
-- TODO this is the worst one
typeOfSubString
  :: SrcSpan
  -> SymbolTable
  -> StructureTable
  -> Type
  -> Index a
  -> Either TypeError Type
typeOfSubString :: SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
typeOfSubString SrcSpan
sp SymbolTable
symt StructureTable
strt Type
ty (IxRange a
_ SrcSpan
_ Maybe (Expression a)
lower Maybe (Expression a)
upper Maybe (Expression a)
_) = do
  Either TypeError (Maybe Type) -> Either TypeError ()
forall a. Either a (Maybe Type) -> Either TypeError ()
isInteger (Either TypeError (Maybe Type) -> Either TypeError ())
-> Either TypeError (Maybe Type) -> Either TypeError ()
forall a b. (a -> b) -> a -> b
$ (Expression a -> Either TypeError Type)
-> Maybe (Expression a) -> Either TypeError (Maybe Type)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strt SymbolTable
symt) Maybe (Expression a)
lower
  Either TypeError (Maybe Type) -> Either TypeError ()
forall a. Either a (Maybe Type) -> Either TypeError ()
isInteger (Either TypeError (Maybe Type) -> Either TypeError ())
-> Either TypeError (Maybe Type) -> Either TypeError ()
forall a b. (a -> b) -> a -> b
$ (Expression a -> Either TypeError Type)
-> Maybe (Expression a) -> Either TypeError (Maybe Type)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strt SymbolTable
symt) Maybe (Expression a)
upper
  Type -> Either TypeError Type
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ CharacterLen -> Kind -> Type
TCharacter CharacterLen
calcLen Kind
1
 where
  calcLen :: CharacterLen
calcLen =
      case (\Kind
x Kind
y -> Kind
y Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
- Kind
x Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
+ Kind
1) (Kind -> Kind -> Kind) -> Maybe Kind -> Maybe (Kind -> Kind)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Kind
lowerIndex Maybe (Kind -> Kind) -> Maybe Kind -> Maybe Kind
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Kind
upperIndex of
        Maybe Kind
Nothing  -> CharacterLen
CharLenStar
        Just Kind
len -> Kind -> CharacterLen
CharLenInt Kind
len
  isInteger :: Either a (Maybe Type) -> Either TypeError ()
isInteger = \case
    Right (Just (TInteger Kind
_)) -> () -> Either TypeError ()
forall a b. b -> Either a b
Right ()
    Right Maybe Type
Nothing -> () -> Either TypeError ()
forall a b. b -> Either a b
Right ()
    Either a (Maybe Type)
_ -> TypeError -> Either TypeError ()
forall a b. a -> Either a b
Left (TypeError -> Either TypeError ())
-> (Name -> TypeError) -> Name -> Either TypeError ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> Name -> TypeError
typeError SrcSpan
sp (Name -> Either TypeError ()) -> Name -> Either TypeError ()
forall a b. (a -> b) -> a -> b
$ Name
"Index  wasn't an integer type"
  upperIndex :: Maybe Kind
upperIndex = let Just Kind
k = Type -> Maybe Kind
getTypeKind Type
ty in Kind -> Maybe (Expression a) -> Maybe Kind
forall a. Kind -> Maybe (Expression a) -> Maybe Kind
getIndex Kind
k Maybe (Expression a)
upper
  lowerIndex :: Maybe Kind
lowerIndex = Kind -> Maybe (Expression a) -> Maybe Kind
forall a. Kind -> Maybe (Expression a) -> Maybe Kind
getIndex Kind
1 Maybe (Expression a)
lower
  getIndex :: Int -> Maybe (Expression a) -> Maybe Int
  getIndex :: Kind -> Maybe (Expression a) -> Maybe Kind
getIndex Kind
dflt Maybe (Expression a)
Nothing  = Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
dflt
  getIndex Kind
_    (Just Expression a
e) = case SymbolTable -> Expression a -> Either Name ExpVal
forall a. SymbolTable -> Expression a -> Either Name ExpVal
eval' SymbolTable
symt Expression a
e of
    Right (Int Kind
i) -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
i
    Either Name ExpVal
_             -> Maybe Kind
forall a. Maybe a
Nothing

typeOfSubString SrcSpan
_ SymbolTable
_ StructureTable
_ Type
_ Index a
idx = TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType (Index a -> SrcSpan
forall a. Spanned a => a -> SrcSpan
getSpan Index a
idx)

-- | determine the return type of a function call
typeOfFunctionCall
  :: SrcSpan
  -> StructureTable
  -> SymbolTable
  -> Name
  -> [Argument a]
  -> Either TypeError Type
typeOfFunctionCall :: SrcSpan
-> StructureTable
-> SymbolTable
-> Name
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
sp StructureTable
strT SymbolTable
symT Name
name [Argument a]
argList =
  Either TypeError Type
checkIntrinsicFunction Either TypeError Type
-> Either TypeError Type -> Either TypeError Type
forall a. Semigroup a => a -> a -> a
<> Either TypeError Type
checkF77IntrinsicFunction Either TypeError Type
-> Either TypeError Type -> Either TypeError Type
forall a. Semigroup a => a -> a -> a
<> Either TypeError Type
checkExternalFunction
 where
  args :: [Expression a]
args = [ Expression a
e | Argument a
_ SrcSpan
_ Maybe Name
_ Expression a
e <- [Argument a]
argList ]
  -- If the function is any of the intrinsics below, determine its return type
  -- accordingly
  checkIntrinsicFunction :: Either TypeError Type
  checkIntrinsicFunction :: Either TypeError Type
checkIntrinsicFunction
    | Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
"int", Name
"nint"], [Expression a] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Expression a]
args Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
1 = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TInteger Kind
4)
    | Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
"int", Name
"nint"], [Expression a] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Expression a]
args Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
2 = case
        SymbolTable -> Expression a -> Either Name ExpVal
forall a. SymbolTable -> Expression a -> Either Name ExpVal
eval' SymbolTable
symT ([Expression a]
args [Expression a] -> Kind -> Expression a
forall a. [a] -> Kind -> a
!! Kind
1)
      of
        Right (Int Kind
k) -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TInteger Kind
k)
        Either Name ExpVal
_             -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Name -> TypeError
typeError
          SrcSpan
sp
          (  Name
"Unable to determine the second argument value of "
          Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
name
          Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" function"
          )
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"int2" = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TInteger Kind
2)
    | Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
"loc", Name
"sizeof", Name
"iachar"] = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TInteger Kind
4)
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"dfloat" = Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TReal Kind
8)
    | Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
"ishft", Name
"rshift", Name
"ibset", Name
"ibits"], Bool -> Bool
not ([Expression a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression a]
args) = StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf
      StructureTable
strT
      SymbolTable
symT
      ([Expression a] -> Expression a
forall a. [a] -> a
head [Expression a]
args)
    | Name
name Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name
"iand", Name
"ior", Name
"ieor", Name
"and"], [Expression a] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Expression a]
args Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
2 = do
      Type
t1 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a] -> Expression a
forall a. [a] -> a
head [Expression a]
args)
      Type
t2 <- StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a]
args [Expression a] -> Kind -> Expression a
forall a. [a] -> Kind -> a
!! Kind
1)
      Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
promote Type
t1 Type
t2
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"btest", [Expression a] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Expression a]
args Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
2 = Type -> Either TypeError Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Either TypeError Type) -> Type -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ Kind -> Type
TLogical Kind
4
    | Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
"not", [Expression a] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Expression a]
args Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
1 = StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a] -> Expression a
forall a. [a] -> a
head [Expression a]
args)
    | Bool
otherwise = TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Name -> TypeError
typeError
      SrcSpan
sp
      (Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" is not in the extra list of intrinsic functions")

  -- Otherwise, if the function is listed in fortran-src's Fortran77 intrinsic
  -- table, get return type from the intrinsic table.
  checkF77IntrinsicFunction :: Either TypeError Type
  checkF77IntrinsicFunction :: Either TypeError Type
checkF77IntrinsicFunction =
    let f77intrinsics :: IntrinsicsTable
f77intrinsics = FortranVersion -> IntrinsicsTable
getVersionIntrinsics FortranVersion
Fortran77
    in
      case Name -> IntrinsicsTable -> Maybe IntrinsicType
getIntrinsicReturnType Name
name IntrinsicsTable
f77intrinsics of
        Just IntrinsicType
ITReal      -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TReal Kind
4)
        Just IntrinsicType
ITInteger   -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TInteger Kind
4)
        Just IntrinsicType
ITComplex   -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TComplex Kind
8)
        Just IntrinsicType
ITDouble    -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TReal Kind
8)
        Just IntrinsicType
ITLogical   -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (Kind -> Type
TLogical Kind
4)
        Just IntrinsicType
ITCharacter -> Type -> Either TypeError Type
forall a b. b -> Either a b
Right (CharacterLen -> Kind -> Type
TCharacter (Kind -> CharacterLen
CharLenInt Kind
1) Kind
1)
        Just (ITParam Kind
i)
          | [Expression a] -> Kind
forall (t :: * -> *) a. Foldable t => t a -> Kind
length [Expression a]
args Kind -> Kind -> Bool
forall a. Ord a => a -> a -> Bool
>= Kind
i -> StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a]
args [Expression a] -> Kind -> Expression a
forall a. [a] -> Kind -> a
!! (Kind
i Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
- Kind
1))
          | Bool
otherwise -> TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Name -> TypeError
typeError
            SrcSpan
sp
            (Name
"Wrong number of arguments for intrinsic function " Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
name)
        Maybe IntrinsicType
Nothing ->
          TypeError -> Either TypeError Type
forall a b. a -> Either a b
Left (TypeError -> Either TypeError Type)
-> TypeError -> Either TypeError Type
forall a b. (a -> b) -> a -> b
$ SrcSpan -> Name -> TypeError
typeError SrcSpan
sp (Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
" is not in Fortran 77 intrinsic table")

  -- If the function is an external function, its type should have been captured
  -- in the symbol table.
  checkExternalFunction :: Either TypeError Type
  checkExternalFunction :: Either TypeError Type
checkExternalFunction = SymbolTable -> Name -> Either TypeError Type
typeOfSymbol SymbolTable
symT Name
name