{-# LANGUAGE TupleSections              #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -fno-warn-unused-matches #-}

{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE DataKinds                  #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE PolyKinds                  #-}

-- TODO: Implement translation for more unsupported language parts

{-|

Provides translation from a subset of the dynamically typed Fortran syntax
("Language.Fortran.AST") to the strongly typed expression language
("Language.Fortran.Model").

-}
module Language.Fortran.Model.Translate
  (
    -- * Types
    -- ** Fortran Expressions
    FortranExpr
    -- ** Existentials
  , Some(..)
  , SomeVar
  , SomeExpr
  , SomeType
    -- ** Semantics
  , KindSelector(..)
  , FortranSemantics(..)
  , defaultSemantics

    -- * Translation Monad
    -- ** Environment
  , TranslateEnv(..)
  , defaultTranslateEnv
    -- ** Errors
  , TranslateError(..)
    -- ** Monad
  , TranslateT(..)
  , runTranslateT

    -- * Translating Expressions
  , translateExpression
  , translateExpression'
  , translateCoerceExpression

    -- * Translating Types
    -- ** 'TypeInfo'
  , TypeInfo
  , typeInfo
    -- ** Translation
  , translateTypeInfo

    -- * Lenses
    -- ** 'FortranSemantics'
  , fsIntegerKinds
  , fsRealKinds
  , fsLogicalKinds
  , fsCharacterKinds
  , fsDoublePrecisionKinds
    -- * 'TranslateEnv'
  , teVarsInScope
  , teImplicitVars
  , teSemantics
    -- ** 'TypeInfo'
  , tiSrcSpan
  , tiBaseType
  , tiSelectorLength
  , tiSelectorKind
  , tiDeclaratorLength
  , tiDimensionDeclarators
  , tiAttributes
  ) where

import           Prelude                              hiding (span)

import           Control.Applicative                  ((<|>))
import           Data.Char                            (toLower)
import           Data.List                            (intersperse)
import           Data.Maybe                           (catMaybes)
import           Data.Typeable                        (Typeable)
import           Text.Read                            (readMaybe)

import           Control.Lens                         hiding (Const (..),
                                                       indices, op, rmap, (.>))
import           Control.Monad.Except
import           Control.Monad.Reader
import           Control.Monad.Fail hiding            (fail)
import           Data.Map                             (Map)

import           Data.Singletons
import           Data.Singletons.Prelude.List         (Length)

import           Data.Vinyl
import           Data.Vinyl.Functor                   (Const (..))

-- TODO: use old non-typeclass Vinyl funcs for inline types I can't figure out
import qualified Data.Vinyl.Recursive                 as VinylRec

import qualified Language.Fortran.Analysis            as F
import qualified Language.Fortran.AST                 as F
import qualified Language.Fortran.Util.Position       as F

import           Language.Expression
import           Language.Expression.Pretty

import           Camfort.Analysis.Logger
import           Camfort.Helpers.TypeLevel
import           Language.Fortran.Model.Op.Core
import           Language.Fortran.Model.Op.Meta
import           Language.Fortran.Model.Op.Core.Match
import           Language.Fortran.Model.Singletons
import           Language.Fortran.Model.Types
import           Language.Fortran.Model.Types.Match
import           Language.Fortran.Model.Vars

--------------------------------------------------------------------------------
--  General types
--------------------------------------------------------------------------------

-- | The type of strongly-typed Fortran expressions.
type FortranExpr = HFree CoreOp FortranVar

-- | A Fortran variable with an existential type.
type SomeVar = Some FortranVar

-- | A Fortran expression with an existential type.
type SomeExpr = Some (PairOf D FortranExpr)

-- | An existential Fortran type.
type SomeType = Some D

--------------------------------------------------------------------------------
--  Semantics
--------------------------------------------------------------------------------

-- | A function mapping numeric kind annotations from Fortran programs to actual
-- precision, for a particular basic type `bt`.
newtype KindSelector = KindSelector { KindSelector -> Integer -> Maybe Precision
selectKind :: Integer -> Maybe Precision }

{-|

A (currently very incomplete) specification of the semantics of a particular
version of Fortran, needed when translating.

-}
data FortranSemantics =
  FortranSemantics
  { FortranSemantics -> KindSelector
_fsIntegerKinds         :: KindSelector
  , FortranSemantics -> KindSelector
_fsRealKinds            :: KindSelector
  , FortranSemantics -> KindSelector
_fsCharacterKinds       :: KindSelector
  , FortranSemantics -> KindSelector
_fsLogicalKinds         :: KindSelector
  , FortranSemantics -> Maybe KindSelector
_fsDoublePrecisionKinds :: Maybe KindSelector
  }

makeLenses ''FortranSemantics

{-|

== /Kinds/

The default semantics has sensible defaults for kind 0 (unspecified). Otherwise,
the kind is the number of bytes used for the type's representation. Only
power-of-two values up to 8 are valid. Characters only allow single byte
precision. Reals only allow 4- or 8-byte precision.

-}
defaultSemantics :: FortranSemantics
defaultSemantics :: FortranSemantics
defaultSemantics =
  FortranSemantics :: KindSelector
-> KindSelector
-> KindSelector
-> KindSelector
-> Maybe KindSelector
-> FortranSemantics
FortranSemantics
  { _fsIntegerKinds :: KindSelector
_fsIntegerKinds = (Integer -> Maybe Precision) -> KindSelector
KindSelector ((Integer -> Maybe Precision) -> KindSelector)
-> (Integer -> Maybe Precision) -> KindSelector
forall a b. (a -> b) -> a -> b
$ \case
      Integer
0 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P64
      Integer
1 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P8
      Integer
2 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P16
      Integer
4 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P32
      Integer
8 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P64
      Integer
_ -> Maybe Precision
forall a. Maybe a
Nothing
  , _fsRealKinds :: KindSelector
_fsRealKinds = (Integer -> Maybe Precision) -> KindSelector
KindSelector ((Integer -> Maybe Precision) -> KindSelector)
-> (Integer -> Maybe Precision) -> KindSelector
forall a b. (a -> b) -> a -> b
$ \case
      Integer
0 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P32
      Integer
4 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P32
      Integer
8 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P64
      Integer
_ -> Maybe Precision
forall a. Maybe a
Nothing
  , _fsCharacterKinds :: KindSelector
_fsCharacterKinds = (Integer -> Maybe Precision) -> KindSelector
KindSelector ((Integer -> Maybe Precision) -> KindSelector)
-> (Integer -> Maybe Precision) -> KindSelector
forall a b. (a -> b) -> a -> b
$ \case
      Integer
0 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P8
      Integer
_ -> Maybe Precision
forall a. Maybe a
Nothing
  , _fsLogicalKinds :: KindSelector
_fsLogicalKinds = (Integer -> Maybe Precision) -> KindSelector
KindSelector ((Integer -> Maybe Precision) -> KindSelector)
-> (Integer -> Maybe Precision) -> KindSelector
forall a b. (a -> b) -> a -> b
$ \case
      Integer
0 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P8
      Integer
1 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P8
      Integer
2 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P16
      Integer
4 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P32
      Integer
8 -> Precision -> Maybe Precision
forall a. a -> Maybe a
Just Precision
P64
      Integer
_ -> Maybe Precision
forall a. Maybe a
Nothing
  , _fsDoublePrecisionKinds :: Maybe KindSelector
_fsDoublePrecisionKinds = Maybe KindSelector
forall a. Maybe a
Nothing
  }


--------------------------------------------------------------------------------
--  Translate Monad
--------------------------------------------------------------------------------

-- | In order to translate Fortran expressions, we require some information
-- about the environment. That information is capture in this record.
data TranslateEnv =
  TranslateEnv
  { TranslateEnv -> Bool
_teImplicitVars :: Bool
    -- ^ Are implicit variable types enabled? (TODO: this currently does
    -- nothing)
  , TranslateEnv -> Map UniqueName SomeVar
_teVarsInScope  :: Map UniqueName SomeVar
    -- ^ A map of the variables in scope, including their types
  , TranslateEnv -> FortranSemantics
_teSemantics    :: FortranSemantics
    -- ^ The version of Fortran's semantics to use when translating code.
  }

defaultTranslateEnv :: TranslateEnv
defaultTranslateEnv :: TranslateEnv
defaultTranslateEnv =
  TranslateEnv :: Bool -> Map UniqueName SomeVar -> FortranSemantics -> TranslateEnv
TranslateEnv
  { _teImplicitVars :: Bool
_teImplicitVars = Bool
True
  , _teVarsInScope :: Map UniqueName SomeVar
_teVarsInScope = Map UniqueName SomeVar
forall a. Monoid a => a
mempty
  , _teSemantics :: FortranSemantics
_teSemantics = FortranSemantics
defaultSemantics
  }

makeLenses ''TranslateEnv

newtype TranslateT m a =
  TranslateT
  { TranslateT m a -> ReaderT TranslateEnv (ExceptT TranslateError m) a
getTranslateT
    :: ReaderT TranslateEnv (ExceptT TranslateError m) a
  }
  deriving ( a -> TranslateT m b -> TranslateT m a
(a -> b) -> TranslateT m a -> TranslateT m b
(forall a b. (a -> b) -> TranslateT m a -> TranslateT m b)
-> (forall a b. a -> TranslateT m b -> TranslateT m a)
-> Functor (TranslateT m)
forall a b. a -> TranslateT m b -> TranslateT m a
forall a b. (a -> b) -> TranslateT m a -> TranslateT m b
forall (m :: * -> *) a b.
Functor m =>
a -> TranslateT m b -> TranslateT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TranslateT m a -> TranslateT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TranslateT m b -> TranslateT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TranslateT m b -> TranslateT m a
fmap :: (a -> b) -> TranslateT m a -> TranslateT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TranslateT m a -> TranslateT m b
Functor, Functor (TranslateT m)
a -> TranslateT m a
Functor (TranslateT m)
-> (forall a. a -> TranslateT m a)
-> (forall a b.
    TranslateT m (a -> b) -> TranslateT m a -> TranslateT m b)
-> (forall a b c.
    (a -> b -> c)
    -> TranslateT m a -> TranslateT m b -> TranslateT m c)
-> (forall a b. TranslateT m a -> TranslateT m b -> TranslateT m b)
-> (forall a b. TranslateT m a -> TranslateT m b -> TranslateT m a)
-> Applicative (TranslateT m)
TranslateT m a -> TranslateT m b -> TranslateT m b
TranslateT m a -> TranslateT m b -> TranslateT m a
TranslateT m (a -> b) -> TranslateT m a -> TranslateT m b
(a -> b -> c) -> TranslateT m a -> TranslateT m b -> TranslateT m c
forall a. a -> TranslateT m a
forall a b. TranslateT m a -> TranslateT m b -> TranslateT m a
forall a b. TranslateT m a -> TranslateT m b -> TranslateT m b
forall a b.
TranslateT m (a -> b) -> TranslateT m a -> TranslateT m b
forall a b c.
(a -> b -> c) -> TranslateT m a -> TranslateT m b -> TranslateT m c
forall (m :: * -> *). Monad m => Functor (TranslateT m)
forall (m :: * -> *) a. Monad m => a -> TranslateT m a
forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> TranslateT m b -> TranslateT m a
forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> TranslateT m b -> TranslateT m b
forall (m :: * -> *) a b.
Monad m =>
TranslateT m (a -> b) -> TranslateT m a -> TranslateT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> TranslateT m a -> TranslateT m b -> TranslateT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: TranslateT m a -> TranslateT m b -> TranslateT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> TranslateT m b -> TranslateT m a
*> :: TranslateT m a -> TranslateT m b -> TranslateT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> TranslateT m b -> TranslateT m b
liftA2 :: (a -> b -> c) -> TranslateT m a -> TranslateT m b -> TranslateT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> TranslateT m a -> TranslateT m b -> TranslateT m c
<*> :: TranslateT m (a -> b) -> TranslateT m a -> TranslateT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
TranslateT m (a -> b) -> TranslateT m a -> TranslateT m b
pure :: a -> TranslateT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> TranslateT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (TranslateT m)
Applicative, Applicative (TranslateT m)
a -> TranslateT m a
Applicative (TranslateT m)
-> (forall a b.
    TranslateT m a -> (a -> TranslateT m b) -> TranslateT m b)
-> (forall a b. TranslateT m a -> TranslateT m b -> TranslateT m b)
-> (forall a. a -> TranslateT m a)
-> Monad (TranslateT m)
TranslateT m a -> (a -> TranslateT m b) -> TranslateT m b
TranslateT m a -> TranslateT m b -> TranslateT m b
forall a. a -> TranslateT m a
forall a b. TranslateT m a -> TranslateT m b -> TranslateT m b
forall a b.
TranslateT m a -> (a -> TranslateT m b) -> TranslateT m b
forall (m :: * -> *). Monad m => Applicative (TranslateT m)
forall (m :: * -> *) a. Monad m => a -> TranslateT m a
forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> TranslateT m b -> TranslateT m b
forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> (a -> TranslateT m b) -> TranslateT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TranslateT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TranslateT m a
>> :: TranslateT m a -> TranslateT m b -> TranslateT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> TranslateT m b -> TranslateT m b
>>= :: TranslateT m a -> (a -> TranslateT m b) -> TranslateT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TranslateT m a -> (a -> TranslateT m b) -> TranslateT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (TranslateT m)
Monad
           , MonadError TranslateError
           , MonadReader TranslateEnv
           , MonadLogger e w
           , Monad (TranslateT m)
Monad (TranslateT m)
-> (forall a. FilePath -> TranslateT m a)
-> MonadFail (TranslateT m)
FilePath -> TranslateT m a
forall a. FilePath -> TranslateT m a
forall (m :: * -> *).
Monad m -> (forall a. FilePath -> m a) -> MonadFail m
forall (m :: * -> *). MonadFail m => Monad (TranslateT m)
forall (m :: * -> *) a. MonadFail m => FilePath -> TranslateT m a
fail :: FilePath -> TranslateT m a
$cfail :: forall (m :: * -> *) a. MonadFail m => FilePath -> TranslateT m a
$cp1MonadFail :: forall (m :: * -> *). MonadFail m => Monad (TranslateT m)
MonadFail
           )

runTranslateT
  :: (Monad m, MonadFail m)
  => TranslateT m a
  -> TranslateEnv
  -> m (Either TranslateError a)
runTranslateT :: TranslateT m a -> TranslateEnv -> m (Either TranslateError a)
runTranslateT (TranslateT ReaderT TranslateEnv (ExceptT TranslateError m) a
action) TranslateEnv
env = ExceptT TranslateError m a -> m (Either TranslateError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TranslateError m a -> m (Either TranslateError a))
-> ExceptT TranslateError m a -> m (Either TranslateError a)
forall a b. (a -> b) -> a -> b
$ ReaderT TranslateEnv (ExceptT TranslateError m) a
-> TranslateEnv -> ExceptT TranslateError m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT TranslateEnv (ExceptT TranslateError m) a
action TranslateEnv
env

--------------------------------------------------------------------------------
--  Errors
--------------------------------------------------------------------------------

data TranslateError
  = ErrUnsupportedItem Text
  -- ^ Tried to translate a part of the language that is not (yet) supported.
  | ErrBadLiteral
  -- ^ Found a literal value that we didn't know how to translate. May or may
  -- not be valid Fortran.
  | ErrUnexpectedType Text SomeType SomeType
  -- ^ @'ErrUnexpectedType' message expected actual@: tried to translate a
  -- Fortran language part into the wrong expression type, and it wasn't
  -- coercible to the correct type.
  | ErrInvalidOpApplication (Some (Rec D))
  -- ^ Tried to apply an operator to arguments with the wrong types.
  | ErrVarNotInScope F.Name
  -- ^ Reference to a variable that's not currently in scope
  | ErrInvalidKind Text Integer
  -- ^ @'ErrInvalidKind' baseTypeName givenKind@: tried to interpret a type with
  -- the given kind which is not valid under the semantics.
  deriving (Typeable)

instance Describe TranslateError where
  describeBuilder :: TranslateError -> Builder
describeBuilder = \case
    ErrUnsupportedItem Text
message ->
      Builder
"unsupported " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall a. Describe a => a -> Builder
describeBuilder Text
message

    TranslateError
ErrBadLiteral ->
      Builder
"encountered a literal value that couldn't be translated; " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Builder
"it might be invalid Fortran or it might use unsupported language features"

    ErrUnexpectedType Text
message SomeType
expected SomeType
actual ->
      Builder
"unexpected type in " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall a. Describe a => a -> Builder
describeBuilder Text
message Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Builder
"; expected type was '" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
forall a. Describe a => a -> Builder
describeBuilder (SomeType -> FilePath
forall a. Show a => a -> FilePath
show SomeType
expected) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      Builder
"'; actual type was '" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
forall a. Describe a => a -> Builder
describeBuilder (SomeType -> FilePath
forall a. Show a => a -> FilePath
show SomeType
actual) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"'"

    ErrInvalidOpApplication (Some Rec D a
argTypes) ->
      let descTypes :: [Builder]
descTypes = Rec (Const Builder) a -> [Builder]
forall u a (rs :: [u]). Rec (Const a) rs -> [a]
VinylRec.recordToList Rec (Const Builder) a
descTypesRec
          descTypesRec :: Rec (Const Builder) a
descTypesRec = (forall x. D x -> Const Builder x)
-> Rec D a -> Rec (Const Builder) a
forall u (f :: u -> *) (g :: u -> *) (rs :: [u]).
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
VinylRec.rmap (Builder -> Const Builder x
forall k a (b :: k). a -> Const a b
Const (Builder -> Const Builder x)
-> (D x -> Builder) -> D x -> Const Builder x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
surround Builder
"'" (Builder -> Builder) -> (D x -> Builder) -> D x -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Builder
forall a. Describe a => a -> Builder
describeBuilder (FilePath -> Builder) -> (D x -> FilePath) -> D x -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D x -> FilePath
forall k (t :: k -> *) (a :: k). Pretty1 t => t a -> FilePath
pretty1) Rec D a
argTypes
          surround :: a -> a -> a
surround a
s a
x = a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
x a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s
      in Builder
"tried to apply operator to arguments of the wrong type; arguments had types " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
         [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat (Builder -> [Builder] -> [Builder]
forall a. a -> [a] -> [a]
intersperse Builder
", " [Builder]
descTypes)

    ErrVarNotInScope FilePath
nm ->
      Builder
"reference to variable '" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
forall a. Describe a => a -> Builder
describeBuilder FilePath
nm Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"' which is not in scope"

    ErrInvalidKind Text
bt Integer
k ->
      Builder
"type with base '" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
forall a. Describe a => a -> Builder
describeBuilder Text
bt Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"' specified a kind '" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
      FilePath -> Builder
forall a. Describe a => a -> Builder
describeBuilder (Integer -> FilePath
forall a. Show a => a -> FilePath
show Integer
k) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"' which is not valid under the current semantics"

unsupported :: (MonadError TranslateError m) => Text -> m a
unsupported :: Text -> m a
unsupported = TranslateError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> m a) -> (Text -> TranslateError) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TranslateError
ErrUnsupportedItem

--------------------------------------------------------------------------------
--  Translating Types
--------------------------------------------------------------------------------

{-|

The different ways of specifying Fortran types are complicated. This record
contains information about all the different things that might contribute to a
type.

-}
data TypeInfo ann =
  TypeInfo
  { TypeInfo ann -> SrcSpan
_tiSrcSpan              :: F.SrcSpan
  , TypeInfo ann -> BaseType
_tiBaseType             :: F.BaseType
  , TypeInfo ann -> Maybe (Expression ann)
_tiSelectorLength       :: Maybe (F.Expression ann)
    -- ^ The length expression from a 'F.Selector' associated with a
    -- 'F.TypeSpec'.
  , TypeInfo ann -> Maybe (Expression ann)
_tiSelectorKind         :: Maybe (F.Expression ann)
    -- ^ The kind expression from a 'F.Selector' associated with a 'F.TypeSpec'.
  , TypeInfo ann -> Maybe (Expression ann)
_tiDeclaratorLength     :: Maybe (F.Expression ann)
    -- ^ The length expression from a 'F.Declarator' associated with an instance
    -- of 'F.StDeclaration'.
  , TypeInfo ann -> Maybe (AList DimensionDeclarator ann)
_tiDimensionDeclarators :: Maybe (F.AList F.DimensionDeclarator ann)
    -- ^ The list of dimension declarators from an instance of 'F.DeclArray'
    -- associated with an instance of 'F.StDeclaration'.
  , TypeInfo ann -> Maybe (AList Attribute ann)
_tiAttributes           :: Maybe (F.AList F.Attribute ann)
    -- ^ The list of attributes from an instance of 'F.StDeclaration'.
  }
  deriving (a -> TypeInfo b -> TypeInfo a
(a -> b) -> TypeInfo a -> TypeInfo b
(forall a b. (a -> b) -> TypeInfo a -> TypeInfo b)
-> (forall a b. a -> TypeInfo b -> TypeInfo a) -> Functor TypeInfo
forall a b. a -> TypeInfo b -> TypeInfo a
forall a b. (a -> b) -> TypeInfo a -> TypeInfo b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TypeInfo b -> TypeInfo a
$c<$ :: forall a b. a -> TypeInfo b -> TypeInfo a
fmap :: (a -> b) -> TypeInfo a -> TypeInfo b
$cfmap :: forall a b. (a -> b) -> TypeInfo a -> TypeInfo b
Functor, Int -> TypeInfo ann -> ShowS
[TypeInfo ann] -> ShowS
TypeInfo ann -> FilePath
(Int -> TypeInfo ann -> ShowS)
-> (TypeInfo ann -> FilePath)
-> ([TypeInfo ann] -> ShowS)
-> Show (TypeInfo ann)
forall ann. Show ann => Int -> TypeInfo ann -> ShowS
forall ann. Show ann => [TypeInfo ann] -> ShowS
forall ann. Show ann => TypeInfo ann -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [TypeInfo ann] -> ShowS
$cshowList :: forall ann. Show ann => [TypeInfo ann] -> ShowS
show :: TypeInfo ann -> FilePath
$cshow :: forall ann. Show ann => TypeInfo ann -> FilePath
showsPrec :: Int -> TypeInfo ann -> ShowS
$cshowsPrec :: forall ann. Show ann => Int -> TypeInfo ann -> ShowS
Show)

makeLenses ''TypeInfo

instance F.Spanned (TypeInfo ann) where
  getSpan :: TypeInfo ann -> SrcSpan
getSpan = Getting SrcSpan (TypeInfo ann) SrcSpan -> TypeInfo ann -> SrcSpan
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting SrcSpan (TypeInfo ann) SrcSpan
forall ann. Lens' (TypeInfo ann) SrcSpan
tiSrcSpan
  setSpan :: SrcSpan -> TypeInfo ann -> TypeInfo ann
setSpan = ASetter (TypeInfo ann) (TypeInfo ann) SrcSpan SrcSpan
-> SrcSpan -> TypeInfo ann -> TypeInfo ann
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (TypeInfo ann) (TypeInfo ann) SrcSpan SrcSpan
forall ann. Lens' (TypeInfo ann) SrcSpan
tiSrcSpan

-- | Create a simple 'TypeInfo' from an 'F.TypeSpec'. Many use cases will need
-- to add more information to fully specify the type.
typeInfo :: F.TypeSpec ann -> TypeInfo ann
typeInfo :: TypeSpec ann -> TypeInfo ann
typeInfo ts :: TypeSpec ann
ts@(F.TypeSpec ann
_ SrcSpan
_ BaseType
bt Maybe (Selector ann)
mselector) =
  let selectorLength :: Selector a -> Maybe (Expression a)
selectorLength (F.Selector a
_ SrcSpan
_ Maybe (Expression a)
l Maybe (Expression a)
_) = Maybe (Expression a)
l
      selectorKind :: Selector a -> Maybe (Expression a)
selectorKind (F.Selector a
_ SrcSpan
_ Maybe (Expression a)
_ Maybe (Expression a)
k) = Maybe (Expression a)
k
  in TypeInfo :: forall ann.
SrcSpan
-> BaseType
-> Maybe (Expression ann)
-> Maybe (Expression ann)
-> Maybe (Expression ann)
-> Maybe (AList DimensionDeclarator ann)
-> Maybe (AList Attribute ann)
-> TypeInfo ann
TypeInfo
     { _tiSrcSpan :: SrcSpan
_tiSrcSpan = TypeSpec ann -> SrcSpan
forall a. Spanned a => a -> SrcSpan
F.getSpan TypeSpec ann
ts
     , _tiBaseType :: BaseType
_tiBaseType = BaseType
bt
     , _tiSelectorLength :: Maybe (Expression ann)
_tiSelectorLength = Maybe (Selector ann)
mselector Maybe (Selector ann)
-> (Selector ann -> Maybe (Expression ann))
-> Maybe (Expression ann)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Selector ann -> Maybe (Expression ann)
forall a. Selector a -> Maybe (Expression a)
selectorLength
     , _tiSelectorKind :: Maybe (Expression ann)
_tiSelectorKind = Maybe (Selector ann)
mselector Maybe (Selector ann)
-> (Selector ann -> Maybe (Expression ann))
-> Maybe (Expression ann)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Selector ann -> Maybe (Expression ann)
forall a. Selector a -> Maybe (Expression a)
selectorKind
     , _tiDeclaratorLength :: Maybe (Expression ann)
_tiDeclaratorLength = Maybe (Expression ann)
forall a. Maybe a
Nothing
     , _tiDimensionDeclarators :: Maybe (AList DimensionDeclarator ann)
_tiDimensionDeclarators = Maybe (AList DimensionDeclarator ann)
forall a. Maybe a
Nothing
     , _tiAttributes :: Maybe (AList Attribute ann)
_tiAttributes = Maybe (AList Attribute ann)
forall a. Maybe a
Nothing
     }


-- | Convert a 'TypeInfo' to its corresponding strong type.
translateTypeInfo
  :: (Monad m, MonadFail m, Show ann)
  => TypeInfo ann
  -> TranslateT m SomeType
translateTypeInfo :: TypeInfo ann -> TranslateT m SomeType
translateTypeInfo TypeInfo ann
ti = do
  -- TODO: Derived data types
  SomePrimD D (PrimS a)
basePrim <- BaseType -> Maybe (Expression ann) -> TranslateT m SomePrimD
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
BaseType -> Maybe (Expression ann) -> TranslateT m SomePrimD
translateBaseType (TypeInfo ann
ti TypeInfo ann
-> Getting BaseType (TypeInfo ann) BaseType -> BaseType
forall s a. s -> Getting a s a -> a
^. Getting BaseType (TypeInfo ann) BaseType
forall ann. Lens' (TypeInfo ann) BaseType
tiBaseType) (TypeInfo ann
ti TypeInfo ann
-> Getting
     (Maybe (Expression ann)) (TypeInfo ann) (Maybe (Expression ann))
-> Maybe (Expression ann)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Expression ann)) (TypeInfo ann) (Maybe (Expression ann))
forall ann. Lens' (TypeInfo ann) (Maybe (Expression ann))
tiSelectorKind)

  let
    -- If an attribute corresponds to a dimension declaration which contains a
    -- simple length dimension, get the expression out.
    attrToLength :: Attribute a -> Maybe (Expression a)
