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

module Language.Fortran.Vars.TypeCheck
  ( Kind
  , TypeError(..)
  , TypeOf
  , typeOf
  )
where
import           Prelude                 hiding ( GT
                                                , EQ
                                                , LT
                                                )
import           Data.List.NonEmpty             ( NonEmpty( (:|) ) )
import qualified Data.Map                      as M
import           Data.Data                      ( toConstr )
import           Data.Maybe                     ( fromJust )
import           Language.Fortran.AST           ( Expression(..)
                                                , Value(..)
                                                , AList(..)
                                                , aStrip
                                                , Argument(..)
                                                , argExprNormalize
                                                , DoSpecification(..)
                                                , Statement(..)
                                                , Name
                                                , BinaryOp(..)
                                                , Index(..)
                                                )
import           Language.Fortran.AST.Literal   ( KindParam(..) )
import           Language.Fortran.AST.Literal.Real
                                                ( RealLit(..)
                                                , Exponent(..)
                                                , ExponentLetter(..)
                                                )
import           Language.Fortran.AST.Literal.Complex
                                                ( ComplexLit(..)
                                                , ComplexPart(..)
                                                )
import           Language.Fortran.Intrinsics    ( getVersionIntrinsics
                                                , getIntrinsicReturnType
                                                , IntrinsicType(..)
                                                )
import           Language.Fortran.Version       ( FortranVersion(..) )

import           Language.Fortran.Util.Position ( SrcSpan
                                                , getSpan
                                                )
import           Language.Fortran.Vars.Types    ( SymbolTableEntry(..)
                                                , ExpVal(..)
                                                , SymbolTable
                                                , StructureTable
                                                , Kind
                                                , Type
                                                , SemType(..)
                                                , CharacterLen(..)
                                                , TypeError(..)
                                                , TypeOf
                                                , typeError
                                                , Dim(..)
                                                , Dims(..)
                                                )
import           Language.Fortran.Vars.Kind     ( getTypeKind
                                                , setTypeKind
                                                , toInt
                                                )
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 :: forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
expr = case Expression a
expr of
  ExpValue a
_ SrcSpan
_ (ValVariable [Char]
name) -> SymbolTable -> [Char] -> Either TypeError Type
typeOfSymbol SymbolTable
symTable [Char]
name
  ExpValue a
_ SrcSpan
s Value a
val                -> 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                -> 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 -> 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 [Char]
name)) AList Argument a
args ->
    forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> [Char]
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
s StructureTable
strTable SymbolTable
symTable [Char]
name (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument a
args)
  ExpFunctionCall a
_ SrcSpan
_ (ExpValue a
_ SrcSpan
s (ValIntrinsic [Char]
name)) AList Argument a
args ->
    forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> [Char]
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
s StructureTable
strTable SymbolTable
symTable [Char]
name (forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Argument a
args)
  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 forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {a}. Index a -> Bool
isIxRange [Index a]
args
          then forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [Char] -> TypeError
typeError SrcSpan
s forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected array range"
          else case forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
arr of
            Right (TArray Type
ty Dimensions
_) -> forall a b. b -> Either a b
Right Type
ty
            Right Type
_ ->
              forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [Char] -> TypeError
typeError SrcSpan
s forall a b. (a -> b) -> a -> b
$ [Char]
"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 <- forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
arr
    case Type
ty of
      TCharacter CharacterLen
_ Int
_ -> forall a.
SrcSpan
-> SymbolTable
-> StructureTable
-> Type
-> Index a
-> Either TypeError Type
typeOfSubString SrcSpan
s SymbolTable
symTable StructureTable
strTable Type
ty Index a
r
      Type
_              -> forall a b. b -> Either a b
Right Type
ty
  ExpImpliedDo a
_ SrcSpan
_ AList Expression a
es DoSpecification a
doSpec -> do
    Int
dim <- forall a. SymbolTable -> DoSpecification a -> Either TypeError Int
specToDim SymbolTable
symTable DoSpecification a
doSpec
    Type
ty  <- forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. AList t a -> [t a]
aStrip AList Expression a
es
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ case Type
ty of
      TArray Type
