{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Fortran.Analysis.SemanticTypes
  ( module Language.Fortran.Analysis.SemanticTypes
  , module Language.Fortran.Common.Array
  ) where

import Language.Fortran.Common.Array

import           Data.Data                      ( Data )
import           Control.DeepSeq                ( NFData )
import           GHC.Generics                   ( Generic )
import           Language.Fortran.AST           ( BaseType(..)
                                                , Expression(..)
                                                , Value(..)
                                                , TypeSpec(..)
                                                , Selector(..) )
import           Language.Fortran.Util.Position ( SrcSpan(..) )
import           Language.Fortran.Version       ( FortranVersion(..) )
import           Data.Binary                    ( Binary )
import           Text.PrettyPrint.GenericPretty ( Out(..) )
import           Language.Fortran.PrettyPrint   ( Pretty(..) )
import qualified Text.PrettyPrint as Pretty

import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty

type Kind = Int

-- | Semantic type assigned to variables.
--
-- 'BaseType' stores the "type tag" given in syntax. 'SemType's add metadata
-- (kind and length), and resolve some "simple" types to a core type with a
-- preset kind (e.g. `DOUBLE PRECISION` -> `REAL(8)`).
--
-- Fortran 90 (and beyond) features may not be well supported.
data SemType
  = TInteger Kind
  | TReal Kind
  | TComplex Kind
  | TLogical Kind
  | TByte Kind
  | TCharacter CharacterLen Kind

  | TArray SemType Dimensions
  -- ^ A Fortran array type is represented by a type and a set of dimensions.

  | TCustom String
  -- ^ Constructor to use for F77 structures, F90 DDTs

    deriving stock    (Eq SemType
Eq SemType =>
(SemType -> SemType -> Ordering)
-> (SemType -> SemType -> Bool)
-> (SemType -> SemType -> Bool)
-> (SemType -> SemType -> Bool)
-> (SemType -> SemType -> Bool)
-> (SemType -> SemType -> SemType)
-> (SemType -> SemType -> SemType)
-> Ord SemType
SemType -> SemType -> Bool
SemType -> SemType -> Ordering
SemType -> SemType -> SemType
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: SemType -> SemType -> Ordering
compare :: SemType -> SemType -> Ordering
$c< :: SemType -> SemType -> Bool
< :: SemType -> SemType -> Bool
$c<= :: SemType -> SemType -> Bool
<= :: SemType -> SemType -> Bool
$c> :: SemType -> SemType -> Bool
> :: SemType -> SemType -> Bool
$c>= :: SemType -> SemType -> Bool
>= :: SemType -> SemType -> Bool
$cmax :: SemType -> SemType -> SemType
max :: SemType -> SemType -> SemType
$cmin :: SemType -> SemType -> SemType
min :: SemType -> SemType -> SemType
Ord, SemType -> SemType -> Bool
(SemType -> SemType -> Bool)
-> (SemType -> SemType -> Bool) -> Eq SemType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SemType -> SemType -> Bool
== :: SemType -> SemType -> Bool
$c/= :: SemType -> SemType -> Bool
/= :: SemType -> SemType -> Bool
Eq, Int -> SemType -> ShowS
[SemType] -> ShowS
SemType -> [Char]
(Int -> SemType -> ShowS)
-> (SemType -> [Char]) -> ([SemType] -> ShowS) -> Show SemType
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SemType -> ShowS
showsPrec :: Int -> SemType -> ShowS
$cshow :: SemType -> [Char]
show :: SemType -> [Char]
$cshowList :: [SemType] -> ShowS
showList :: [SemType] -> ShowS
Show, Typeable SemType
Typeable SemType =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> SemType -> c SemType)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c SemType)
-> (SemType -> Constr)
-> (SemType -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c SemType))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SemType))
-> ((forall b. Data b => b -> b) -> SemType -> SemType)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> SemType -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> SemType -> r)
-> (forall u. (forall d. Data d => d -> u) -> SemType -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> SemType -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> SemType -> m SemType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SemType -> m SemType)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> SemType -> m SemType)
-> Data SemType
SemType -> Constr
SemType -> DataType
(forall b. Data b => b -> b) -> SemType -> SemType
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> SemType -> u
forall u. (forall d. Data d => d -> u) -> SemType -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SemType
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SemType -> c SemType
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SemType)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SemType)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SemType -> c SemType
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SemType -> c SemType
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SemType
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SemType
$ctoConstr :: SemType -> Constr
toConstr :: SemType -> Constr
$cdataTypeOf :: SemType -> DataType
dataTypeOf :: SemType -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SemType)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SemType)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SemType)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SemType)
$cgmapT :: (forall b. Data b => b -> b) -> SemType -> SemType
gmapT :: (forall b. Data b => b -> b) -> SemType -> SemType
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SemType -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> SemType -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SemType -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> SemType -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
Data, (forall x. SemType -> Rep SemType x)
-> (forall x. Rep SemType x -> SemType) -> Generic SemType
forall x. Rep SemType x -> SemType
forall x. SemType -> Rep SemType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. SemType -> Rep SemType x
from :: forall x. SemType -> Rep SemType x
$cto :: forall x. Rep SemType x -> SemType
to :: forall x. Rep SemType x -> SemType
Generic)
    deriving anyclass (SemType -> ()
(SemType -> ()) -> NFData SemType
forall a. (a -> ()) -> NFData a
$crnf :: SemType -> ()
rnf :: SemType -> ()
NFData, Get SemType
[SemType] -> Put
SemType -> Put
(SemType -> Put)
-> Get SemType -> ([SemType] -> Put) -> Binary SemType
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: SemType -> Put
put :: SemType -> Put
$cget :: Get SemType
get :: Get SemType
$cputList :: [SemType] -> Put
putList :: [SemType] -> Put
Binary, Int -> SemType -> Doc
[SemType] -> Doc
SemType -> Doc
(Int -> SemType -> Doc)
-> (SemType -> Doc) -> ([SemType] -> Doc) -> Out SemType
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> SemType -> Doc
docPrec :: Int -> SemType -> Doc
$cdoc :: SemType -> Doc
doc :: SemType -> Doc
$cdocList :: [SemType] -> Doc
docList :: [SemType] -> Doc
Out)

