{-# 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
data SemType
= TInteger Kind
| TReal Kind
| TComplex Kind
| TLogical Kind
| TByte Kind
| TCharacter CharacterLen Kind
| TArray SemType Dimensions
| TCustom String
deriving stock (Eq 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
min :: SemType -> SemType -> SemType
$cmin :: SemType -> SemType -> SemType
max :: SemType -> SemType -> SemType
$cmax :: SemType -> SemType -> SemType
>= :: SemType -> SemType -> Bool
$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
compare :: SemType -> SemType -> Ordering
$ccompare :: SemType -> SemType -> Ordering
Ord, SemType -> SemType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SemType -> SemType -> Bool
$c/= :: SemType -> SemType -> Bool
== :: SemType -> SemType -> Bool
$c== :: SemType -> SemType -> Bool
Eq, Kind -> SemType -> ShowS
[SemType] -> ShowS
SemType -> String
forall a.
(Kind -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SemType] -> ShowS
$cshowList :: [SemType] -> ShowS
show :: SemType -> String
$cshow :: SemType -> String
showsPrec :: Kind -> SemType -> ShowS
$cshowsPrec :: Kind -> SemType -> ShowS
Show, Typeable SemType
SemType -> DataType
SemType -> Constr
(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. Kind -> (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. Kind -> (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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> SemType -> m SemType
gmapQi :: forall u. Kind -> (forall d. Data d => d -> u) -> SemType -> u
$cgmapQi :: forall u. Kind -> (forall d. Data d => d -> u) -> SemType -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> SemType -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> SemType -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> SemType -> r
gmapT :: (forall b. Data b => b -> b) -> SemType -> SemType
$cgmapT :: (forall b. Data b => b -> b) -> SemType -> SemType
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SemType)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c SemType)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SemType)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c SemType)
dataTypeOf :: SemType -> DataType
$cdataTypeOf :: SemType -> DataType
toConstr :: SemType -> Constr
$ctoConstr :: SemType -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SemType
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c SemType
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SemType -> c SemType
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> SemType -> c SemType
Data, 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
$cto :: forall x. Rep SemType x -> SemType
$cfrom :: forall x. SemType -> Rep SemType x
Generic)
deriving anyclass (SemType -> ()
forall a. (a -> ()) -> NFData a
rnf :: SemType -> ()
$crnf :: SemType -> ()
NFData, Get SemType
[SemType] -> Put
SemType -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [SemType] -> Put
$cputList :: [SemType] -> Put
get :: Get SemType
$cget :: Get SemType
put :: SemType -> Put
$cput :: SemType -> Put
Binary, Kind -> SemType -> Doc
[SemType] -> Doc
SemType -> Doc
forall a. (Kind -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
docList :: [SemType] -> Doc
$cdocList :: [SemType] -> Doc
doc :: SemType -> Doc
$cdoc :: SemType -> Doc
docPrec :: Kind -> SemType -> Doc
$cdocPrec :: Kind -> SemType -> Doc
Out)
type Dimensions = Dims NonEmpty (Maybe Int)
instance Pretty SemType where
pprint' :: FortranVersion -> SemType -> Doc
pprint' FortranVersion
v
| FortranVersion
v forall a. Ord a => a -> a -> Bool
>= FortranVersion
Fortran90 = \case
TInteger Kind
k -> Doc
"integer"forall a. Semigroup a => a -> a -> a
<>Kind -> Doc
pd Kind
k
TReal Kind
k -> Doc
"real"forall a. Semigroup a => a -> a -> a
<>Kind -> Doc
pd Kind
k
TComplex Kind
k -> Doc
"complex"forall a. Semigroup a => a -> a -> a
<>Kind -> Doc
pd Kind
k
TLogical Kind
k -> Doc
"logical"forall a. Semigroup a => a -> a -> a
<>Kind -> Doc
pd Kind
k
TByte Kind
k -> Doc
"byte"forall a. Semigroup a => a -> a -> a
<>Kind -> Doc
pd Kind
k
TCharacter CharacterLen
_ Kind
_ -> Doc
"character(TODO)"
TArray SemType
st Dimensions
dims -> forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v SemType
st forall a. Semigroup a => a -> a -> a
<> forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v Dimensions
dims
TCustom String
str -> forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v (String -> BaseType
TypeCustom String
str)
| Bool
otherwise = \case
TInteger Kind
k -> Doc
"integer"forall a. Semigroup a => a -> a -> a
<>forall {a}. Out a => a -> Doc
ad Kind
k
TReal Kind
k -> Doc
"real"forall a. Semigroup a => a -> a -> a
<>forall {a}. Out a => a -> Doc
ad Kind
k
TComplex Kind
k -> Doc
"complex"forall a. Semigroup a => a -> a -> a
<>forall {a}. Out a => a -> Doc
ad Kind
k
TLogical Kind
k -> Doc
"logical"forall a. Semigroup a => a -> a -> a
<>forall {a}. Out a => a -> Doc
ad Kind
k
TByte Kind
k -> Doc
"byte"forall a. Semigroup a => a -> a -> a
<>forall {a}. Out a => a -> Doc
ad Kind
k
TCharacter CharacterLen
_ Kind
_ -> Doc
"character*TODO"
TArray SemType
st Dimensions
dims -> forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v SemType
st forall a. Semigroup a => a -> a -> a
<> forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v Dimensions
dims
TCustom String
str -> forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v (String -> BaseType
TypeCustom String
str)
where
pd :: Kind -> Doc
pd = Doc -> Doc
Pretty.parens forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Out a => a -> Doc
doc
ad :: a -> Doc
ad a
k = forall {a}. Out a => a -> Doc
doc Char
'*' forall a. Semigroup a => a -> a -> a
<> forall {a}. Out a => a -> Doc
doc a
k
dimensionsToTuples :: Dimensions -> Maybe [(Int, Int)]
dimensionsToTuples :: Dimensions -> Maybe [(Kind, Kind)]
dimensionsToTuples = \case
DimsExplicitShape NonEmpty (Dim (Maybe Kind))
ds -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. NonEmpty a -> [a]
NonEmpty.toList 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 {m :: * -> *} {b}. Monad m => Dim (m b) -> m (b, b)
go NonEmpty (Dim (Maybe Kind))
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
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (b
lb, b
ub)
DimsAssumedSize Maybe (NonEmpty (Dim (Maybe Kind)))
_ds Maybe Kind
_d -> forall a. Maybe a
Nothing
DimsAssumedShape NonEmpty (Maybe Kind)
_ss -> forall a. Maybe a
Nothing
data CharacterLen = CharLenStar
| CharLenColon
| CharLenExp
| CharLenInt Int
deriving stock (Eq 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
min :: CharacterLen -> CharacterLen -> CharacterLen
$cmin :: CharacterLen -> CharacterLen -> CharacterLen
max :: CharacterLen -> CharacterLen -> CharacterLen
$cmax :: CharacterLen -> CharacterLen -> CharacterLen
>= :: CharacterLen -> CharacterLen -> Bool
$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
compare :: CharacterLen -> CharacterLen -> Ordering
$ccompare :: CharacterLen -> CharacterLen -> Ordering
Ord, CharacterLen -> CharacterLen -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CharacterLen -> CharacterLen -> Bool
$c/= :: CharacterLen -> CharacterLen -> Bool
== :: CharacterLen -> CharacterLen -> Bool
$c== :: CharacterLen -> CharacterLen -> Bool
Eq, Kind -> CharacterLen -> ShowS
[CharacterLen] -> ShowS
CharacterLen -> String
forall a.
(Kind -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CharacterLen] -> ShowS
$cshowList :: [CharacterLen] -> ShowS
show :: CharacterLen -> String
$cshow :: CharacterLen -> String
showsPrec :: Kind -> CharacterLen -> ShowS
$cshowsPrec :: Kind -> CharacterLen -> ShowS
Show, Typeable CharacterLen
CharacterLen -> DataType
CharacterLen -> Constr
(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. Kind -> (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. Kind -> (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)
gmapMo :: 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
gmapMp :: forall (m :: * -> *).
MonadPlus 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
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> CharacterLen -> m CharacterLen
gmapQi :: forall u. Kind -> (forall d. Data d => d -> u) -> CharacterLen -> u
$cgmapQi :: forall u. Kind -> (forall d. Data d => d -> u) -> CharacterLen -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> CharacterLen -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> CharacterLen -> [u]
gmapQr :: 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
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> CharacterLen -> r
gmapT :: (forall b. Data b => b -> b) -> CharacterLen -> CharacterLen
$cgmapT :: (forall b. Data b => b -> b) -> CharacterLen -> CharacterLen
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CharacterLen)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c CharacterLen)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CharacterLen)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c CharacterLen)
dataTypeOf :: CharacterLen -> DataType
$cdataTypeOf :: CharacterLen -> DataType
toConstr :: CharacterLen -> Constr
$ctoConstr :: CharacterLen -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CharacterLen
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c CharacterLen
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CharacterLen -> c CharacterLen
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> CharacterLen -> c CharacterLen
Data, 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
$cto :: forall x. Rep CharacterLen x -> CharacterLen
$cfrom :: forall x. CharacterLen -> Rep CharacterLen x
Generic)
deriving anyclass (CharacterLen -> ()
forall a. (a -> ()) -> NFData a
rnf :: CharacterLen -> ()
$crnf :: CharacterLen -> ()
NFData, Get CharacterLen
[CharacterLen] -> Put
CharacterLen -> Put
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
putList :: [CharacterLen] -> Put
$cputList :: [CharacterLen] -> Put
get :: Get CharacterLen
$cget :: Get CharacterLen
put :: CharacterLen -> Put
$cput :: CharacterLen -> Put
Binary, Kind -> CharacterLen -> Doc
[CharacterLen] -> Doc
CharacterLen -> Doc
forall a. (Kind -> a -> Doc) -> (a -> Doc) -> ([a] -> Doc) -> Out a
docList :: [CharacterLen] -> Doc
$cdocList :: [CharacterLen] -> Doc
doc :: CharacterLen -> Doc
$cdoc :: CharacterLen -> Doc
docPrec :: Kind -> CharacterLen -> Doc
$cdocPrec :: Kind -> CharacterLen -> Doc
Out)
charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)
charLenSelector :: forall a. Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)
charLenSelector Maybe (Selector a)
Nothing = (forall a. Maybe a
Nothing, forall a. Maybe a
Nothing)
charLenSelector (Just (Selector a
_ SrcSpan
_ Maybe (Expression a)
mlen Maybe (Expression a)
mkind)) = (Maybe CharacterLen
l, Maybe String
k)
where
l :: Maybe CharacterLen
l = forall a. Expression a -> CharacterLen
charLenSelector' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Expression a)
mlen
k :: Maybe String
k | Just (ExpValue a
_ SrcSpan
_ (ValInteger String
i Maybe (KindParam a)
_)) <- Maybe (Expression a)
mkind = forall a. a -> Maybe a
Just String
i
| Just (ExpValue a
_ SrcSpan
_ (ValVariable String
s)) <- Maybe (Expression a)
mkind = forall a. a -> Maybe a
Just String
s
| Bool
otherwise = 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 String
i Maybe (KindParam a)
_) -> Kind -> CharacterLen
CharLenInt (forall a. Read a => String -> a
read String
i)
Expression a
_ -> CharacterLen
CharLenExp
charLenToValue :: CharacterLen -> Maybe (Value a)
charLenToValue :: forall a. CharacterLen -> Maybe (Value a)
charLenToValue = \case
CharacterLen
CharLenStar -> forall a. a -> Maybe a
Just forall a. Value a
ValStar
CharacterLen
CharLenColon -> forall a. a -> Maybe a
Just forall a. Value a
ValColon
CharLenInt Kind
i -> forall a. a -> Maybe a
Just (forall a. String -> Maybe (KindParam a) -> Value a
ValInteger (forall a. Show a => a -> String
show Kind
i) forall a. Maybe a
Nothing)
CharacterLen
CharLenExp -> forall a. Maybe a
Nothing
getTypeKind :: SemType -> Kind
getTypeKind :: SemType -> Kind
getTypeKind = \case
TInteger Kind
k -> Kind
k
TReal Kind
k -> Kind
k
TComplex Kind
k -> Kind
k
TLogical Kind
k -> Kind
k
TByte Kind
k -> Kind
k
TCharacter CharacterLen
_ Kind
k -> Kind
k
TCustom String
_ -> forall a. HasCallStack => String -> a
error String
"TCustom does not have a kind"
TArray SemType
t Dimensions
_ -> SemType -> Kind
getTypeKind SemType
t
setTypeKind :: SemType -> Kind -> SemType
setTypeKind :: SemType -> Kind -> SemType
setTypeKind SemType
st Kind
k = case SemType
st of
TInteger Kind
_ -> Kind -> SemType
TInteger Kind
k
TReal Kind
_ -> Kind -> SemType
TReal Kind
k
TComplex Kind
_ -> Kind -> SemType
TComplex Kind
k
TLogical Kind
_ -> Kind -> SemType
TLogical Kind
k
TByte Kind
_ -> Kind -> SemType
TByte Kind
k
TCharacter CharacterLen
charLen Kind
_ -> CharacterLen -> Kind -> SemType
TCharacter CharacterLen
charLen Kind
k
TCustom String
_ -> forall a. HasCallStack => String -> a
error String
"can't set kind of TCustom"
TArray SemType
_ Dimensions
_ -> forall a. HasCallStack => String -> a
error String
"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 Kind
i1 , CharLenInt Kind
i2 ) -> Kind -> CharacterLen
CharLenInt (Kind
i1 forall a. Num a => a -> a -> a
+ Kind
i2)
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 Kind
k -> BaseType -> Kind -> TypeSpec a
wrapBaseAndKind BaseType
TypeInteger Kind
k
TLogical Kind
k -> BaseType -> Kind -> TypeSpec a
wrapBaseAndKind BaseType
TypeLogical Kind
k
TByte Kind
k -> BaseType -> Kind -> TypeSpec a
wrapBaseAndKind BaseType
TypeByte Kind
k
TCustom String
str -> BaseType -> Maybe (Selector a) -> TypeSpec a
ts (String -> BaseType
TypeCustom String
str) forall a. Maybe a
Nothing
TArray SemType
st Dimensions
_ -> forall a. a -> SrcSpan -> FortranVersion -> SemType -> TypeSpec a
recoverSemTypeTypeSpec a
a SrcSpan
ss FortranVersion
v SemType
st
TReal Kind
k ->
if Kind
k forall a. Eq a => a -> a -> Bool
== Kind
8 Bool -> Bool -> Bool
&& FortranVersion
v forall a. Ord a => a -> a -> Bool
< FortranVersion
Fortran90
then BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
TypeDoublePrecision forall a. Maybe a
Nothing
else BaseType -> Kind -> TypeSpec a
wrapBaseAndKind BaseType
TypeReal Kind
k
TComplex Kind
k ->
if Kind
k forall a. Eq a => a -> a -> Bool
== Kind
16 Bool -> Bool -> Bool
&& FortranVersion
v forall a. Ord a => a -> a -> Bool
< FortranVersion
Fortran90
then BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
TypeDoubleComplex forall a. Maybe a
Nothing
else BaseType -> Kind -> TypeSpec a
wrapBaseAndKind BaseType
TypeComplex Kind
k
TCharacter CharacterLen
len Kind
k ->
let sel :: Selector a
sel = forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
Selector a
a SrcSpan
ss (forall a. a -> SrcSpan -> Value a -> Expression a
ExpValue a
a SrcSpan
ss forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. CharacterLen -> Maybe (Value a)
charLenToValue CharacterLen
len) (if Kind
k forall a. Eq a => a -> a -> Bool
== Kind
1 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Kind -> Expression a
intValExpr Kind
k))
in BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
TypeCharacter (forall a. a -> Maybe a
Just Selector a
sel)
where
ts :: BaseType -> Maybe (Selector a) -> TypeSpec a
ts = forall a.
a -> SrcSpan -> BaseType -> Maybe (Selector a) -> TypeSpec a
TypeSpec a
a SrcSpan
ss
intValExpr :: Int -> Expression a
intValExpr :: Kind -> Expression a
intValExpr Kind
x = forall a. a -> SrcSpan -> Value a -> Expression a
ExpValue a
a SrcSpan
ss (forall a. String -> Maybe (KindParam a) -> Value a
ValInteger (forall a. Show a => a -> String
show Kind
x) forall a. Maybe a
Nothing)
wrapBaseAndKind :: BaseType -> Kind -> TypeSpec a
wrapBaseAndKind :: BaseType -> Kind -> TypeSpec a
wrapBaseAndKind BaseType
bt Kind
k = BaseType -> Maybe (Selector a) -> TypeSpec a
ts BaseType
bt Maybe (Selector a)
sel
where
sel :: Maybe (Selector a)
sel = if Kind
k forall a. Eq a => a -> a -> Bool
== BaseType -> Kind
kindOfBaseType BaseType
bt
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a.
a
-> SrcSpan
-> Maybe (Expression a)
-> Maybe (Expression a)
-> Selector a
Selector a
a SrcSpan
ss forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just (Kind -> Expression a
intValExpr Kind
k))
kindOfBaseType :: BaseType -> Int
kindOfBaseType :: BaseType -> Kind
kindOfBaseType = \case
BaseType
TypeInteger -> Kind
4
BaseType
TypeReal -> Kind
4
BaseType
TypeDoublePrecision -> Kind
8
BaseType
TypeComplex -> Kind
8
BaseType
TypeDoubleComplex -> Kind
16
BaseType
TypeLogical -> Kind
4
TypeCharacter{} -> Kind
1
BaseType
TypeByte -> Kind
1
TypeCustom{} -> Kind
1
BaseType
ClassStar -> Kind
1
ClassCustom{} -> Kind
1
getTypeSize :: SemType -> Maybe Int
getTypeSize :: SemType -> Maybe Kind
getTypeSize = \case
TInteger Kind
k -> forall a. a -> Maybe a
Just Kind
k
TReal Kind
k -> forall a. a -> Maybe a
Just Kind
k
TComplex Kind
k -> forall a. a -> Maybe a
Just Kind
k
TLogical Kind
k -> forall a. a -> Maybe a
Just Kind
k
TByte Kind
k -> forall a. a -> Maybe a
Just Kind
k
TArray SemType
ty Dimensions
_ -> SemType -> Maybe Kind
getTypeSize SemType
ty
TCustom String
_ -> forall a. a -> Maybe a
Just Kind
1
TCharacter (CharLenInt Kind
l) Kind
k -> forall a. a -> Maybe a
Just (Kind
l forall a. Num a => a -> a -> a
* Kind
k)
TCharacter CharacterLen
_ Kind
_ -> forall a. Maybe a
Nothing
setTypeSize :: SemType -> Maybe Int -> SemType
setTypeSize :: SemType -> Maybe Kind -> SemType
setTypeSize SemType
ty Maybe Kind
mk = case (Maybe Kind
mk, SemType
ty) of
(Just Kind
k, TInteger Kind
_ ) -> Kind -> SemType
TInteger Kind
k
(Just Kind
k, TReal Kind
_ ) -> Kind -> SemType
TReal Kind
k
(Just Kind
k, TComplex Kind
_ ) -> Kind -> SemType
TComplex Kind
k
(Just Kind
k, TLogical Kind
_ ) -> Kind -> SemType
TLogical Kind
k
(Just Kind
k, TByte Kind
_ ) -> Kind -> SemType
TByte Kind
k
(Maybe Kind
_ , TCustom String
s ) -> String -> SemType
TCustom String
s
(Just Kind
l, TCharacter CharacterLen
_ Kind
k) ->
CharacterLen -> Kind -> SemType
TCharacter (Kind -> CharacterLen
CharLenInt Kind
l) Kind
k
(Maybe Kind
Nothing, TCharacter CharacterLen
_ Kind
k) ->
CharacterLen -> Kind -> SemType
TCharacter CharacterLen
CharLenStar Kind
k
(Maybe Kind, SemType)
_ -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Tried to set invalid kind for type " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show SemType
ty