ty' (DimsExplicitShape (Dim (Just Int
1) (Just Int
dim') :| [])) ->
        Type -> Dimensions -> Type
TArray Type
ty' forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. t (Dim a) -> Dims t a
DimsExplicitShape forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Dim a
Dim (forall a. a -> Maybe a
Just Int
1) (forall a. a -> Maybe a
Just (Int
dim forall a. Num a => a -> a -> a
* Int
dim')) forall a. a -> [a] -> NonEmpty a
:| []
      TArray Type
_ Dimensions
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected array type in implied do"
      Type
_ ->
        Type -> Dimensions -> Type
TArray Type
ty  forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. t (Dim a) -> Dims t a
DimsExplicitShape forall a b. (a -> b) -> a -> b
$ forall a. a -> a -> Dim a
Dim (forall a. a -> Maybe a
Just Int
1) (forall a. a -> Maybe a
Just Int
dim) forall a. a -> [a] -> NonEmpty a
:| []

  ExpDataRef a
_ SrcSpan
_ Expression a
es (ExpValue a
_ SrcSpan
_ (ValVariable [Char]
name)) -> do
    Type
ty <- forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
es
    StructureTable -> Type -> [Char] -> Either TypeError Type
lookupField StructureTable
strTable Type
ty [Char]
name
  Expression a
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> TypeError
UnknownType forall a b. (a -> b) -> a -> b
$ 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 :: forall a. SymbolTable -> DoSpecification a -> Either TypeError Int
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 Int
evalInt Expression a
x = case forall a. SymbolTable -> Expression a -> Either [Char] ExpVal
eval' SymbolTable
symt Expression a
x of
          Right (Int Int
y) -> forall a b. b -> Either a b
Right Int
y
          Right ExpVal
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [Char] -> TypeError
typeError SrcSpan
s forall a b. (a -> b) -> a -> b
$ [Char]
"non int value in do spec " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show SrcSpan
s
          Left [Char]
err -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [Char] -> TypeError
typeError SrcSpan
s forall a b. (a -> b) -> a -> b
$ [Char]
err
    in  do
          Int
start' <- Expression a -> Either TypeError Int
evalInt Expression a
start
          Int
end'   <- Expression a -> Either TypeError Int
evalInt Expression a
end
          case Maybe (Expression a)
step of
            Just Expression a
x -> do
              Int
step' <- Expression a -> Either TypeError Int
evalInt Expression a
x
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ((Int
end' forall a. Num a => a -> a -> a
- Int
start') forall a. Integral a => a -> a -> a
`div` Int
step') forall a. Num a => a -> a -> a
+ Int
1
            Maybe (Expression a)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (Int
end' forall a. Num a => a -> a -> a
- Int
start') forall a. Num a => a -> a -> a
+ Int
1
specToDim SymbolTable
_ DoSpecification a
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"Unexpected do specification structure"

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

-- | Internal function to determine the 'Type' of a constant
--
-- TODO ignoring kind param errors (should report better)
typeOfValue
  :: SrcSpan
  -> StructureTable
  -> SymbolTable
  -> Value a
  -> Either TypeError Type
typeOfValue :: forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue SrcSpan
sp StructureTable
strTable SymbolTable
symTable Value a
v = case Value a
v of
  ValInteger [Char]
_ Maybe (KindParam a)
mkp -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int -> Type
TInteger (forall a. Int -> Maybe (KindParam a) -> Int
kpOrDef Int
4 Maybe (KindParam a)
mkp)
  ValReal RealLit
r Maybe (KindParam a)
_ -> -- TODO ignoring kind param
    let k :: Int
k = case Exponent -> ExponentLetter
exponentLetter (RealLit -> Exponent
realLitExponent RealLit
r) of
          ExponentLetter
ExpLetterE -> Int
4
          ExponentLetter
ExpLetterD -> Int
8
          ExponentLetter
ExpLetterQ -> Int
16
    in  forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int -> Type
TReal Int
k
  ValComplex ComplexLit a
c -> do
    Type
tr <- forall a.
StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart StructureTable
strTable SymbolTable
symTable forall a b. (a -> b) -> a -> b
$ forall a. ComplexLit a -> ComplexPart a
complexLitRealPart ComplexLit a
c
    Type
ti <- forall a.
StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart StructureTable
strTable SymbolTable
symTable forall a b. (a -> b) -> a -> b
$ forall a. ComplexLit a -> ComplexPart a
complexLitImagPart ComplexLit a
c
    if Type
tr forall a. Eq a => a -> a -> Bool
== Int -> Type
TReal Int
8 Bool -> Bool -> Bool
|| Type
ti forall a. Eq a => a -> a -> Bool
== Int -> Type
TReal Int
8
      then forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type
TComplex Int
16)
      else forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type
TComplex Int
8)
  ValString    [Char]
s   -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ CharacterLen -> Int -> Type
TCharacter (Int -> CharacterLen
CharLenInt (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s)) Int
1
  ValHollerith [Char]
s   -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TByte forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
s
  ValLogical Bool
_ Maybe (KindParam a)
mkp -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int -> Type
TLogical (forall a. Int -> Maybe (KindParam a) -> Int
kpOrDef Int
4 Maybe (KindParam a)
mkp)
  ValBoz Boz
_         -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Int -> Type
TByte Int
4
  Value a
_                -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType SrcSpan
sp
  where
    kpOrDef :: Kind -> Maybe (KindParam a) -> Kind
    kpOrDef :: forall a. Int -> Maybe (KindParam a) -> Int
kpOrDef Int
kDef = \case
      Maybe (KindParam a)
Nothing -> Int
kDef
      Just KindParam a
kp -> case KindParam a
kp of
        KindParamInt a
_ SrcSpan
_ [Char]
kpLit -> forall a. Read a => [Char] -> a
read [Char]
kpLit
        KindParamVar a
_ SrcSpan
_ [Char]
kpVar ->
          let kpVarExpr :: Expression Any
kpVarExpr = forall a. a -> SrcSpan -> Value a -> Expression a
ExpValue forall a. HasCallStack => a
undefined forall a. HasCallStack => a
undefined (forall a. [Char] -> Value a
ValVariable [Char]
kpVar)
          in  case forall a. SymbolTable -> Expression a -> Either [Char] ExpVal
eval' SymbolTable
symTable Expression Any
kpVarExpr of
                Left{} -> Int
kDef
                Right ExpVal
k -> ExpVal -> Int
toInt ExpVal
k

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

-- | Internal function fo determine type of binary expression
typeOfBinaryExp
  :: SrcSpan
  -> StructureTable
  -> SymbolTable
  -> BinaryOp
  -> Expression a
  -> Expression a
  -> Either TypeError Type
typeOfBinaryExp :: forall a.
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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
GT, BinaryOp
GTE, BinaryOp
LT, BinaryOp
LTE, BinaryOp
EQ, BinaryOp
NE] = forall a b. b -> Either a b
Right (Int -> Type
TLogical Int
4)
  | Bool
otherwise = do
    Type
st1 <- forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strTable SymbolTable
symTable Expression a
e1
    Type
st2 <- 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 forall a. Eq a => a -> a -> Bool
== BinaryOp
Concatenation
  -- TODO
  -- = Right . TCharacter $ (+) <$> k1 <*> k2
  = case Type
t1 of
    TCharacter CharacterLen
l1 Int
k1' -> case Type
t2 of
      TCharacter CharacterLen
l2 Int
_ -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ CharacterLen -> Int -> Type
TCharacter (CharacterLen -> CharacterLen -> CharacterLen
charLenConcat CharacterLen
l1 CharacterLen
l2) Int
k1'
      Type
_               -> forall a. HasCallStack => [Char] -> a
error [Char]
"shit 1"
    Type
_ -> forall a. HasCallStack => [Char] -> a
error [Char]
"shit 2"
  |
  -- Logical
  -- NB when integer's are used with logical operators you get bitwise
  -- arithmetic behaviour
    BinaryOp
op forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
And, BinaryOp
Or, BinaryOp
Equivalent, BinaryOp
NotEquivalent, BinaryOp
XOr]
  = let
      ty :: Int -> Either TypeError Type
ty = case (Type
t1, Type
t2) of
        (TLogical Int
_, TLogical Int
_) -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TLogical
        (TInteger Int
_, Type
_         ) -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
        (Type
_         , TInteger Int
_) -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
        (TByte Int
_   , Type
_         ) -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
        (Type
_         , TByte Int
_   ) -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TInteger
        (Type, Type)
_                        -> forall a b. a -> b -> a
const
          (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> [Char] -> TypeError
typeError SrcSpan
sp [Char]
"Unexpected types used with logical operators")
    in  Int -> Either TypeError Type
ty forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. Ord a => a -> a -> a
max forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
k1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
k2
  |
  -- Arithmetic
    BinaryOp
op forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [BinaryOp
Addition, BinaryOp
Subtraction, BinaryOp
Multiplication, BinaryOp
Division, BinaryOp
Exponentiation]
  = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
promote Type
t1 Type
t2
  | Bool
otherwise
  = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType SrcSpan
sp
 where
  k1 :: Maybe Int
k1 = Type -> Maybe Int
getTypeKind Type
t1
  k2 :: Maybe Int
k2 = Type -> Maybe Int
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 :: forall a.
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 ()
isInteger forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strt SymbolTable
symt) Maybe (Expression a)
lower
  Either TypeError (Maybe Type) -> Either TypeError ()
isInteger forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strt SymbolTable
symt) Maybe (Expression a)
upper
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ CharacterLen -> Int -> Type
TCharacter CharacterLen
calcLen Int
1
 where
  calcLen :: CharacterLen