-- | The main dimension type is a non-empty list of dimensions where each bound
--   is @'Maybe' 'Int'@. @'Nothing'@ bounds indicate a dynamic bound (e.g. uses
--   a dummy variable).
type Dimensions = Dims NonEmpty (Maybe Int)

instance Pretty SemType where
  pprint' :: FortranVersion -> SemType -> Doc
pprint' FortranVersion
v
    | FortranVersion
v FortranVersion -> FortranVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= FortranVersion
Fortran90 = \case
      TInteger Int
k -> Doc
"integer"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
pd Int
k
      TReal    Int
k -> Doc
"real"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
pd Int
k
      TComplex Int
k -> Doc
"complex"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
pd Int
k
      TLogical Int
k -> Doc
"logical"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
pd Int
k
      TByte    Int
k -> Doc
"byte"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
pd Int
k
      TCharacter CharacterLen
_ Int
_ -> Doc
"character(TODO)"
      TArray SemType
st Dimensions
dims -> FortranVersion -> SemType -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v SemType
st Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> FortranVersion -> Dimensions -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v Dimensions
dims
      TCustom [Char]
str -> FortranVersion -> BaseType -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v ([Char] -> BaseType
TypeCustom [Char]
str)
    | Bool
otherwise = \case
      TInteger Int
k -> Doc
"integer"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
forall {a}. Out a => a -> Doc
ad Int
k
      TReal    Int
k -> Doc
"real"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
forall {a}. Out a => a -> Doc
ad Int
k
      TComplex Int
k -> Doc
"complex"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
forall {a}. Out a => a -> Doc
ad Int
k
      TLogical Int
k -> Doc
"logical"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
forall {a}. Out a => a -> Doc
ad Int
k
      TByte    Int
k -> Doc
"byte"Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>Int -> Doc
forall {a}. Out a => a -> Doc
ad Int
k
      TCharacter CharacterLen
