{-# 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
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)

-- | 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 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

-- | 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 [(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    -- ^ 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
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
      -- FIXME: some references refer to things like kind=kanji but I can't find any spec for it
      | 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

-- | 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  -> 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)

-- | 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 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   ->
    -- TODO can improve, use no selector if len=1, kind=1
    -- only include kind if != 1
    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)

    -- | 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 -> 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))

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

-- | 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 -> 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

  -- arbitrary values (>F77 is not tested/used)
  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
  -- char: treat length as "kind" (but also use recorded kind)
  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
  -- char: treat length as "kind"
  (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