calcLen = case (\Int
x Int
y -> Int
y forall a. Num a => a -> a -> a
- Int
x forall a. Num a => a -> a -> a
+ Int
1) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
lowerIndex forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe Int
upperIndex of
    Maybe Int
Nothing  -> CharacterLen
CharLenStar
    Just Int
len -> Int -> CharacterLen
CharLenInt Int
len
  isInteger :: Either TypeError (Maybe Type) -> Either TypeError ()
isInteger = \case
    Right (Just (TInteger Int
_)) -> forall a b. b -> Either a b
Right ()
    Right Maybe Type
Nothing -> forall a b. b -> Either a b
Right ()
    Either TypeError (Maybe Type)
_ -> forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. SrcSpan -> [Char] -> TypeError
typeError SrcSpan
sp forall a b. (a -> b) -> a -> b
$ [Char]
"Index  wasn't an integer type"
  upperIndex :: Maybe Int
upperIndex = let Just Int
k = Type -> Maybe Int
getTypeKind Type
ty in forall a. Int -> Maybe (Expression a) -> Maybe Int
getIndex Int
k Maybe (Expression a)
upper
  lowerIndex :: Maybe Int
lowerIndex = forall a. Int -> Maybe (Expression a) -> Maybe Int
getIndex Int
1 Maybe (Expression a)
lower
  getIndex :: Int -> Maybe (Expression a) -> Maybe Int
  getIndex :: forall a. Int -> Maybe (Expression a) -> Maybe Int