_ Int
_ -> Doc
"character*TODO"
      TArray SemType
st Dimensions
dims -> FortranVersion -> SemType -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v SemType
st Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> FortranVersion -> Dimensions -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v Dimensions
dims
      TCustom [Char]
str -> FortranVersion -> BaseType -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v ([Char] -> BaseType
TypeCustom [Char]
str)
    where
       pd :: Int -> Doc
pd = Doc -> Doc
Pretty.parens (Doc -> Doc) -> (Int -> Doc) -> Int -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Doc
forall {a}. Out a => a -> Doc
doc
       ad :: a -> Doc
ad a
k = Char -> Doc
forall {a}. Out a => a -> Doc
doc Char
'*' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> a -> Doc
forall {a}. Out a => a -> Doc
doc a
k

-- | Convert 'Dimensions' data type to its previous type synonym
--   @(Maybe [(Int, Int)])@.
--
-- Drops all information for array dimensions that aren't fully static/known.
dimensionsToTuples :: Dimensions -> Maybe [(Int, Int)]
dimensionsToTuples :: Dimensions -> Maybe [(Int, Int)]
dimensionsToTuples = \case
  DimsExplicitShape NonEmpty (Dim (Maybe Int))
ds     -> (NonEmpty (Int, Int) -> [(Int, Int)])
-> Maybe (NonEmpty (Int, Int)) -> Maybe [(Int, Int)]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty (Int, Int) -> [(Int, Int)]
forall a. NonEmpty a -> [a]
NonEmpty.toList (Maybe (NonEmpty (Int, Int)) -> Maybe [(Int, Int)])
-> Maybe (NonEmpty (Int, Int)) -> Maybe [(Int, Int)]
forall a b. (a -> b) -> a -> b
$ (Dim (Maybe Int) -> Maybe (Int, Int))
-> NonEmpty (Dim (Maybe Int)) -> Maybe (NonEmpty (Int, Int))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> NonEmpty a -> f (NonEmpty b)
traverse Dim (Maybe Int) -> Maybe (Int, Int)
forall {m :: * -> *} {b}. Monad m => Dim (m b) -> m (b, b)
go NonEmpty (Dim (Maybe Int))
ds
    where
      go :: Dim (m b) -> m (b, b)
go (Dim m b
mlb m b
mub) = do
          b
lb <- m b
mlb
          b
ub <- m b
mub
          (b, b) -> m (b, b)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b, b) -> m (b, b)) -> (b, b) -> m (b, b)
forall a b. (a -> b) -> a -> b
$ (b
lb, b
ub)
  DimsAssumedSize   Maybe (NonEmpty (Dim (Maybe Int)))
_ds Maybe Int
_d -> Maybe [(Int, Int)]
forall a. Maybe a
Nothing
  DimsAssumedShape  NonEmpty (Maybe Int)
_ss    -> Maybe [(Int, Int)]
forall a. Maybe a
Nothing

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

