{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

module Language.Fortran.Analysis.SemanticTypes where

import           Data.Data                      ( Data, Typeable )
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           Text.PrettyPrint               ( (<+>), parens )
import           Language.Fortran.PrettyPrint   ( Pretty(..) )

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 (Maybe Dimensions) -- ^ Nothing denotes dynamic dimensions
  | TCustom String                    -- use for F77 structures, F90 DDTs
  deriving (SemType -> SemType -> Bool
(SemType -> SemType -> Bool)
-> (SemType -> SemType -> Bool) -> Eq SemType
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, 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
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, Kind -> SemType -> ShowS
[SemType] -> ShowS
SemType -> String
(Kind -> SemType -> ShowS)
-> (SemType -> String) -> ([SemType] -> ShowS) -> Show SemType
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
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. Kind -> (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 -> 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, Typeable, (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
$cto :: forall x. Rep SemType x -> SemType
$cfrom :: forall x. SemType -> Rep SemType x
Generic)

instance Binary SemType
instance Out    SemType

-- TODO placeholder, not final or tested
-- should really attempt to print with kind info, and change to DOUBLE PRECISION
-- etc. for <F90. Maybe cheat, use 'recoverSemTypeTypeSpec' and print resulting
-- TypeSpec?
instance Pretty SemType where
  pprint' :: FortranVersion -> SemType -> Doc
pprint' FortranVersion
v = \case
    TInteger Kind
_ -> Doc
"integer"
    TReal Kind
_    -> Doc
"real"
    TComplex Kind
_ -> Doc
"complex"
    TLogical Kind
_ -> Doc
"logical"
    TByte Kind
_    -> Doc
"byte"
    TCharacter CharacterLen
_ Kind
_ -> Doc
"character"
    TArray SemType
st Maybe Dimensions
_ -> FortranVersion -> SemType -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v SemType
st Doc -> Doc -> Doc
<+> Doc -> Doc
parens Doc
"(A)"
    TCustom String
str -> FortranVersion -> BaseType -> Doc
forall t. Pretty t => FortranVersion -> t -> Doc
pprint' FortranVersion
v (String -> BaseType
TypeCustom String
str)

-- | The declared dimensions of a staticically typed array variable
-- type is of the form [(dim1_lower, dim1_upper), (dim2_lower, dim2_upper)]
type Dimensions = [(Int, Int)]

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

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 (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
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
(CharacterLen -> CharacterLen -> Bool)
-> (CharacterLen -> CharacterLen -> Bool) -> Eq CharacterLen
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
(Kind -> CharacterLen -> ShowS)
-> (CharacterLen -> String)
-> ([CharacterLen] -> ShowS)
-> Show CharacterLen
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
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.
    Kind -> (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 -> 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, Typeable, (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
$cto :: forall x. Rep CharacterLen x -> CharacterLen
$cfrom :: forall x. CharacterLen -> Rep CharacterLen x
Generic)

instance Binary CharacterLen
instance Out    CharacterLen
instance NFData CharacterLen

charLenSelector :: Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)
charLenSelector :: forall a. Maybe (Selector a) -> (Maybe CharacterLen, Maybe String)
charLenSelector Maybe (Selector a)
Nothing                          = (Maybe CharacterLen
forall a. Maybe a
Nothing, Maybe String
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 = 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 String
k | Just (ExpValue a
_ SrcSpan
_ (ValInteger String
i Maybe (KindParam a)
_)) <- Maybe (Expression a)
mkind  = String -> Maybe String
forall a. a -> Maybe a
Just String
i
      | Just (ExpValue a
_ SrcSpan
_ (ValVariable String
s)) <- Maybe (Expression a)
mkind = String -> Maybe String
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                                    = Maybe String
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 (String -> Kind
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  -> 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 Kind
i -> Value a -> Maybe (Value a)
forall a. a -> Maybe a
Just (String -> Maybe (KindParam a) -> Value a
forall a. String -> Maybe (KindParam a) -> Value a
ValInteger (Kind -> String
forall a. Show a => a -> String
show Kind
i) Maybe (KindParam a)
forall a. Maybe a
Nothing)
  CharacterLen
CharLenExp   -> Maybe (Value a)
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
_ -> String -> Kind
forall a. HasCallStack => String -> a
error String
"TCustom does not have a kind"
  TArray SemType
t Maybe 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
_ -> String -> SemType
forall a. HasCallStack => String -> a
error String
"can't set kind of TCustom"
  TArray SemType
_ Maybe Dimensions
_   -> String -> SemType
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 Kind -> Kind -> Kind
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) Maybe (Selector a)
forall a. Maybe a
Nothing

  TArray     SemType
st  Maybe 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    Kind
k ->
      if Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
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 -> Kind -> TypeSpec a
wrapBaseAndKind BaseType
TypeReal Kind
k
  TComplex Kind
k ->
      if Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
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 -> 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 = 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 Kind
k Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== Kind
1 then Maybe (Expression a)
forall a. Maybe a
Nothing else Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just (Kind -> Expression a
intValExpr Kind
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 :: Kind -> Expression a
intValExpr Kind
x = a -> SrcSpan -> Value a -> Expression a
forall a. a -> SrcSpan -> Value a -> Expression a
ExpValue a
a SrcSpan
ss (String -> Maybe (KindParam a) -> Value a
forall a. String -> Maybe (KindParam a) -> Value a
ValInteger (Kind -> String
forall a. Show a => a -> String
show Kind
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 -> 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 Kind -> Kind -> Bool
forall a. Eq a => a -> a -> Bool
== BaseType -> Kind
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 (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   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
  TReal         Kind
k   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
  TComplex      Kind
k   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
  TLogical      Kind
k   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
  TByte         Kind
k   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
k
  TArray     SemType
ty Maybe Dimensions
_   -> SemType -> Maybe Kind
getTypeSize SemType
ty
  TCustom       String
_   -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just Kind
1
  -- char: treat length as "kind" (but also use recorded kind)
  TCharacter (CharLenInt Kind
l) Kind
k -> Kind -> Maybe Kind
forall a. a -> Maybe a
Just (Kind
l Kind -> Kind -> Kind
forall a. Num a => a -> a -> a
* Kind
k)
  TCharacter CharacterLen
_              Kind
_ -> Maybe 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)
_ -> String -> SemType
forall a. HasCallStack => String -> a
error (String -> SemType) -> String -> SemType
forall a b. (a -> b) -> a -> b
$ String
"Tried to set invalid kind for type " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> SemType -> String
forall a. Show a => a -> String
show SemType
ty