getIndex Int
dflt Maybe (Expression a)
Nothing  = forall a. a -> Maybe a
Just Int
dflt
  getIndex Int
_    (Just Expression a
e) = case forall a. SymbolTable -> Expression a -> Either [Char] ExpVal
eval' SymbolTable
symt Expression a
e of
    Right (Int Int
i) -> forall a. a -> Maybe a
Just Int
i
    Either [Char] ExpVal
_             -> forall a. Maybe a
Nothing

typeOfSubString SrcSpan
_ SymbolTable
_ StructureTable
_ Type
_ Index a
idx = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> TypeError
UnknownType (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 :: forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> [Char]
-> [Argument a]
-> Either TypeError Type
typeOfFunctionCall SrcSpan
sp StructureTable
strT SymbolTable
symT [Char]
name [Argument a]
argList =
  Either TypeError Type
checkIntrinsicFunction forall a. Semigroup a => a -> a -> a
<> Either TypeError Type
checkF77IntrinsicFunction forall a. Semigroup a => a -> a -> a
<> Either TypeError Type
checkExternalFunction
 where
  args :: [Expression a]
args = [ forall a. ArgumentExpression a -> Expression a
argExprNormalize ArgumentExpression a
e | Argument a
_ SrcSpan
_ Maybe [Char]
_ ArgumentExpression 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
    | [Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"int", [Char]
"nint"], forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args forall a. Eq a => a -> a -> Bool
== Int
1
    = forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
4)
    | [Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"int", [Char]
"nint"], forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args forall a. Eq a => a -> a -> Bool
== Int
2
    = case forall a. SymbolTable -> Expression a -> Either [Char] ExpVal
eval' SymbolTable
symT ([Expression a]
args forall a. [a] -> Int -> a
!! Int
1) of
      Right (Int Int
k) -> forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
k)
      Either [Char] ExpVal
_             -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> [Char] -> TypeError
typeError
        SrcSpan
sp
        (  [Char]
"Unable to determine the second argument value of "
        forall a. Semigroup a => a -> a -> a
<> [Char]
name
        forall a. Semigroup a => a -> a -> a
<> [Char]
" function"
        )
    | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
"int2"
    = forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
2)
    | [Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"loc", [Char]
"sizeof", [Char]
"iachar"]
    = forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
4)
    | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
"dfloat"
    = forall a b. b -> Either a b
Right (Int -> Type
TReal Int
8)
    | [Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"ishft", [Char]
"lshift", [Char]
"rshift", [Char]
"ibset", [Char]
"ibits"], Bool -> Bool
not
      (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Expression a]
args)
    = forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT (forall a. [a] -> a
head [Expression a]
args)
    | [Char]
name forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"iand", [Char]
"ior", [Char]
"ieor", [Char]
"and"], forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args forall a. Eq a => a -> a -> Bool
== Int
2
    = do
      Type
t1 <- forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT (forall a. [a] -> a
head [Expression a]
args)
      Type