attrToLength (F.AttrDimension a
_ SrcSpan
_ AList DimensionDeclarator a
declarators) = AList DimensionDeclarator a -> Maybe (Expression a)
forall a. AList DimensionDeclarator a -> Maybe (Expression a)
dimensionDeclaratorsToLength AList DimensionDeclarator a
declarators
    attrToLength Attribute a
_                           = Maybe (Expression a)
forall a. Maybe a
Nothing

    attrsToLength :: AList Attribute a -> Maybe (Expression a)
attrsToLength (F.AList a
_ SrcSpan
_ [Attribute a]
attrs) =
      case [Maybe (Expression a)] -> [Expression a]
forall a. [Maybe a] -> [a]
catMaybes (Attribute a -> Maybe (Expression a)
forall a. Attribute a -> Maybe (Expression a)
attrToLength (Attribute a -> Maybe (Expression a))
-> [Attribute a] -> [Maybe (Expression a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Attribute a]
attrs) of
        [Expression a
e] -> Expression a -> Maybe (Expression a)
forall a. a -> Maybe a
Just Expression a
e
        [Expression a]
_   -> Maybe (Expression a)
forall a. Maybe a
Nothing

    -- If a list of dimension declarators corresponds to a simple one
    -- dimensional length, get the expression out. We don't handle other cases
    -- yet.
    dimensionDeclaratorsToLength :: AList DimensionDeclarator a -> Maybe (Expression a)
dimensionDeclaratorsToLength (F.AList a
_ SrcSpan
_ [F.DimensionDeclarator a
_ SrcSpan
_ Maybe (Expression a)
e1 Maybe (Expression a)
e2]) = Maybe (Expression a)
e1 Maybe (Expression a)
-> Maybe (Expression a) -> Maybe (Expression a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe (Expression a)
e2
    dimensionDeclaratorsToLength AList DimensionDeclarator a
_ = Maybe (Expression a)
forall a. Maybe a
Nothing

    mLengthExp :: Maybe (Expression ann)
mLengthExp =
      (TypeInfo ann
ti TypeInfo ann
-> Getting
     (Maybe (Expression ann)) (TypeInfo ann) (Maybe (Expression ann))
-> Maybe (Expression ann)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Expression ann)) (TypeInfo ann) (Maybe (Expression ann))
forall ann. Lens' (TypeInfo ann) (Maybe (Expression ann))
tiSelectorLength) Maybe (Expression ann)
-> Maybe (Expression ann) -> Maybe (Expression ann)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      (TypeInfo ann
ti TypeInfo ann
-> Getting
     (Maybe (Expression ann)) (TypeInfo ann) (Maybe (Expression ann))
-> Maybe (Expression ann)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (Expression ann)) (TypeInfo ann) (Maybe (Expression ann))
forall ann. Lens' (TypeInfo ann) (Maybe (Expression ann))
tiDeclaratorLength) Maybe (Expression ann)
-> Maybe (Expression ann) -> Maybe (Expression ann)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      (TypeInfo ann
ti TypeInfo ann
-> Getting
     (Maybe (AList DimensionDeclarator ann))
     (TypeInfo ann)
     (Maybe (AList DimensionDeclarator ann))
-> Maybe (AList DimensionDeclarator ann)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (AList DimensionDeclarator ann))
  (TypeInfo ann)
  (Maybe (AList DimensionDeclarator ann))
