{-# 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 #-}
{-# LANGUAGE CPP #-}
module Language.Fortran.Model.Translate
(
FortranExpr
, Some(..)
, SomeVar
, SomeExpr
, SomeType
, KindSelector(..)
, FortranSemantics(..)
, defaultSemantics
, TranslateEnv(..)
, defaultTranslateEnv
, TranslateError(..)
, TranslateT(..)
, runTranslateT
, translateExpression
, translateExpression'
, translateCoerceExpression
, TypeInfo
, typeInfo
, translateTypeInfo
, fsIntegerKinds
, fsRealKinds
, fsLogicalKinds
, fsCharacterKinds
, fsDoublePrecisionKinds
, teVarsInScope
, teImplicitVars
, teSemantics
, 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 Data.Map (Map)
import Data.Singletons
import Data.Singletons.Prelude.List (Length)
import Data.Vinyl
import Data.Vinyl.Functor (Const (..))
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
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail hiding (fail)
#endif
type FortranExpr = HFree CoreOp FortranVar
type SomeVar = Some FortranVar
type SomeExpr = Some (PairOf D FortranExpr)
type SomeType = Some D
newtype KindSelector = KindSelector { KindSelector -> Integer -> Maybe Precision
selectKind :: Integer -> Maybe Precision }
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
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
}
data TranslateEnv =
TranslateEnv
{ TranslateEnv -> Bool
_teImplicitVars :: Bool
, TranslateEnv -> Map UniqueName SomeVar
_teVarsInScope :: Map UniqueName SomeVar
, TranslateEnv -> FortranSemantics
_teSemantics :: FortranSemantics
}
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
data TranslateError
= ErrUnsupportedItem Text
| ErrBadLiteral
| ErrUnexpectedType Text SomeType SomeType
| ErrInvalidOpApplication (Some (Rec D))
| ErrVarNotInScope F.Name
| ErrInvalidKind Text Integer
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
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)
, TypeInfo ann -> Maybe (Expression ann)
_tiSelectorKind :: Maybe (F.Expression ann)
, TypeInfo ann -> Maybe (Expression ann)
_tiDeclaratorLength :: Maybe (F.Expression ann)
, TypeInfo ann -> Maybe (AList DimensionDeclarator ann)
_tiDimensionDeclarators :: Maybe (F.AList F.DimensionDeclarator ann)
, TypeInfo ann -> Maybe (AList Attribute ann)
_tiAttributes :: Maybe (F.AList F.Attribute ann)
}
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
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
}
translateTypeInfo
:: (Monad m, MonadFail m, Show ann)
=> TypeInfo ann
-> TranslateT m SomeType
translateTypeInfo :: TypeInfo ann -> TranslateT m SomeType
translateTypeInfo TypeInfo ann
ti = do
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
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
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
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)
-> 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
(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
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"
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"
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"
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)
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
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
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)
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"
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
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
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)
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)
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