data CharacterLen = CharLenStar    -- ^ specified with a *
                  | CharLenColon   -- ^ specified with a : (Fortran2003)
                    -- FIXME, possibly, with a more robust const-exp:
                  | CharLenExp     -- ^ specified with a non-trivial expression
                  | CharLenInt Int -- ^ specified with a constant integer
    deriving stock    (Eq CharacterLen
Eq CharacterLen =>
(CharacterLen -> CharacterLen -> Ordering)
-> (CharacterLen -> CharacterLen -> Bool)
-> (CharacterLen -> CharacterLen -> Bool)
-> (CharacterLen -> CharacterLen -> Bool)
-> (CharacterLen -> CharacterLen -> Bool)
-> (CharacterLen -> CharacterLen -> CharacterLen)
-> (CharacterLen -> CharacterLen -> CharacterLen)
-> Ord CharacterLen
CharacterLen -> CharacterLen -> Bool
CharacterLen -> CharacterLen -> Ordering
CharacterLen -> CharacterLen -> CharacterLen
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: CharacterLen -> CharacterLen -> Ordering
compare :: CharacterLen -> CharacterLen -> Ordering
$c< :: CharacterLen -> CharacterLen -> Bool
< :: CharacterLen -> CharacterLen -> Bool
$c<= :: CharacterLen -> CharacterLen -> Bool
<= :: CharacterLen -> CharacterLen -> Bool
$c> :: CharacterLen -> CharacterLen -> Bool
> :: CharacterLen -> CharacterLen -> Bool
$c>= :: CharacterLen -> CharacterLen -> Bool
>= :: CharacterLen -> CharacterLen -> Bool
$cmax :: CharacterLen -> CharacterLen -> CharacterLen
max :: CharacterLen -> CharacterLen -> CharacterLen
$cmin :: CharacterLen -> CharacterLen -> CharacterLen
min :: CharacterLen -> CharacterLen -> CharacterLen
Ord, CharacterLen -> CharacterLen -> Bool
(CharacterLen -> CharacterLen -> Bool)
-> (CharacterLen -> CharacterLen -> Bool) -> Eq CharacterLen
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CharacterLen -> CharacterLen -> Bool
== :: CharacterLen -> CharacterLen -> Bool
$c/= :: CharacterLen -> CharacterLen -> Bool
/= :: CharacterLen -> CharacterLen -> Bool
Eq, Int -> CharacterLen -> ShowS
[CharacterLen] -> ShowS
CharacterLen -> [Char]
(Int -> CharacterLen -> ShowS)
-> (CharacterLen -> [Char])
-> ([CharacterLen] -> ShowS)
-> Show CharacterLen
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CharacterLen -> ShowS
showsPrec :: Int -> CharacterLen -> ShowS
$cshow :: CharacterLen -> [Char]
show :: CharacterLen -> [Char]
$cshowList :: [CharacterLen] -> ShowS
showList :: [CharacterLen] -> ShowS
Show, Typeable CharacterLen
Typeable CharacterLen =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> CharacterLen -> c CharacterLen)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c CharacterLen)
-> (CharacterLen -> Constr)
-> (CharacterLen -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c CharacterLen))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c CharacterLen))
-> ((forall b. Data b => b -> b) -> CharacterLen -> CharacterLen)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> CharacterLen -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> CharacterLen -> r)
-> (forall u. (forall d. Data d => d -> u) -> CharacterLen -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> CharacterLen -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen)
-> Data CharacterLen
CharacterLen -> Constr
CharacterLen -> DataType
(forall b. Data b => b -> b) -> CharacterLen -> CharacterLen
forall a.
Typeable a =>
(forall (c :: * -> *).
 (forall d b. Data d => c (d -> b) -> d -> c b)
 -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> CharacterLen -> u
forall u. (forall d. Data d => d -> u) -> CharacterLen -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CharacterLen
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CharacterLen -> c CharacterLen
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CharacterLen)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CharacterLen)
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CharacterLen -> c CharacterLen
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CharacterLen -> c CharacterLen
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CharacterLen
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CharacterLen
$ctoConstr :: CharacterLen -> Constr
toConstr :: CharacterLen -> Constr
$cdataTypeOf :: CharacterLen -> DataType
dataTypeOf :: CharacterLen -> DataType
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CharacterLen)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CharacterLen)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CharacterLen)
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CharacterLen)
$cgmapT :: (forall b. Data b => b -> b) -> CharacterLen -> CharacterLen
gmapT :: (forall b. Data b => b -> b) -> CharacterLen -> CharacterLen
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CharacterLen -> [u]
gmapQ :: forall u. (forall d. Data d => d -> u) -> CharacterLen -> [u]
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CharacterLen -> u
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> CharacterLen -> u
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
Data, (forall x. CharacterLen -> Rep CharacterLen x)
-> (forall x. Rep CharacterLen x -> CharacterLen)
-> Generic CharacterLen
forall x. Rep CharacterLen x -> CharacterLen
forall x. CharacterLen -> Rep CharacterLen x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. CharacterLen -> Rep CharacterLen x
from :: forall x. CharacterLen -> Rep CharacterLen x
$cto :: forall x. Rep CharacterLen x -> CharacterLen
to :: forall x. Rep CharacterLen x -> CharacterLen
Generic)
    deriving anyclass (CharacterLen -> ()
(CharacterLen -> ()) -> NFData CharacterLen
forall a. (a -> ()) -> NFData a
$crnf :: CharacterLen -> ()
rnf :: CharacterLen -> ()
NFData, Get CharacterLen
[CharacterLen] -> Put
CharacterLen -> Put
(CharacterLen -> Put)
-> Get CharacterLen
-> ([CharacterLen] -> Put)
-> Binary CharacterLen
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
$cput :: CharacterLen -> Put
put :: CharacterLen -> Put
$cget :: Get CharacterLen
get :: Get CharacterLen
$cputList :: [CharacterLen] -> Put
putList :: [CharacterLen] -> Put
Binary, Int -> CharacterLen -> Doc
[CharacterLen] -> Doc
CharacterLen -> Doc
(Int -> CharacterLen -> Doc)
-> (CharacterLen -> Doc)
-> ([CharacterLen] -> Doc)
-> Out CharacterLen
forall a. (Int -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
$cdocPrec :: Int -> CharacterLen -> Doc
docPrec :: Int -> CharacterLen -> Doc
$cdoc :: CharacterLen -> Doc
doc :: CharacterLen -> Doc
$cdocList :: [CharacterLen] -> Doc
docList :: [CharacterLen] -> Doc
Out)

charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)
charLenSelector :: forall a. Maybe (Selector a) -> (Maybe CharacterLen, Maybe [Char])
charLenSelector Maybe (Selector a)
Nothing                          = (Maybe CharacterLen
forall a. Maybe a
Nothing, Maybe [Char]
forall a. Maybe a
Nothing)
charLenSelector (Just (Selector a
_ SrcSpan
_ Maybe (Expression a)
mlen Maybe (Expression a)
mkind)) = (Maybe CharacterLen
l, Maybe [Char]
k)
  where
    l :: Maybe CharacterLen