forall ann.
Lens' (TypeInfo ann) (Maybe (AList DimensionDeclarator ann))
tiDimensionDeclarators Maybe (AList DimensionDeclarator ann)
-> (AList DimensionDeclarator ann -> Maybe (Expression ann))
-> Maybe (Expression ann)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AList DimensionDeclarator ann -> Maybe (Expression ann)
forall a. AList DimensionDeclarator a -> Maybe (Expression a)
dimensionDeclaratorsToLength) Maybe (Expression ann)
-> Maybe (Expression ann) -> Maybe (Expression ann)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
      (TypeInfo ann
ti TypeInfo ann
-> Getting
     (Maybe (AList Attribute ann))
     (TypeInfo ann)
     (Maybe (AList Attribute ann))
-> Maybe (AList Attribute ann)
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe (AList Attribute ann))
  (TypeInfo ann)
  (Maybe (AList Attribute ann))
forall ann. Lens' (TypeInfo ann) (Maybe (AList Attribute ann))
tiAttributes Maybe (AList Attribute ann)
-> (AList Attribute ann -> Maybe (Expression ann))
-> Maybe (Expression ann)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= AList Attribute ann -> Maybe (Expression ann)
forall a. AList Attribute a -> Maybe (Expression a)
attrsToLength)

  case Maybe (Expression ann)