t2 <- forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a]
args forall a. [a] -> Int -> a
!! Int
1)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> Type -> Type
promote Type
t1 Type
t2
    | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
"imag", forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args forall a. Eq a => a -> a -> Bool
== Int
1
    = do
      Type
ty <- forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT (forall a. [a] -> a
head [Expression a]
args)
      case Type
ty of
        TComplex Int
x -> forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Type
TReal forall a b. (a -> b) -> a -> b
$ Int
x forall a. Integral a => a -> a -> a
`div` Int
2
        Type
_          -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> [Char] -> TypeError
typeError SrcSpan
sp [Char]
"Invalid argument to imag"
    | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
"btest", forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args forall a. Eq a => a -> a -> Bool
== Int
2
    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Type
TLogical Int
4
    | [Char]
name forall a. Eq a => a -> a -> Bool
== [Char]
"not", forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args forall a. Eq a => a -> a -> Bool
== Int
1
    = forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT (forall a. [a] -> a
head [Expression a]
args)
    | Bool
otherwise
    = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> [Char] -> TypeError
typeError
      SrcSpan
sp
      ([Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" 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 [Char] -> IntrinsicsTable -> Maybe IntrinsicType
getIntrinsicReturnType [Char]
name IntrinsicsTable
f77intrinsics of
        Just IntrinsicType
ITReal      -> forall a b. b -> Either a b
Right (Int -> Type
TReal Int
4)
        Just IntrinsicType
ITInteger   -> forall a b. b -> Either a b
Right (Int -> Type
TInteger Int
4)
        Just IntrinsicType
ITComplex   -> forall a b. b -> Either a b
Right (Int -> Type
TComplex Int
8)
        Just IntrinsicType
ITDouble    -> forall a b. b -> Either a b
Right (Int -> Type
TReal Int
8)
        Just IntrinsicType
ITLogical   -> forall a b. b -> Either a b
Right (Int -> Type
TLogical Int
4)
        Just IntrinsicType
ITCharacter -> forall a b. b -> Either a b
Right (CharacterLen -> Int -> Type
TCharacter (Int -> CharacterLen
CharLenInt Int
1) Int
1)
        Just (ITParam Int
i)
          | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Expression a]
args forall a. Ord a => a -> a -> Bool
>= Int
i -> forall a.
StructureTable
-> SymbolTable -> Expression a -> Either TypeError Type
typeOf StructureTable
strT SymbolTable
symT ([Expression a]
args forall a. [a] -> Int -> a
!! (Int
i forall a. Num a => a -> a -> a
- Int
1))
          | Bool
otherwise -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> [Char] -> TypeError
typeError
            SrcSpan
sp
            ([Char]
"Wrong number of arguments for intrinsic function " forall a. Semigroup a => a -> a -> a
<> [Char]
name)
        Maybe IntrinsicType
Nothing ->
          forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ SrcSpan -> [Char] -> TypeError
typeError SrcSpan
sp ([Char]
name forall a. Semigroup a => a -> a -> a
<> [Char]
" 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 -> [Char] -> Either TypeError Type
typeOfSymbol SymbolTable
symT [Char]
name

typeOfComplexPart :: StructureTable -> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart :: forall a.
StructureTable
-> SymbolTable -> ComplexPart a -> Either TypeError Type
typeOfComplexPart StructureTable
strTable SymbolTable
symTable = \case
  ComplexPartReal   a
_ SrcSpan
ss RealLit
cpReal Maybe (KindParam a)
mkp -> SrcSpan -> Value a -> Either TypeError Type
tOfVal SrcSpan
ss (forall a. RealLit -> Maybe (KindParam a) -> Value a
ValReal    RealLit
cpReal Maybe (KindParam a)
mkp)
  ComplexPartInt    a
_ SrcSpan
ss [Char]
cpInt  Maybe (KindParam a)
mkp -> SrcSpan -> Value a -> Either TypeError Type
tOfVal SrcSpan
ss (forall a. [Char] -> Maybe (KindParam a) -> Value a
ValInteger [Char]
cpInt  Maybe (KindParam a)
mkp)
  ComplexPartNamed  a
_ SrcSpan
_ [Char]
nm         -> SymbolTable -> [Char] -> Either TypeError Type
typeOfSymbol SymbolTable
symTable [Char]
nm
  where tOfVal :: SrcSpan -> Value a -> Either TypeError Type
tOfVal SrcSpan
ss Value a
v = forall a.
SrcSpan
-> StructureTable
-> SymbolTable
-> Value a
-> Either TypeError Type
typeOfValue SrcSpan
ss StructureTable
strTable SymbolTable
symTable Value a
v