{-# LANGUAGE LambdaCase #-}

module Language.Fortran.Vars.Kind
  ( module Language.Fortran.Vars.Kind
  , kindOfBaseType
  , getTypeSize
  , setTypeSize
  , deriveSemTypeFromBaseType
  )
where

import           Data.Maybe                     ( fromJust )
import           Language.Fortran.Analysis      ( Analysis )
import           Language.Fortran.Analysis.Types
                                                ( deriveSemTypeFromBaseType )
import           Language.Fortran.AST           ( BaseType(..)
                                                , Expression(..)
                                                , Selector(..)
                                                , TypeSpec(..)
                                                , Value(..)
                                                )
import           Language.Fortran.Analysis.SemanticTypes
                                                ( kindOfBaseType
                                                , getTypeSize
                                                , setTypeSize
                                                )

import           Language.Fortran.Vars.Errors   ( invalidArg )
import           Language.Fortran.Vars.Eval     ( eval' )
import           Language.Fortran.Vars.Types    ( ExpVal(..)
                                                , Type
                                                , SemType(..)
                                                , CharacterLen(..)
                                                , SymbolTable
                                                )

baseToType :: BaseType -> Type
baseToType :: BaseType -> Type
baseToType = BaseType -> Type
deriveSemTypeFromBaseType

getTypeKind :: Type -> Maybe Int
getTypeKind :: Type -> Maybe Int
getTypeKind = Type -> Maybe Int
getTypeSize

setTypeKind :: Type -> Maybe Int -> Type
setTypeKind :: Type -> Maybe Int -> Type
setTypeKind = Type -> Maybe Int -> Type
setTypeSize

-- | Given an 'ExpVal', return the 'Type' of that value
typeOfExpVal :: ExpVal -> Type
typeOfExpVal :: ExpVal -> Type
typeOfExpVal = \case
  Int     Int
_ -> Int -> Type
TInteger Int
4
  Real    Double
_ -> Int -> Type
TReal Int
4
  Logical Bool
_ -> Int -> Type
TLogical Int
4
  Str     String
_ -> CharacterLen -> Int -> Type
TCharacter (Int -> CharacterLen
CharLenInt Int
1) Int
1
  Boz     Boz
_ -> forall a. HasCallStack => String -> a
error String
"BOZ constant is type-less"

-- | Given an 'ExpVal', return true if it is a 'Str', else false
isStr :: ExpVal -> Bool
isStr :: ExpVal -> Bool
isStr ExpVal
e = case ExpVal
e of
  Str String
_ -> Bool
True
  ExpVal
_     -> Bool
False

-- | Given an 'ExpVal' determine the kind of it
getKindOfExpVal :: ExpVal -> Int
getKindOfExpVal :: ExpVal -> Int
getKindOfExpVal (Str String
s) = forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s
getKindOfExpVal ExpVal
ev      = forall a. HasCallStack => Maybe a -> a
fromJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe Int
getTypeSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpVal -> Type
typeOfExpVal forall a b. (a -> b) -> a -> b
$ ExpVal
ev

-- | Convert an 'ExpVal' to an 'Int'. This will fail if the
-- 'ExpVal' is not already known to be an 'Int'
toInt :: ExpVal -> Int
toInt :: ExpVal -> Int
toInt (Int Int
i) = Int
i
toInt ExpVal
e       = forall a b. Show a => String -> [a] -> b
invalidArg String
"toInt" [ExpVal
e]

-- | Given a 'SymbolTable', a 'TypeSpec' for a variable, and possibly an 'Expression'
-- for the length of a character array, determine the kind of that variable
-- The charLength also works for nonstandard kind
getKind
  :: SymbolTable
  -> TypeSpec (Analysis a)
  -> Maybe (Expression (Analysis a))
  -> Maybe Int
getKind :: forall a.
SymbolTable
-> TypeSpec (Analysis a)
-> Maybe (Expression (Analysis a))
-> Maybe Int
getKind SymbolTable
symTable (TypeSpec Analysis a
_ SrcSpan
_ BaseType
bt Maybe (Selector (Analysis a))
selector) Maybe (Expression (Analysis a))
charLength =
  let evalMaybeKind :: Expression (Analysis a) -> Maybe Int
evalMaybeKind Expression (Analysis a)
kind =
          forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExpVal -> Int
toInt) forall a b. (a -> b) -> a -> b
$ forall a. SymbolTable -> Expression a -> Either String ExpVal
eval' SymbolTable
symTable Expression (Analysis a)
kind
  in  case Maybe (Expression (Analysis a))
charLength of
        Just Expression (Analysis a)
charLen -> Expression (Analysis a) -> Maybe Int
evalMaybeKind Expression (Analysis a)
charLen
        Maybe (Expression (Analysis a))
Nothing      -> case Maybe (Selector (Analysis a))
selector of
          Just (Selector Analysis a
_ SrcSpan
_ Maybe (Expression (Analysis a))
_ (Just Expression (Analysis a)
kindExp)) ->
            let k' :: Expression (Analysis a)
k' = Expression (Analysis a)
kindExp
            in  case Expression (Analysis a)
k' of
                  ExpValue Analysis a
_ SrcSpan
_ Value (Analysis a)
ValStar -> forall a. Maybe a
Nothing
                  Expression (Analysis a)
_                    -> Expression (Analysis a) -> Maybe Int
evalMaybeKind Expression (Analysis a)
kindExp
          Just (Selector Analysis a
_ SrcSpan
_ (Just Expression (Analysis a)
lengthExp) Maybe (Expression (Analysis a))
_) ->
            let l' :: Expression (Analysis a)
l' = Expression (Analysis a)
lengthExp
            in  case Expression (Analysis a)
l' of
                  ExpValue Analysis a
_ SrcSpan
_ Value (Analysis a)
ValStar -> forall a. Maybe a
Nothing
                  Expression (Analysis a)
_                    -> Expression (Analysis a) -> Maybe Int
evalMaybeKind Expression (Analysis a)
lengthExp
          Maybe (Selector (Analysis a))
_ -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ BaseType -> Int
kindOfBaseType BaseType
bt