mLengthExp of
    Just Expression ann
lengthExp -> do
      -- If a length expression could be found, this variable is an array

      -- TODO: If the length expression is malformed, throw an error.
      -- TODO: Use information about the length.
      -- maybe (unsupported "type spec") void (exprIntLit lengthExp)
      case D (PrimS a)
basePrim of
        DPrim Prim p k a
bp -> SomeType -> TranslateT m SomeType
forall (m :: * -> *) a. Monad m => a -> m a
return (D (Array (PrimS Int64) (PrimS a)) -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some (Index (PrimS Int64)
-> ArrValue (PrimS a) -> D (Array (PrimS Int64) (PrimS a))
forall i a. Index i -> ArrValue a -> D (Array i a)
DArray (Prim 'P64 'BTInt Int64 -> Index (PrimS Int64)
forall (p :: Precision) a. Prim p 'BTInt a -> Index (PrimS a)
Index Prim 'P64 'BTInt Int64
PInt64) (Prim p k a -> ArrValue (PrimS a)
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> ArrValue (PrimS a)
ArrPrim Prim p k a
bp)))
    Maybe (Expression ann)
Nothing ->
      SomeType -> TranslateT m SomeType
forall (m :: * -> *) a. Monad m => a -> m a
return (D (PrimS a) -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some D (PrimS a)
basePrim)


data SomePrimD where
  SomePrimD :: D (PrimS a) -> SomePrimD

translateBaseType
  :: (Monad m, MonadFail m)
  => F.BaseType
  -> Maybe (F.Expression ann) -- ^ Kind
  -> TranslateT m SomePrimD
translateBaseType :: BaseType -> Maybe (Expression ann) -> TranslateT m SomePrimD
translateBaseType BaseType
bt Maybe (Expression ann)
mkind = do

  Integer
kindInt <- case Maybe (Expression ann)
mkind of
    Maybe (Expression ann)
Nothing -> Integer -> TranslateT m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0
    Just (F.ExpValue ann
_ SrcSpan
_ (F.ValInteger FilePath
s)) ->
      case FilePath -> Maybe Integer
readLitInteger FilePath
s of
        Just Integer
k  -> Integer -> TranslateT m Integer
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
k
        Maybe Integer
Nothing -> TranslateError -> TranslateT m Integer
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TranslateError
ErrBadLiteral
    Maybe (Expression ann)
_ -> Text -> TranslateT m Integer
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"kind which isn't an integer literal"

  let getKindPrec :: Text
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> TranslateT m Precision
getKindPrec Text
btName (KindSelector -> Const (First KindSelector) KindSelector)
-> FortranSemantics -> Const (First KindSelector) FortranSemantics
ksl = do
        Maybe KindSelector
mks <- Getting (First KindSelector) TranslateEnv KindSelector
-> TranslateT m (Maybe KindSelector)
forall s (m :: * -> *) a.
MonadReader s m =>
Getting (First a) s a -> m (Maybe a)
preview ((FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> TranslateEnv -> Const (First KindSelector) TranslateEnv
Lens' TranslateEnv FortranSemantics
teSemantics ((FortranSemantics -> Const (First KindSelector) FortranSemantics)
 -> TranslateEnv -> Const (First KindSelector) TranslateEnv)
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> Getting (First KindSelector) TranslateEnv KindSelector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KindSelector -> Const (First KindSelector) KindSelector)
-> FortranSemantics -> Const (First KindSelector) FortranSemantics
ksl)
        case Maybe KindSelector
mks Maybe KindSelector
-> (KindSelector -> Maybe Precision) -> Maybe Precision
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (KindSelector -> Integer -> Maybe Precision
`selectKind` Integer
kindInt) of
          Just Precision
p  -> Precision -> TranslateT m Precision
forall (m :: * -> *) a. Monad m => a -> m a
return Precision
p
          Maybe Precision
Nothing -> TranslateError -> TranslateT m Precision
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> TranslateT m Precision)
-> TranslateError -> TranslateT m Precision
forall a b. (a -> b) -> a -> b
$ Text -> Integer -> TranslateError
ErrInvalidKind Text
btName Integer
kindInt

  -- Get value-level representations of the type's basic type and precision
  (BasicType
basicType, Precision
prec) <- case BaseType
bt of
    BaseType
F.TypeInteger     -> (BasicType
BTInt     ,) (Precision -> (BasicType, Precision))
-> TranslateT m Precision -> TranslateT m (BasicType, Precision)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> TranslateT m Precision
getKindPrec Text
"integer"   (KindSelector -> Const (First KindSelector) KindSelector)
-> FortranSemantics -> Const (First KindSelector) FortranSemantics
Lens' FortranSemantics KindSelector
fsIntegerKinds
    BaseType
F.TypeReal        -> (BasicType
BTReal    ,) (Precision -> (BasicType, Precision))
-> TranslateT m Precision -> TranslateT m (BasicType, Precision)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> TranslateT m Precision
getKindPrec Text
"real"      (KindSelector -> Const (First KindSelector) KindSelector)
-> FortranSemantics -> Const (First KindSelector) FortranSemantics
Lens' FortranSemantics KindSelector
fsRealKinds
    F.TypeCharacter{} -> (BasicType
BTChar    ,) (Precision -> (BasicType, Precision))
-> TranslateT m Precision -> TranslateT m (BasicType, Precision)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> TranslateT m Precision
getKindPrec Text
"character" (KindSelector -> Const (First KindSelector) KindSelector)
-> FortranSemantics -> Const (First KindSelector) FortranSemantics
Lens' FortranSemantics KindSelector
fsCharacterKinds
    BaseType
F.TypeLogical     -> (BasicType
BTLogical ,) (Precision -> (BasicType, Precision))
-> TranslateT m Precision -> TranslateT m (BasicType, Precision)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> TranslateT m Precision
getKindPrec Text
"logical"   (KindSelector -> Const (First KindSelector) KindSelector)
-> FortranSemantics -> Const (First KindSelector) FortranSemantics
Lens' FortranSemantics KindSelector
fsLogicalKinds
    -- Double precision is special because it's not always supported as its own
    -- basic type, being subsumed by the `REAL` basic type.
    BaseType
F.TypeDoublePrecision ->
      (BasicType
BTReal,) (Precision -> (BasicType, Precision))
-> TranslateT m Precision -> TranslateT m (BasicType, Precision)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> TranslateT m Precision
getKindPrec Text
"double precision" ((Maybe KindSelector
 -> Const (First KindSelector) (Maybe KindSelector))
-> FortranSemantics -> Const (First KindSelector) FortranSemantics
Lens' FortranSemantics (Maybe KindSelector)
fsDoublePrecisionKinds ((Maybe KindSelector
  -> Const (First KindSelector) (Maybe KindSelector))
 -> FortranSemantics -> Const (First KindSelector) FortranSemantics)
-> ((KindSelector -> Const (First KindSelector) KindSelector)
    -> Maybe KindSelector
    -> Const (First KindSelector) (Maybe KindSelector))
-> (KindSelector -> Const (First KindSelector) KindSelector)
-> FortranSemantics
-> Const (First KindSelector) FortranSemantics
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KindSelector -> Const (First KindSelector) KindSelector)
-> Maybe KindSelector
-> Const (First KindSelector) (Maybe KindSelector)
forall a b. Prism (Maybe a) (Maybe b) a b
_Just)
    BaseType