l = Expression a -> CharacterLen
forall a. Expression a -> CharacterLen
charLenSelector' (Expression a -> CharacterLen)
-> Maybe (Expression a) -> Maybe CharacterLen
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Expression a)
mlen
    k :: Maybe [Char]
k | Just (ExpValue a
_ SrcSpan
_ (ValInteger [Char]
i Maybe (KindParam a)
_)) <- Maybe (Expression a)
mkind  = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
i
      | Just (ExpValue a
_ SrcSpan
_ (ValVariable [Char]
s)) <- Maybe (Expression a)
mkind = [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just [Char]
s
      -- FIXME: some references refer to things like kind=kanji but I can't find any spec for it
      | Bool
otherwise                                    = Maybe [Char]
forall a. Maybe a
Nothing

charLenSelector' :: Expression a -> CharacterLen
charLenSelector' :: forall a. Expression a -> CharacterLen
charLenSelector' = \case
  ExpValue a
_ SrcSpan
_ Value a
ValStar        -> CharacterLen
CharLenStar
  ExpValue a
_ SrcSpan
_ Value a
ValColon       -> CharacterLen
CharLenColon
  ExpValue a
_ SrcSpan
_ (ValInteger [Char]
i Maybe (KindParam a)
_) -> Int -> CharacterLen
CharLenInt ([Char] -> Int
forall a. Read a => [Char] -> a
read [Char]
i)
  Expression a
_                           -> CharacterLen
CharLenExp

-- | Attempt to recover the 'Value' that generated the given 'CharacterLen'.
charLenToValue :: CharacterLen -> Maybe (Value a)
charLenToValue :: forall a. CharacterLen -> Maybe (Value a)
charLenToValue = \case
  CharacterLen
CharLenStar  -> Value a -> Maybe (Value a)
forall a. a -> Maybe a
Just Value a
forall a. Value a
ValStar
  CharacterLen
CharLenColon -> Value a -> Maybe (Value a)
forall a. a -> Maybe a
Just Value a
forall a. Value a
ValColon
  CharLenInt Int
i -> Value a -> Maybe (Value a)
forall a. a -> Maybe a
Just ([Char] -> Maybe (KindParam a) -> Value a
forall a. [Char] -> Maybe (KindParam a) -> Value a
ValInteger (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i) Maybe (KindParam a)
forall a. Maybe a
Nothing)
  CharacterLen
CharLenExp   -> Maybe (Value a)
forall a. Maybe a
Nothing

getTypeKind :: SemType -> Kind
getTypeKind :: SemType -> Int
getTypeKind = \case
  TInteger   Int
k -> Int
k
  TReal      Int
k -> Int
k
  TComplex   Int
k -> Int
k
  TLogical   Int
k -> Int
k
  TByte      Int
k -> Int
k
  TCharacter CharacterLen
_ Int
k -> Int
k
  TCustom    [Char]
_ -> [Char] -> Int
forall a. HasCallStack => [Char] -> a
error [Char]
"TCustom does not have a kind"
  TArray SemType
t Dimensions
_   -> SemType -> Int
getTypeKind SemType
t

setTypeKind :: SemType -> Kind -> SemType
setTypeKind :: SemType -> Int -> SemType
setTypeKind SemType
st Int
k = case SemType
st of
  TInteger   Int
_ -> Int -> SemType
TInteger   Int
k
  TReal      Int
_ -> Int -> SemType
TReal      Int
k
  TComplex   Int
_ -> Int -> SemType
TComplex   Int
k
  TLogical   Int
_ -> Int -> SemType
TLogical   Int
k
  TByte      Int
_ -> Int -> SemType
TByte      Int
k
  TCharacter CharacterLen
charLen Int
_ -> CharacterLen -> Int -> SemType
TCharacter CharacterLen
charLen Int
k
  TCustom    [Char]
_ -> [Char] -> SemType
forall a. HasCallStack => [Char] -> a
error [Char]
"can't set kind of TCustom"
  TArray SemType
_ Dimensions
_   -> [Char] -> SemType
forall a. HasCallStack => [Char] -> a
error [Char]
"can't set kind of TArray"

charLenConcat :: CharacterLen -> CharacterLen -> CharacterLen
charLenConcat :: CharacterLen -> CharacterLen -> CharacterLen
charLenConcat CharacterLen
l1 CharacterLen
l2 = case (CharacterLen
l1, CharacterLen
l2) of
  (CharacterLen
CharLenExp    , CharacterLen
_             ) -> CharacterLen
CharLenExp
  (CharacterLen
_             , CharacterLen
CharLenExp    ) -> CharacterLen
CharLenExp
  (CharacterLen
CharLenStar   , CharacterLen
_             ) -> CharacterLen
CharLenStar
  (CharacterLen
_             , CharacterLen
CharLenStar   ) -> CharacterLen
CharLenStar
  (CharacterLen
CharLenColon  , CharacterLen
_             ) -> CharacterLen
CharLenColon
  (CharacterLen
_             , CharacterLen
CharLenColon  ) -> CharacterLen
CharLenColon
  (CharLenInt Int
i1 , CharLenInt Int
i2 ) -> Int -> CharacterLen
CharLenInt (Int
i1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i2)

-- | Recover the most appropriate 'TypeSpec' for the given 'SemType', depending
--   on the given 'FortranVersion'.
--
-- Kinds weren't formalized as a syntactic feature until Fortran 90, so we ask
-- for a context. If possible (>=F90), we prefer the more explicit
-- representation e.g. @REAL(8)@. For older versions, for specific type-kind
-- combinations, @DOUBLE PRECISION@ and @DOUBLE COMPLEX@ are used instead.
-- However, we otherwise don't shy away from adding kind info regardless of
-- theoretical version support.
--
-- Array types don't work properly, due to array type info being in a parent
-- node that holds individual elements.
recoverSemTypeTypeSpec :: forall a. a -> SrcSpan
                       -> FortranVersion -> SemType -> TypeSpec a
recoverSemTypeTypeSpec :: forall a. a -> SrcSpan -> FortranVersion -> SemType -> TypeSpec a
recoverSemTypeTypeSpec a
a SrcSpan
ss FortranVersion
v = \case
  TInteger Int
k -> BaseType -> Int -> TypeSpec a
wrapBaseAndKind BaseType
TypeInteger Int
k
  TLogical Int
k -> BaseType -> Int -> TypeSpec a
wrapBaseAndKind BaseType
TypeLogical Int
k
  TByte    Int
k -> BaseType -> Int -> TypeSpec a
wrapBaseAndKind BaseType
TypeByte Int
k

  TCustom [Char]
str -> BaseType -> Maybe (Selector a) -> TypeSpec a
ts ([Char] -> BaseType
TypeCustom [Char]
str) Maybe (Selector a)
forall a. Maybe a
Nothing

  TArray     SemType
st  Dimensions
_   -> a -> SrcSpan -> FortranVersion -> SemType -> TypeSpec a
forall a. a -> SrcSpan -> FortranVersion -> SemType -> TypeSpec a
recoverSemTypeTypeSpec a
a SrcSpan
ss FortranVersion
v SemType
st

  TReal    Int
k ->
      if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
8 Bool -> Bool -> Bool
&& FortranVersion
v FortranVersion -> FortranVersion -> Bool
forall a. Ord a => a -> a -> Bool
< FortranVersion
Fortran90
    then BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
TypeDoublePrecision Maybe (Selector a)
forall a. Maybe a
Nothing
    else BaseType -> Int -> TypeSpec a
wrapBaseAndKind BaseType
TypeReal Int
k
  TComplex Int
k ->
      if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 Bool -> Bool -> Bool
&& FortranVersion
v FortranVersion -> FortranVersion -> Bool
forall a. Ord a => a -> a -> Bool
< FortranVersion
Fortran90
    then BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
TypeDoubleComplex Maybe (Selector a)
forall a. Maybe a
Nothing
    else BaseType -> Int -> TypeSpec a
wrapBaseAndKind BaseType
TypeComplex Int
k

  TCharacter CharacterLen
len Int
k   ->
    -- TODO can improve, use no selector if len=1, kind=1
    -- only include kind if != 1
    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
a SrcSpan
ss (a -> SrcSpan -> Value a -> Expression a
forall a. a -> SrcSpan -> Value a -> Expression a
ExpValue a
a SrcSpan
ss (Value a -> Expression a)
-> Maybe (Value a) -> Maybe (Expression a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CharacterLen -> Maybe (Value a)
forall a. CharacterLen -> Maybe (Value a)
charLenToValue CharacterLen
len) (if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 then Maybe (Expression a)
forall a. Maybe a
Nothing else Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just (Int -> Expression a
intValExpr Int
k))
     in BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
TypeCharacter (Selector a -> Maybe (Selector a)
forall a. a -> Maybe a
Just Selector a
sel)

  where
    ts :: BaseType -> Maybe (Selector a) -> TypeSpec a
ts = a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
TypeSpec a
a SrcSpan
ss
    intValExpr :: Int -> Expression a
    intValExpr :: Int -> Expression a
intValExpr Int
x = a -> SrcSpan -> Value a -> Expression a
forall a. a -> SrcSpan -> Value a -> Expression a
ExpValue a
a SrcSpan
ss ([Char] -> Maybe (KindParam a) -> Value a
forall a. [Char] -> Maybe (KindParam a) -> Value a
ValInteger (Int -> [Char]
forall a. Show a => a -> [Char]
show Int
x) Maybe (KindParam a)
forall a. Maybe a
Nothing)

    -- | Wraps 'BaseType' and 'Kind' into 'TypeSpec'. If the kind is the
    --   'BaseType''s default kind, it is omitted.
    wrapBaseAndKind :: BaseType -> Kind -> TypeSpec a
    wrapBaseAndKind :: BaseType -> Int -> TypeSpec a
wrapBaseAndKind BaseType
bt Int
k = BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
bt Maybe (Selector a)
sel
      where
        sel :: Maybe (Selector a)
sel =   if Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== BaseType -> Int
kindOfBaseType BaseType
bt
              then Maybe (Selector a)
forall a. Maybe a
Nothing
              else Selector a -> Maybe (Selector a)
forall a. a -> Maybe a
Just (Selector a -> Maybe (Selector a))
-> Selector a -> Maybe (Selector a)
forall a b. (a -> b) -> a -> b
$ a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
Selector a
a SrcSpan
ss Maybe (Expression a)
forall a. Maybe a
Nothing (Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just (Int -> Expression a
intValExpr Int
k))

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

-- | Given a 'BaseType' infer the "default" kind (or size of the
-- variable in memory).
--
-- Useful when you need a default kind, but gives you an unwrapped type.
-- Consider using Analysis.deriveSemTypeFromBaseType also.
--
-- Further documentation:
-- https://docs.oracle.com/cd/E19957-01/805-4939/c400041360f5/index.html
kindOfBaseType :: BaseType -> Int
kindOfBaseType :: BaseType -> Int
kindOfBaseType = \case
  BaseType
TypeInteger         -> Int
4
  BaseType
TypeReal            -> Int
4
  BaseType
TypeDoublePrecision -> Int
8
  BaseType
TypeComplex         -> Int
8
  BaseType
TypeDoubleComplex   -> Int
16
  BaseType
TypeLogical         -> Int
4
  TypeCharacter{}     -> Int
1
  BaseType
TypeByte            -> Int
1

  -- arbitrary values (>F77 is not tested/used)
  TypeCustom{}        -> Int
1
  BaseType
ClassStar           -> Int
1
  ClassCustom{}       -> Int
1

getTypeSize :: SemType -> Maybe Int
getTypeSize :: SemType -> Maybe Int
getTypeSize = \case
  TInteger      Int
k   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
  TReal         Int
k   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
  TComplex      Int
k   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
  TLogical      Int
k   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
  TByte         Int
k   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
k
  TArray     SemType
ty Dimensions
_   -> SemType -> Maybe Int
getTypeSize SemType
ty
  TCustom       [Char]
_   -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
  -- char: treat length as "kind" (but also use recorded kind)
  TCharacter (CharLenInt Int
l) Int
k -> Int -> Maybe Int
forall a. a -> Maybe a
Just (Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
k)
  TCharacter CharacterLen
_              Int
_ -> Maybe Int
forall a. Maybe a
Nothing

setTypeSize :: SemType -> Maybe Int -> SemType
setTypeSize :: SemType -> Maybe Int -> SemType
setTypeSize SemType
ty Maybe Int
mk = case (Maybe Int
mk, SemType
ty) of
  (Just Int
k, TInteger Int
_  ) -> Int -> SemType
TInteger Int
k
  (Just Int
k, TReal Int
_     ) -> Int -> SemType
TReal Int
k
  (Just Int
k, TComplex Int
_  ) -> Int -> SemType
TComplex Int
k
  (Just Int
k, TLogical Int
_  ) -> Int -> SemType
TLogical Int
k
  (Just Int
k, TByte Int
_     ) -> Int -> SemType
TByte Int
k
  (Maybe Int
_     , TCustom [Char]
s   ) -> [Char] -> SemType
TCustom [Char]
s
  -- char: treat length as "kind"
  (Just Int
l, TCharacter CharacterLen
_ Int
k) ->
    CharacterLen -> Int -> SemType
TCharacter (Int -> CharacterLen
CharLenInt Int
l) Int
k
  (Maybe Int
Nothing, TCharacter CharacterLen
_ Int
k) ->
    CharacterLen -> Int -> SemType
TCharacter CharacterLen
CharLenStar Int
k
  (Maybe Int, SemType)
_ -> [Char] -> SemType
forall a. HasCallStack => [Char] -> a
error ([Char] -> SemType) -> [Char] -> SemType
forall a b. (a -> b) -> a -> b
$ [Char]
"Tried to set invalid kind for type " [Char] -> ShowS
forall a. Semigroup a => a -> a -> a
<> SemType -> [Char]
forall a. Show a => a -> [Char]
show SemType
ty