_ -> Text -> TranslateT m (BasicType, Precision)
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"type spec"

  -- Lift the value-level representations to the type level and get a primitive
  -- type with those properties.
  case (Demote BasicType -> SomeSing BasicType
forall k. SingKind k => Demote k -> SomeSing k
toSing BasicType
Demote BasicType
basicType, Demote Precision -> SomeSing Precision
forall k. SingKind k => Demote k -> SomeSing k
toSing Precision
Demote Precision
prec) of
    (SomeSing Sing a
sbt, SomeSing Sing a
sprec) -> case Sing a -> Sing a -> Maybe (MakePrim a a)
forall (p :: Precision) (k :: BasicType).
Sing p -> Sing k -> Maybe (MakePrim p k)
makePrim Sing a
sprec Sing a
sbt of
      Just (MakePrim Prim a a a
prim) -> SomePrimD -> TranslateT m SomePrimD
forall (m :: * -> *) a. Monad m => a -> m a
return (D (PrimS a) -> SomePrimD
forall a. D (PrimS a) -> SomePrimD
SomePrimD (Prim a a a -> D (PrimS a)
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> D (PrimS a)
DPrim Prim a a a
prim))
      Maybe (MakePrim a a)
Nothing              -> Text -> TranslateT m SomePrimD
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"type spec"

--------------------------------------------------------------------------------
--  Translating Expressions
--------------------------------------------------------------------------------

-- | Translate an expression with an unknown type. The return value
-- existentially captures the type of the result.
translateExpression :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr
translateExpression :: Expression (Analysis ann) -> TranslateT m SomeExpr
translateExpression = \case
  e :: Expression (Analysis ann)
e@(F.ExpValue Analysis ann
ann SrcSpan
span Value (Analysis ann)
val) -> Expression (Analysis ann) -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann) -> TranslateT m SomeExpr
translateValue Expression (Analysis ann)
e
  F.ExpBinary Analysis ann
ann SrcSpan
span BinaryOp
bop Expression (Analysis ann)
e1 Expression (Analysis ann)
e2 -> Expression (Analysis ann)
-> Expression (Analysis ann) -> BinaryOp -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann)
-> Expression (Analysis ann) -> BinaryOp -> TranslateT m SomeExpr
translateOp2App Expression (Analysis ann)
e1 Expression (Analysis ann)
e2 BinaryOp
bop
  F.ExpUnary Analysis ann
ann SrcSpan
span UnaryOp
uop Expression (Analysis ann)
operand -> Expression (Analysis ann) -> UnaryOp -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann) -> UnaryOp -> TranslateT m SomeExpr
translateOp1App Expression (Analysis ann)
operand UnaryOp
uop

  F.ExpSubscript Analysis ann
ann SrcSpan
span Expression (Analysis ann)
lhs (F.AList Analysis ann
_ SrcSpan
_ [Index (Analysis ann)]
indices) -> Expression (Analysis ann)
-> [Index (Analysis ann)] -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann)
-> [Index (Analysis ann)] -> TranslateT m SomeExpr
translateSubscript Expression (Analysis ann)
lhs [Index (Analysis ann)]
indices

  F.ExpDataRef Analysis ann
ann SrcSpan
span Expression (Analysis ann)
e1 Expression (Analysis ann)
e2           -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"data reference"
  F.ExpFunctionCall Analysis ann
ann SrcSpan
span Expression (Analysis ann)
fexpr Maybe (AList Argument (Analysis ann))
args -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"function call"
  F.ExpImpliedDo Analysis ann
ann SrcSpan
span AList Expression (Analysis ann)
es DoSpecification (Analysis ann)
spec       -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"implied do expression"
  F.ExpInitialisation Analysis ann
ann SrcSpan
span AList Expression (Analysis ann)
es       -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"intitialization expression"
  F.ExpReturnSpec Analysis ann
ann SrcSpan
span Expression (Analysis ann)
rval         -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"return spec expression"


-- | Translate an expression with a known type. Fails if the actual type does
-- not match.
translateExpression'
  :: (Monad m, MonadFail m) => D a -> F.Expression (F.Analysis ann)
  -> TranslateT m (FortranExpr a)
translateExpression' :: D a -> Expression (Analysis ann) -> TranslateT m (FortranExpr a)
translateExpression' D a
targetD Expression (Analysis ann)
ast = do
  SomePair D a
sourceD FortranExpr a
expr <- Expression (Analysis ann) -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann) -> TranslateT m SomeExpr
translateExpression Expression (Analysis ann)
ast

  case D a -> D a -> FortranExpr a -> Maybe (FortranExpr a)
forall a b (f :: * -> *). D a -> D b -> f a -> Maybe (f b)
dcast D a
sourceD D a
targetD FortranExpr a
expr of
    Just FortranExpr a
y -> FortranExpr a -> TranslateT m (FortranExpr a)
forall (m :: * -> *) a. Monad m => a -> m a
return FortranExpr a
y
    Maybe (FortranExpr a)
Nothing -> TranslateError -> TranslateT m (FortranExpr a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> TranslateT m (FortranExpr a))
-> TranslateError -> TranslateT m (FortranExpr a)
forall a b. (a -> b) -> a -> b
$ Text -> SomeType -> SomeType -> TranslateError
ErrUnexpectedType Text
"expression" (D a -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some D a
sourceD) (D a -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some D a
targetD)


-- | Translate an expression and try to coerce it to a particular type. Fails if
-- the actual type cannot be coerced to the given type.
translateCoerceExpression
  :: (Monad m, MonadFail m) => D a -> F.Expression (F.Analysis ann)
  -> TranslateT m (HFree MetaOp FortranExpr a)
translateCoerceExpression :: D a
-> Expression (Analysis ann)
-> TranslateT m (HFree MetaOp FortranExpr a)
translateCoerceExpression D a
targetD Expression (Analysis ann)
ast = do
  SomePair D a
sourceD FortranExpr a
expr <- Expression (Analysis ann) -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann) -> TranslateT m SomeExpr
translateExpression Expression (Analysis ann)
ast

  -- First check if it's already the right type
  case D a -> D a -> FortranExpr a -> Maybe (FortranExpr a)
forall a b (f :: * -> *). D a -> D b -> f a -> Maybe (f b)
dcast D a
sourceD D a
targetD FortranExpr a
expr of
    Just FortranExpr a
y -> HFree MetaOp FortranExpr a
-> TranslateT m (HFree MetaOp FortranExpr a)
forall (m :: * -> *) a. Monad m => a -> m a
return (FortranExpr a -> HFree MetaOp FortranExpr a
forall k (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
t a -> HFree h t a
HPure FortranExpr a
y)
    Maybe (FortranExpr a)
Nothing -> case (D a -> Maybe (MatchPrimD a)
forall a. D a -> Maybe (MatchPrimD a)
matchPrimD D a
sourceD, D a -> Maybe (MatchPrimD a)
forall a. D a -> Maybe (MatchPrimD a)
matchPrimD D a
targetD) of
      (Just (MatchPrimD MatchPrim p k a
_ Prim p k a
sourcePrim), Just (MatchPrimD MatchPrim p k a
_ Prim p k a
targetPrim)) ->
        HFree MetaOp FortranExpr (PrimS a)
-> TranslateT m (HFree MetaOp FortranExpr (PrimS a))
forall (m :: * -> *) a. Monad m => a -> m a
return (MetaOp (HFree MetaOp FortranExpr) (PrimS a)
-> HFree MetaOp FortranExpr (PrimS a)
forall k (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
h (HFree h t) a -> HFree h t a
HWrap (Prim p k a
-> HFree MetaOp FortranExpr (PrimS a)
-> MetaOp (HFree MetaOp FortranExpr) (PrimS a)
forall (p :: Precision) (k :: BasicType) b (t :: * -> *) a.
Prim p k b -> t (PrimS a) -> MetaOp t (PrimS b)
MopCoercePrim Prim p k a
targetPrim (FortranExpr a -> HFree MetaOp FortranExpr a
forall k (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
t a -> HFree h t a
HPure FortranExpr a
expr)))
      (Maybe (MatchPrimD a), Maybe (MatchPrimD a))
_ -> TranslateError -> TranslateT m (HFree MetaOp FortranExpr a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> TranslateT m (HFree MetaOp FortranExpr a))
-> TranslateError -> TranslateT m (HFree MetaOp FortranExpr a)
forall a b. (a -> b) -> a -> b
$ Text -> SomeType -> SomeType -> TranslateError
ErrUnexpectedType Text
"expression" (D a -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some D a
sourceD) (D a -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some D a
targetD)


translateSubscript
  :: (Monad m, MonadFail m)
  => F.Expression (F.Analysis ann) -> [F.Index (F.Analysis ann)] -> TranslateT m SomeExpr
translateSubscript :: Expression (Analysis ann)
-> [Index (Analysis ann)] -> TranslateT m SomeExpr
translateSubscript Expression (Analysis ann)
arrAst [F.IxSingle Analysis ann
_ SrcSpan
_ Maybe FilePath
_ Expression (Analysis ann)
ixAst] = do
  SomePair D a
arrD FortranExpr a
arrExp <- Expression (Analysis ann) -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann) -> TranslateT m SomeExpr
translateExpression Expression (Analysis ann)
arrAst
  SomePair D a
ixD FortranExpr a
ixExp <- Expression (Analysis ann) -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann) -> TranslateT m SomeExpr
translateExpression Expression (Analysis ann)
ixAst

  case Op (Length '[a, a]) 'OKLookup
-> Rec D '[a, a] -> Maybe (MatchOpSpec 'OKLookup '[a, a])
forall (args :: [*]) (ok :: OpKind).
Op (Length args) ok -> Rec D args -> Maybe (MatchOpSpec ok args)
matchOpSpec Op 2 'OKLookup
Op (Length '[a, a]) 'OKLookup
OpLookup (D a
arrD D a -> Rec D '[a] -> Rec D '[a, a]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& D a
ixD D a -> Rec D '[] -> Rec D '[a]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec D '[]
forall u (a :: u -> *). Rec a '[]
RNil) of
    Just (MatchOpSpec OpSpec 'OKLookup '[a, a] result
opResult D result
resultD) ->
      SomeExpr -> TranslateT m SomeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeExpr -> TranslateT m SomeExpr)
-> SomeExpr -> TranslateT m SomeExpr
forall a b. (a -> b) -> a -> b
$ D result -> HFree CoreOp FortranVar result -> SomeExpr
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Some (PairOf f g)
SomePair D result
resultD (HFree CoreOp FortranVar result -> SomeExpr)
-> HFree CoreOp FortranVar result -> SomeExpr
forall a b. (a -> b) -> a -> b
$ CoreOp FortranExpr result -> HFree CoreOp FortranVar result
forall k (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
h (HFree h t) a -> HFree h t a
HWrap (CoreOp FortranExpr result -> HFree CoreOp FortranVar result)
-> CoreOp FortranExpr result -> HFree CoreOp FortranVar result
forall a b. (a -> b) -> a -> b
$ Op (Length '[a, a]) 'OKLookup
-> OpSpec 'OKLookup '[a, a] result
-> Rec FortranExpr '[a, a]
-> CoreOp FortranExpr result
forall (args :: [*]) (ok :: OpKind) result (t :: * -> *).
Op (Length args) ok
-> OpSpec ok args result -> Rec t args -> CoreOp t result
CoreOp Op 2 'OKLookup
Op (Length '[a, a]) 'OKLookup
OpLookup OpSpec 'OKLookup '[a, a] result
opResult (FortranExpr a
arrExp FortranExpr a -> Rec FortranExpr '[a] -> Rec FortranExpr '[a, a]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& FortranExpr a
ixExp FortranExpr a -> Rec FortranExpr '[] -> Rec FortranExpr '[a]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec FortranExpr '[]
forall u (a :: u -> *). Rec a '[]
RNil)
    Maybe (MatchOpSpec 'OKLookup '[a, a])
Nothing ->
      case D a
arrD of
        -- If the LHS is indeed an array, the index type must not have matched
        DArray (Index Prim p 'BTInt a
requiredIx) ArrValue a
_ ->
          TranslateError -> TranslateT m SomeExpr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> TranslateT m SomeExpr)
-> TranslateError -> TranslateT m SomeExpr
forall a b. (a -> b) -> a -> b
$
          Text -> SomeType -> SomeType -> TranslateError
ErrUnexpectedType Text
"array indexing"
          (D (PrimS a) -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some (Prim p 'BTInt a -> D (PrimS a)
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> D (PrimS a)
DPrim Prim p 'BTInt a
requiredIx)) (D a -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some D a
ixD)
        -- If the LHS is not an array, tell the user we expected some specific
        -- array type; in reality any array type would have done.
        D a
_ -> TranslateError -> TranslateT m SomeExpr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> TranslateT m SomeExpr)
-> TranslateError -> TranslateT m SomeExpr
forall a b. (a -> b) -> a -> b
$
          Text -> SomeType -> SomeType -> TranslateError
ErrUnexpectedType Text
"array indexing"
          (D (Array (PrimS Int64) (PrimS Int64)) -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some (Index (PrimS Int64)
-> ArrValue (PrimS Int64) -> D (Array (PrimS Int64) (PrimS Int64))
forall i a. Index i -> ArrValue a -> D (Array i a)
DArray (Prim 'P64 'BTInt Int64 -> Index (PrimS Int64)
forall (p :: Precision) a. Prim p 'BTInt a -> Index (PrimS a)
Index Prim 'P64 'BTInt Int64
PInt64) (Prim 'P64 'BTInt Int64 -> ArrValue (PrimS Int64)
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> ArrValue (PrimS a)
ArrPrim Prim 'P64 'BTInt Int64
PInt64)))
          (D a -> SomeType
forall k (f :: k -> *) (a :: k). f a -> Some f
Some D a
arrD)

translateSubscript Expression (Analysis ann)
lhs [F.IxRange {}] =
  Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"range indices"
translateSubscript Expression (Analysis ann)
_ [Index (Analysis ann)]
_ =
  Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"multiple indices"


-- | Translate a source 'F.Value' to a strongly-typed expression. Accepts an
-- 'F.Expression' which is expected to be an 'F.ExpValue' because it needs
-- access to annotations to get unique names, and 'F.Value' doesn't have any
-- annotations of its own.
--
-- Do not call on an expression that you don't know to be an 'F.ExpValue'!
translateValue :: (Monad m, MonadFail m) => F.Expression (F.Analysis ann) -> TranslateT m SomeExpr
translateValue :: Expression (Analysis ann) -> TranslateT m SomeExpr
translateValue Expression (Analysis ann)
e = case Expression (Analysis ann)
e of
  F.ExpValue Analysis ann
_ SrcSpan
_ Value (Analysis ann)
v -> case Value (Analysis ann)
v of
    F.ValInteger FilePath
s -> Value (Analysis ann)
-> Prim 'P64 'BTInt Int64
-> (FilePath -> Maybe Int64)
-> FilePath
-> TranslateT m SomeExpr
forall (m :: * -> *) ann (p :: Precision) (k :: BasicType) a s.
(Monad m, MonadFail m) =>
Value ann
-> Prim p k a -> (s -> Maybe a) -> s -> TranslateT m SomeExpr
translateLiteral Value (Analysis ann)
v Prim 'P64 'BTInt Int64
PInt64 ((Integer -> Int64) -> Maybe Integer -> Maybe Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Maybe Integer -> Maybe Int64)
-> (FilePath -> Maybe Integer) -> FilePath -> Maybe Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Integer
readLitInteger) FilePath
s
    F.ValReal    FilePath
s -> Value (Analysis ann)
-> Prim 'P32 'BTReal Float
-> (FilePath -> Maybe Float)
-> FilePath
-> TranslateT m SomeExpr
forall (m :: * -> *) ann (p :: Precision) (k :: BasicType) a s.
(Monad m, MonadFail m) =>
Value ann
-> Prim p k a -> (s -> Maybe a) -> s -> TranslateT m SomeExpr
translateLiteral Value (Analysis ann)
v Prim 'P32 'BTReal Float
PFloat ((Double -> Float) -> Maybe Double -> Maybe Float
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac (Maybe Double -> Maybe Float)
-> (FilePath -> Maybe Double) -> FilePath -> Maybe Float
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Double
readLitReal) FilePath
s

    -- TODO: Auxiliary variables
    F.ValVariable FilePath
nm -> do
      let uniq :: UniqueName
uniq = FilePath -> UniqueName
UniqueName (Expression (Analysis ann) -> FilePath
forall a. Expression (Analysis a) -> FilePath
F.varName Expression (Analysis ann)
e)
      Maybe SomeVar
theVar <- Getting (Maybe SomeVar) TranslateEnv (Maybe SomeVar)
-> TranslateT m (Maybe SomeVar)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Map UniqueName SomeVar
 -> Const (Maybe SomeVar) (Map UniqueName SomeVar))
-> TranslateEnv -> Const (Maybe SomeVar) TranslateEnv
Lens' TranslateEnv (Map UniqueName SomeVar)
teVarsInScope ((Map UniqueName SomeVar
  -> Const (Maybe SomeVar) (Map UniqueName SomeVar))
 -> TranslateEnv -> Const (Maybe SomeVar) TranslateEnv)
-> ((Maybe SomeVar -> Const (Maybe SomeVar) (Maybe SomeVar))
    -> Map UniqueName SomeVar
    -> Const (Maybe SomeVar) (Map UniqueName SomeVar))
-> Getting (Maybe SomeVar) TranslateEnv (Maybe SomeVar)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (Map UniqueName SomeVar)
-> Lens'
     (Map UniqueName SomeVar) (Maybe (IxValue (Map UniqueName SomeVar)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Index (Map UniqueName SomeVar)
UniqueName
uniq)
      case Maybe SomeVar
theVar of
        Just (Some v' :: FortranVar a
v'@(FortranVar d _)) -> SomeExpr -> TranslateT m SomeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (D a -> FortranExpr a -> SomeExpr
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Some (PairOf f g)
SomePair D a
d (FortranVar a -> FortranExpr a
forall k (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
t a -> HFree h t a
HPure FortranVar a
v'))
        Maybe SomeVar
_                               -> TranslateError -> TranslateT m SomeExpr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> TranslateT m SomeExpr)
-> TranslateError -> TranslateT m SomeExpr
forall a b. (a -> b) -> a -> b
$ FilePath -> TranslateError
ErrVarNotInScope FilePath
nm

    F.ValLogical FilePath
s ->
      let intoBool :: FilePath -> Maybe Bool8
intoBool = (Bool -> Bool8) -> Maybe Bool -> Maybe Bool8
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\Bool
b -> if Bool
b then Int8 -> Bool8
Bool8 Int8
1 else Int8 -> Bool8
Bool8 Int8
0) (Maybe Bool -> Maybe Bool8)
-> (FilePath -> Maybe Bool) -> FilePath -> Maybe Bool8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Bool
readLitBool
      in Value (Analysis ann)
-> Prim 'P8 'BTLogical Bool8
-> (FilePath -> Maybe Bool8)
-> FilePath
-> TranslateT m SomeExpr
forall (m :: * -> *) ann (p :: Precision) (k :: BasicType) a s.
(Monad m, MonadFail m) =>
Value ann
-> Prim p k a -> (s -> Maybe a) -> s -> TranslateT m SomeExpr
translateLiteral Value (Analysis ann)
v Prim 'P8 'BTLogical Bool8
PBool8 FilePath -> Maybe Bool8
intoBool FilePath
s

    F.ValComplex Expression (Analysis ann)
r Expression (Analysis ann)
c  -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"complex literal"
    F.ValString FilePath
s     -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"string literal"
    F.ValHollerith FilePath
s  -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"hollerith literal"
    F.ValIntrinsic FilePath
nm -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported (Text -> TranslateT m SomeExpr) -> Text -> TranslateT m SomeExpr
forall a b. (a -> b) -> a -> b
$ Text
"intrinsic " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. Describe a => a -> Text
describe FilePath
nm
    F.ValOperator FilePath
s   -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"user-defined operator"
    Value (Analysis ann)
F.ValAssignment   -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"interface assignment"
    F.ValType FilePath
s       -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"type value"
    Value (Analysis ann)
F.ValStar         -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"star value"
    Value (Analysis ann)
F.ValColon        -> Text -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"colon value"
  Expression (Analysis ann)
_ -> FilePath -> TranslateT m SomeExpr
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"impossible: translateValue called on a non-value"


translateLiteral
  :: (Monad m, MonadFail m)
  => F.Value ann
  -> Prim p k a -> (s -> Maybe a) -> s
  -> TranslateT m SomeExpr
translateLiteral :: Value ann
-> Prim p k a -> (s -> Maybe a) -> s -> TranslateT m SomeExpr
translateLiteral Value ann
v Prim p k a
pa s -> Maybe a
readLit
  = TranslateT m SomeExpr
-> (a -> TranslateT m SomeExpr) -> Maybe a -> TranslateT m SomeExpr
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (TranslateError -> TranslateT m SomeExpr
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TranslateError
ErrBadLiteral) (SomeExpr -> TranslateT m SomeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeExpr -> TranslateT m SomeExpr)
-> (a -> SomeExpr) -> a -> TranslateT m SomeExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. D (PrimS a) -> HFree CoreOp FortranVar (PrimS a) -> SomeExpr
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Some (PairOf f g)
SomePair (Prim p k a -> D (PrimS a)
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> D (PrimS a)
DPrim Prim p k a
pa) (HFree CoreOp FortranVar (PrimS a) -> SomeExpr)
-> (a -> HFree CoreOp FortranVar (PrimS a)) -> a -> SomeExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prim p k a -> a -> HFree CoreOp FortranVar (PrimS a)
forall (p :: Precision) (k :: BasicType) a (t :: * -> *).
Prim p k a -> a -> HFree CoreOp t (PrimS a)
flit Prim p k a
pa)
  (Maybe a -> TranslateT m SomeExpr)
-> (s -> Maybe a) -> s -> TranslateT m SomeExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. s -> Maybe a
readLit
  where
    flit :: Prim p k a -> a -> HFree CoreOp t (PrimS a)
flit Prim p k a
px a
x = CoreOp (HFree CoreOp t) (PrimS a) -> HFree CoreOp t (PrimS a)
forall k (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
h (HFree h t) a -> HFree h t a
HWrap (Op (Length '[]) 'OKLit
-> OpSpec 'OKLit '[] (PrimS a)
-> Rec (HFree CoreOp t) '[]
-> CoreOp (HFree CoreOp t) (PrimS a)
forall (args :: [*]) (ok :: OpKind) result (t :: * -> *).
Op (Length args) ok
-> OpSpec ok args result -> Rec t args -> CoreOp t result
CoreOp Op 0 'OKLit
Op (Length '[]) 'OKLit
OpLit (Prim p k a -> a -> OpSpec 'OKLit '[] (PrimS a)
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> a -> OpSpec 'OKLit '[] (PrimS a)
OSLit Prim p k a
px a
x) Rec (HFree CoreOp t) '[]
forall u (a :: u -> *). Rec a '[]
RNil)


translateOp1 :: F.UnaryOp -> Maybe (Some (Op 1))
translateOp1 :: UnaryOp -> Maybe (Some (Op 1))
translateOp1 = \case
  UnaryOp
F.Minus -> Some (Op 1) -> Maybe (Some (Op 1))
forall a. a -> Maybe a
Just (Op 1 'OKNum -> Some (Op 1)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 1 'OKNum
OpNeg)
  UnaryOp
F.Plus -> Some (Op 1) -> Maybe (Some (Op 1))
forall a. a -> Maybe a
Just (Op 1 'OKNum -> Some (Op 1)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 1 'OKNum
OpPos)
  UnaryOp
F.Not -> Some (Op 1) -> Maybe (Some (Op 1))
forall a. a -> Maybe a
Just (Op 1 'OKLogical -> Some (Op 1)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 1 'OKLogical
OpNot)
  UnaryOp
_ -> Maybe (Some (Op 1))
forall a. Maybe a
Nothing


translateOp2 :: F.BinaryOp -> Maybe (Some (Op 2))
translateOp2 :: BinaryOp -> Maybe (Some (Op 2))
translateOp2 = \case
  BinaryOp
F.Addition -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKNum -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKNum
OpAdd)
  BinaryOp
F.Subtraction -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKNum -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKNum
OpSub)
  BinaryOp
F.Multiplication -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKNum -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKNum
OpMul)
  BinaryOp
F.Division -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKNum -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKNum
OpDiv)

  BinaryOp
F.LT -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKRel -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKRel
OpLT)
  BinaryOp
F.GT -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKRel -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKRel
OpGT)
  BinaryOp
F.LTE -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKRel -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKRel
OpLE)
  BinaryOp
F.GTE -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKRel -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKRel
OpGE)

  BinaryOp
F.EQ -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKEq -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKEq
OpEq)
  BinaryOp
F.NE -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKEq -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKEq
OpNE)

  BinaryOp
F.And -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKLogical -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKLogical
OpAnd)
  BinaryOp
F.Or -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKLogical -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKLogical
OpOr)
  BinaryOp
F.Equivalent -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKLogical -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKLogical
OpEquiv)
  BinaryOp
F.NotEquivalent -> Some (Op 2) -> Maybe (Some (Op 2))
forall a. a -> Maybe a
Just (Op 2 'OKLogical -> Some (Op 2)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Op 2 'OKLogical
OpNotEquiv)

  BinaryOp
_ -> Maybe (Some (Op 2))
forall a. Maybe a
Nothing


data HasLength n as where
  HasLength :: Length as ~ n => HasLength n as

-- | Given a record of 'Some' functorial types, return 'Some' record over the
-- list of those types.
--
-- In the return value, @'Some' ('PairOf' ('HasLength' n) ('Rec' f))@ is a record over
-- an unknown list of types, with the constraint that the unknown list has
-- length @n@.
recSequenceSome :: Rec (Const (Some f)) xs -> Some (PairOf (HasLength (Length xs)) (Rec f))
recSequenceSome :: Rec (Const (Some f)) xs
-> Some (PairOf (HasLength (Length xs)) (Rec f))
recSequenceSome Rec (Const (Some f)) xs
RNil = HasLength 0 '[] -> Rec f '[] -> Some (PairOf (HasLength 0) (Rec f))
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Some (PairOf f g)
SomePair HasLength 0 '[]
forall (t :: * -> *) a (as :: t a) (n :: Nat).
(Length as ~ n) =>
HasLength n as
HasLength Rec f '[]
forall u (a :: u -> *). Rec a '[]
RNil
recSequenceSome (Const (Some f) r
x :& Rec (Const (Some f)) rs
xs) = case (Const (Some f) r
x, Rec (Const (Some f)) rs
-> Some (PairOf (HasLength (Length rs)) (Rec f))
forall a a (f :: a -> *) (xs :: [a]).
Rec (Const (Some f)) xs
-> Some (PairOf (HasLength (Length xs)) (Rec f))
recSequenceSome Rec (Const (Some f)) rs
xs) of
  (Const (Some f a
y), Some (PairOf HasLength ys)) -> HasLength (1 + LengthSym1 rs) (a : a)
-> Rec f (a : a)
-> Some (PairOf (HasLength (1 + LengthSym1 rs)) (Rec f))
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Some (PairOf f g)
SomePair HasLength (1 + LengthSym1 rs) (a : a)
forall (t :: * -> *) a (as :: t a) (n :: Nat).
(Length as ~ n) =>
HasLength n as
HasLength (f a
y f a -> Rec f a -> Rec f (a : a)
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec f a
ys)


-- This is way too general for its own good but it was fun to write.
translateOpApp
  :: (Monad m, MonadFail m)
  => (Length xs ~ n)
  => Op n ok
  -> Rec (Const (F.Expression (F.Analysis ann))) xs -> TranslateT m SomeExpr
translateOpApp :: Op n ok
-> Rec (Const (Expression (Analysis ann))) xs
-> TranslateT m SomeExpr
translateOpApp Op n ok
operator Rec (Const (Expression (Analysis ann))) xs
argAsts = do
  Some (PairOf (HasLength n) (Rec (PairOf D FortranExpr)))
someArgs <- Rec (Const SomeExpr) xs
-> Some (PairOf (HasLength n) (Rec (PairOf D FortranExpr)))
forall a a (f :: a -> *) (xs :: [a]).
Rec (Const (Some f)) xs
-> Some (PairOf (HasLength (Length xs)) (Rec f))
recSequenceSome (Rec (Const SomeExpr) xs
 -> Some (PairOf (HasLength n) (Rec (PairOf D FortranExpr))))
-> TranslateT m (Rec (Const SomeExpr) xs)
-> TranslateT
     m (Some (PairOf (HasLength n) (Rec (PairOf D FortranExpr))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (x :: u).
 Const (Expression (Analysis ann)) x
 -> TranslateT m (Const SomeExpr x))
-> Rec (Const (Expression (Analysis ann))) xs
-> TranslateT m (Rec (Const SomeExpr) xs)
forall u (h :: * -> *) (f :: u -> *) (g :: u -> *) (rs :: [u]).
Applicative h =>
(forall (x :: u). f x -> h (g x)) -> Rec f rs -> h (Rec g rs)
rtraverse ((SomeExpr -> Const SomeExpr x)
-> TranslateT m SomeExpr -> TranslateT m (Const SomeExpr x)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeExpr -> Const SomeExpr x
forall k a (b :: k). a -> Const a b
Const (TranslateT m SomeExpr -> TranslateT m (Const SomeExpr x))
-> (Const (Expression (Analysis ann)) x -> TranslateT m SomeExpr)
-> Const (Expression (Analysis ann)) x
-> TranslateT m (Const SomeExpr x)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expression (Analysis ann) -> TranslateT m SomeExpr
forall (m :: * -> *) ann.
(Monad m, MonadFail m) =>
Expression (Analysis ann) -> TranslateT m SomeExpr
translateExpression (Expression (Analysis ann) -> TranslateT m SomeExpr)
-> (Const (Expression (Analysis ann)) x
    -> Expression (Analysis ann))
-> Const (Expression (Analysis ann)) x
-> TranslateT m SomeExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Const (Expression (Analysis ann)) x -> Expression (Analysis ann)
forall a k (b :: k). Const a b -> a
getConst) Rec (Const (Expression (Analysis ann))) xs
argAsts

  case Some (PairOf (HasLength n) (Rec (PairOf D FortranExpr)))
someArgs of
    SomePair HasLength n a
HasLength Rec (PairOf D FortranExpr) a
argsTranslated -> do
      let argsD :: Rec D a
argsD = (forall x. PairOf D FortranExpr x -> D x)
-> Rec (PairOf D FortranExpr) a -> Rec D a
forall u (f :: u -> *) (g :: u -> *) (rs :: [u]).
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
VinylRec.rmap (\(PairOf d _) -> D x
d) Rec (PairOf D FortranExpr) a
argsTranslated
          argsExpr :: Rec FortranExpr a
argsExpr = (forall x. PairOf D FortranExpr x -> HFree CoreOp FortranVar x)
-> Rec (PairOf D FortranExpr) a -> Rec FortranExpr a
forall u (f :: u -> *) (g :: u -> *) (rs :: [u]).
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
VinylRec.rmap (\(PairOf _ e) -> HFree CoreOp FortranVar x
e) Rec (PairOf D FortranExpr) a
argsTranslated

      MatchOpSpec OpSpec ok a result
opResult D result
resultD <- case Op (Length a) ok -> Rec D a -> Maybe (MatchOpSpec ok a)
forall (args :: [*]) (ok :: OpKind).
Op (Length args) ok -> Rec D args -> Maybe (MatchOpSpec ok args)
matchOpSpec Op n ok
Op (Length a) ok
operator Rec D a
argsD of
        Just MatchOpSpec ok a
x  -> MatchOpSpec ok a -> TranslateT m (MatchOpSpec ok a)
forall (m :: * -> *) a. Monad m => a -> m a
return MatchOpSpec ok a
x
        Maybe (MatchOpSpec ok a)
Nothing -> TranslateError -> TranslateT m (MatchOpSpec ok a)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TranslateError -> TranslateT m (MatchOpSpec ok a))
-> TranslateError -> TranslateT m (MatchOpSpec ok a)
forall a b. (a -> b) -> a -> b
$ Some (Rec D) -> TranslateError
ErrInvalidOpApplication (Rec D a -> Some (Rec D)
forall k (f :: k -> *) (a :: k). f a -> Some f
Some Rec D a
argsD)

      SomeExpr -> TranslateT m SomeExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeExpr -> TranslateT m SomeExpr)
-> SomeExpr -> TranslateT m SomeExpr
forall a b. (a -> b) -> a -> b
$ D result -> HFree CoreOp FortranVar result -> SomeExpr
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Some (PairOf f g)
SomePair D result
resultD (HFree CoreOp FortranVar result -> SomeExpr)
-> HFree CoreOp FortranVar result -> SomeExpr
forall a b. (a -> b) -> a -> b
$ CoreOp FortranExpr result -> HFree CoreOp FortranVar result
forall k (h :: (k -> *) -> k -> *) (t :: k -> *) (a :: k).
h (HFree h t) a -> HFree h t a
HWrap (CoreOp FortranExpr result -> HFree CoreOp FortranVar result)
-> CoreOp FortranExpr result -> HFree CoreOp FortranVar result
forall a b. (a -> b) -> a -> b
$ Op (Length a) ok
-> OpSpec ok a result
-> Rec FortranExpr a
-> CoreOp FortranExpr result
forall (args :: [*]) (ok :: OpKind) result (t :: * -> *).
Op (Length args) ok
-> OpSpec ok args result -> Rec t args -> CoreOp t result
CoreOp Op n ok
Op (Length a) ok
operator OpSpec ok a result
opResult Rec FortranExpr a
argsExpr


translateOp2App
  :: (Monad m, MonadFail m)
  => F.Expression (F.Analysis ann) -> F.Expression (F.Analysis ann) -> F.BinaryOp
  -> TranslateT m SomeExpr
translateOp2App :: Expression (Analysis ann)
-> Expression (Analysis ann) -> BinaryOp -> TranslateT m SomeExpr
translateOp2App Expression (Analysis ann)
e1 Expression (Analysis ann)
e2 BinaryOp
bop = do
  Some Op 2 a
operator <- case BinaryOp -> Maybe (Some (Op 2))
translateOp2 BinaryOp
bop of
    Just Some (Op 2)
x  -> Some (Op 2) -> TranslateT m (Some (Op 2))
forall (m :: * -> *) a. Monad m => a -> m a
return Some (Op 2)
x
    Maybe (Some (Op 2))
Nothing -> Text -> TranslateT m (Some (Op 2))
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"binary operator"
  Op 2 a
-> Rec (Const (Expression (Analysis ann))) '[Any, Any]
-> TranslateT m SomeExpr
forall u (m :: * -> *) (xs :: [u]) (n :: Nat) (ok :: OpKind) ann.
(Monad m, MonadFail m, Length xs ~ n) =>
Op n ok
-> Rec (Const (Expression (Analysis ann))) xs
-> TranslateT m SomeExpr
translateOpApp Op 2 a
operator (Expression (Analysis ann) -> Const (Expression (Analysis ann)) Any
forall k a (b :: k). a -> Const a b
Const Expression (Analysis ann)
e1 Const (Expression (Analysis ann)) Any
-> Rec (Const (Expression (Analysis ann))) '[Any]
-> Rec (Const (Expression (Analysis ann))) '[Any, Any]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Expression (Analysis ann) -> Const (Expression (Analysis ann)) Any
forall k a (b :: k). a -> Const a b
Const Expression (Analysis ann)
e2 Const (Expression (Analysis ann)) Any
-> Rec (Const (Expression (Analysis ann))) '[]
-> Rec (Const (Expression (Analysis ann))) '[Any]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (Const (Expression (Analysis ann))) '[]
forall u (a :: u -> *). Rec a '[]
RNil)


translateOp1App
  :: (Monad m, MonadFail m)
  => F.Expression (F.Analysis ann) -> F.UnaryOp
  -> TranslateT m SomeExpr
translateOp1App :: Expression (Analysis ann) -> UnaryOp -> TranslateT m SomeExpr
translateOp1App Expression (Analysis ann)
e UnaryOp
uop = do
  Some Op 1 a
operator <- case UnaryOp -> Maybe (Some (Op 1))
translateOp1 UnaryOp
uop of
    Just Some (Op 1)
x  -> Some (Op 1) -> TranslateT m (Some (Op 1))
forall (m :: * -> *) a. Monad m => a -> m a
return Some (Op 1)
x
    Maybe (Some (Op 1))
Nothing -> Text -> TranslateT m (Some (Op 1))
forall (m :: * -> *) a. MonadError TranslateError m => Text -> m a
unsupported Text
"unary operator"
  Op 1 a
-> Rec (Const (Expression (Analysis ann))) '[Any]
-> TranslateT m SomeExpr
forall u (m :: * -> *) (xs :: [u]) (n :: Nat) (ok :: OpKind) ann.
(Monad m, MonadFail m, Length xs ~ n) =>
Op n ok
-> Rec (Const (Expression (Analysis ann))) xs
-> TranslateT m SomeExpr
translateOpApp Op 1 a
operator (Expression (Analysis ann) -> Const (Expression (Analysis ann)) Any
forall k a (b :: k). a -> Const a b
Const Expression (Analysis ann)
e Const (Expression (Analysis ann)) Any
-> Rec (Const (Expression (Analysis ann))) '[]
-> Rec (Const (Expression (Analysis ann))) '[Any]
forall u (a :: u -> *) (r :: u) (rs :: [u]).
a r -> Rec a rs -> Rec a (r : rs)
:& Rec (Const (Expression (Analysis ann))) '[]
forall u (a :: u -> *). Rec a '[]
RNil)

--------------------------------------------------------------------------------
--  Readers for things that are strings in the AST
--------------------------------------------------------------------------------

readLitInteger :: String -> Maybe Integer
readLitInteger :: FilePath -> Maybe Integer
readLitInteger = FilePath -> Maybe Integer
forall a. Read a => FilePath -> Maybe a
readMaybe

readLitReal :: String -> Maybe Double
readLitReal :: FilePath -> Maybe Double
readLitReal = FilePath -> Maybe Double
forall a. Read a => FilePath -> Maybe a
readMaybe

readLitBool :: String -> Maybe Bool
readLitBool :: FilePath -> Maybe Bool
readLitBool FilePath
l = case (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower FilePath
l of
  FilePath
".true."  -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
  FilePath
".false." -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
  FilePath
_         -> Maybe Bool
forall a. Maybe a
Nothing