{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE EmptyCase             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE LambdaCase            #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE UndecidableInstances  #-}

{-# OPTIONS_GHC -Wall #-}

{-|
For expressions over normal Fortran values that are not representable in
Fortran.

- Immutable array update ('MopWriteArr')
- Immutable data update ('MopWriteData')
- Explicit coercions ('MopCoercePrim')
-}

module Language.Fortran.Model.Op.Meta (MetaOp(..)) where

import           Data.Functor.Compose

import           Data.Vinyl                          (Rec, RMap, RApply, rmap, (<<*>>))
import           Data.Vinyl.Functor                  (Lift (..))
import           Data.Vinyl.Lens                     (RElem, rput)

import           Data.Singletons.TypeLits

import qualified Data.SBV.Dynamic                    as SBV

import           Language.Expression
import           Language.Expression.Pretty

import           Language.Fortran.Model.Op.Core.Eval
import           Language.Fortran.Model.Op.Eval
import           Language.Fortran.Model.Repr
import           Language.Fortran.Model.Types


data MetaOp t a where
  MopWriteArr
    :: D (Array i v)
    -> t (Array i v)
    -> t i
    -> t v
    -> MetaOp t (Array i v)

  {-|

  In @'MopWriteData' recD fSymb valD recVal valVal@:

  * @recD@ is the type of the record we're writing to.
  * @fSymb@ is the name of the field we're writing to.
  * @valD@ is the type of the value we're writing to.
  * @recVal@ is the original value of the record.
  * @valVal@ is the new value of the field to write to.
  -}
  MopWriteData
    :: RElem '(fname, a) fields i
    => D (Record rname fields)
    -> SSymbol fname
    -> D a
    -> t (Record rname fields)
    -> t a
    -> MetaOp t (Record rname fields)

  MopCoercePrim
    :: Prim p k b
    -> t (PrimS a)
    -> MetaOp t (PrimS b)


instance HFunctor MetaOp where
instance HTraversable MetaOp where
  htraverse :: (forall b. t b -> f (t' b)) -> MetaOp t a -> f (MetaOp t' a)
htraverse forall b. t b -> f (t' b)
f = \case
    MopWriteArr D (Array i v)
d t (Array i v)
x t i
y t v
z -> D (Array i v)
-> t' (Array i v) -> t' i -> t' v -> MetaOp t' (Array i v)
forall i v (t :: * -> *).
D (Array i v)
-> t (Array i v) -> t i -> t v -> MetaOp t (Array i v)
MopWriteArr D (Array i v)
d (t' (Array i v) -> t' i -> t' v -> MetaOp t' (Array i v))
-> f (t' (Array i v)) -> f (t' i -> t' v -> MetaOp t' (Array i v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (Array i v) -> f (t' (Array i v))
forall b. t b -> f (t' b)
f t (Array i v)
x f (t' i -> t' v -> MetaOp t' (Array i v))
-> f (t' i) -> f (t' v -> MetaOp t' (Array i v))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t i -> f (t' i)
forall b. t b -> f (t' b)
f t i
y f (t' v -> MetaOp t' (Array i v))
-> f (t' v) -> f (MetaOp t' (Array i v))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t v -> f (t' v)
forall b. t b -> f (t' b)
f t v
z
    MopWriteData D (Record rname fields)
a SSymbol fname
b D a
c t (Record rname fields)
x t a
y -> D (Record rname fields)
-> SSymbol fname
-> D a
-> t' (Record rname fields)
-> t' a
-> MetaOp t' (Record rname fields)
forall (fname :: Symbol) a (fields :: [(Symbol, *)]) (p :: Nat)
       (k :: Symbol) (t :: * -> *).
RElem '(fname, a) fields p =>
D (Record k fields)
-> SSymbol fname
-> D a
-> t (Record k fields)
-> t a
-> MetaOp t (Record k fields)
MopWriteData D (Record rname fields)
a SSymbol fname
b D a
c (t' (Record rname fields)
 -> t' a -> MetaOp t' (Record rname fields))
-> f (t' (Record rname fields))
-> f (t' a -> MetaOp t' (Record rname fields))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (Record rname fields) -> f (t' (Record rname fields))
forall b. t b -> f (t' b)
f t (Record rname fields)
x f (t' a -> MetaOp t' (Record rname fields))
-> f (t' a) -> f (MetaOp t' (Record rname fields))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t a -> f (t' a)
forall b. t b -> f (t' b)
f t a
y
    MopCoercePrim Prim p k b
p t (PrimS a)
x -> Prim p k b -> t' (PrimS a) -> MetaOp t' (PrimS b)
forall (p :: Precision) (k :: BasicType) b (t :: * -> *) a.
Prim p k b -> t (PrimS a) -> MetaOp t (PrimS b)
MopCoercePrim Prim p k b
p (t' (PrimS a) -> MetaOp t' (PrimS b))
-> f (t' (PrimS a)) -> f (MetaOp t' (PrimS b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (PrimS a) -> f (t' (PrimS a))
forall b. t b -> f (t' b)
f t (PrimS a)
x


instance (MonadEvalFortran r m) => HFoldableAt (Compose m CoreRepr) MetaOp where
  hfoldMap :: (forall b. t b -> Compose m CoreRepr b)
-> MetaOp t a -> Compose m CoreRepr a
hfoldMap = (MetaOp CoreRepr a -> m (CoreRepr a))
-> (forall b. t b -> Compose m CoreRepr b)
-> MetaOp t a
-> Compose m CoreRepr a
forall k1 (h :: (k1 -> *) -> k1 -> *) (m :: * -> *) (k :: k1 -> *)
       (a :: k1) (t :: k1 -> *).
(HTraversable h, Monad m) =>
(h k a -> m (k a))
-> (forall (b :: k1). t b -> Compose m k b)
-> h t a
-> Compose m k a
implHfoldMapCompose ((MetaOp CoreRepr a -> m (CoreRepr a))
 -> (forall b. t b -> Compose m CoreRepr b)
 -> MetaOp t a
 -> Compose m CoreRepr a)
-> (MetaOp CoreRepr a -> m (CoreRepr a))
-> (forall b. t b -> Compose m CoreRepr b)
-> MetaOp t a
-> Compose m CoreRepr a
forall a b. (a -> b) -> a -> b
$ \case
    MopWriteArr D (Array i v)
_ CoreRepr (Array i v)
arr CoreRepr i
ix CoreRepr v
val -> CoreRepr (Array i v) -> m (CoreRepr (Array i v))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreRepr (Array i v) -> m (CoreRepr (Array i v)))
-> CoreRepr (Array i v) -> m (CoreRepr (Array i v))
forall a b. (a -> b) -> a -> b
$ CoreRepr (Array i v)
-> CoreRepr i -> CoreRepr v -> CoreRepr (Array i v)
forall i v.
CoreRepr (Array i v)
-> CoreRepr i -> CoreRepr v -> CoreRepr (Array i v)
writeArray CoreRepr (Array i v)
arr CoreRepr i
ix CoreRepr v
val
    MopWriteData D (Record rname fields)
_ SSymbol fname
fname D a
_ CoreRepr (Record rname fields)
rec CoreRepr a
val -> CoreRepr (Record rname fields)
-> m (CoreRepr (Record rname fields))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CoreRepr (Record rname fields)
 -> m (CoreRepr (Record rname fields)))
-> CoreRepr (Record rname fields)
-> m (CoreRepr (Record rname fields))
forall a b. (a -> b) -> a -> b
$ SSymbol fname
-> CoreRepr (Record rname fields)
-> CoreRepr a
-> CoreRepr (Record rname fields)
forall (fname :: Symbol) a (fields :: [(Symbol, *)]) (i :: Nat)
       (rname :: Symbol).
RElem '(fname, a) fields i =>
SSymbol fname
-> CoreRepr (Record rname fields)
-> CoreRepr a
-> CoreRepr (Record rname fields)
writeDataAt SSymbol fname
fname CoreRepr (Record rname fields)
rec CoreRepr a
val
    MopCoercePrim Prim p k b
p CoreRepr (PrimS a)
x -> Prim p k b -> CoreRepr (PrimS a) -> m (CoreRepr (PrimS b))
forall r (m :: * -> *) (p :: Precision) (k :: BasicType) b a.
MonadEvalFortran r m =>
Prim p k b -> CoreRepr (PrimS a) -> m (CoreRepr (PrimS b))
coercePrim Prim p k b
p CoreRepr (PrimS a)
x


instance (MonadEvalFortran r m) => HFoldableAt (Compose m HighRepr) MetaOp where
  hfoldMap :: (forall b. t b -> Compose m HighRepr b)
-> MetaOp t a -> Compose m HighRepr a
hfoldMap = (MetaOp HighRepr a -> m (HighRepr a))
-> (forall b. t b -> Compose m HighRepr b)
-> MetaOp t a
-> Compose m HighRepr a
forall k1 (h :: (k1 -> *) -> k1 -> *) (m :: * -> *) (k :: k1 -> *)
       (a :: k1) (t :: k1 -> *).
(HTraversable h, Monad m) =>
(h k a -> m (k a))
-> (forall (b :: k1). t b -> Compose m k b)
-> h t a
-> Compose m k a
implHfoldMapCompose ((MetaOp HighRepr a -> m (HighRepr a))
 -> (forall b. t b -> Compose m HighRepr b)
 -> MetaOp t a
 -> Compose m HighRepr a)
-> (MetaOp HighRepr a -> m (HighRepr a))
-> (forall b. t b -> Compose m HighRepr b)
-> MetaOp t a
-> Compose m HighRepr a
forall a b. (a -> b) -> a -> b
$ (CoreRepr a -> HighRepr a) -> m (CoreRepr a) -> m (HighRepr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CoreRepr a -> HighRepr a
forall a. CoreRepr a -> HighRepr a
HRCore (m (CoreRepr a) -> m (HighRepr a))
-> (MetaOp HighRepr a -> m (CoreRepr a))
-> MetaOp HighRepr a
-> m (HighRepr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaOp CoreRepr a -> m (CoreRepr a)
forall k (f :: * -> *) (t :: k -> *) (h :: (k -> *) -> k -> *)
       (a :: k).
(HFoldableAt (Compose f t) h, Applicative f) =>
h t a -> f (t a)
hfoldA (MetaOp CoreRepr a -> m (CoreRepr a))
-> (MetaOp HighRepr a -> MetaOp CoreRepr a)
-> MetaOp HighRepr a
-> m (CoreRepr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (forall b. HighRepr b -> CoreRepr b)
-> MetaOp HighRepr a -> MetaOp CoreRepr a
forall u (h :: (u -> *) -> u -> *) (t :: u -> *) (t' :: u -> *)
       (a :: u).
HFunctor h =>
(forall (b :: u). t b -> t' b) -> h t a -> h t' a
hmap (\case HRCore x -> CoreRepr b
x
                HRHigh _ -> [Char] -> CoreRepr b
forall a. HasCallStack => [Char] -> a
error [Char]
"impossible")


instance Pretty2 MetaOp where
  prettys2Prec :: Int -> MetaOp t a -> ShowS
prettys2Prec Int
p = \case
    MopWriteArr D (Array i v)
_ t (Array i v)
arr t i
i t v
v ->
      -- e.g. @myArrayVar[9 <- "new value"]@
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> t (Array i v) -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
10 t (Array i v)
arr ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          [Char] -> ShowS
showString [Char]
"[" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> t i -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
0 t i
i ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          [Char] -> ShowS
showString [Char]
" <- " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> t v -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
0 t v
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                          [Char] -> ShowS
showString [Char]
"]"
    MopWriteData D (Record rname fields)
_ SSymbol fname
fname D a
_ t (Record rname fields)
r t a
v ->
      Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
9) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> t (Record rname fields) -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
10 t (Record rname fields)
r ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [Char] -> ShowS
showString [Char]
"{" ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [Char] -> ShowS
showString (Sing fname -> (KnownSymbol fname => [Char]) -> [Char]
forall (n :: Symbol) r. Sing n -> (KnownSymbol n => r) -> r
withKnownSymbol Sing fname
SSymbol fname
fname (SSymbol fname -> [Char]
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> [Char]
symbolVal SSymbol fname
fname)) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [Char] -> ShowS
showString [Char]
" <- " ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Int -> t a -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
0 t a
v ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      [Char] -> ShowS
showString [Char]
"}"

    -- TODO: Consider adding visual evidence of coercion
    MopCoercePrim Prim p k b
_ t (PrimS a)
x -> Int -> t (PrimS a) -> ShowS
forall k (t :: k -> *) (a :: k). Pretty1 t => Int -> t a -> ShowS
prettys1Prec Int
p t (PrimS a)
x


--------------------------------------------------------------------------------
--  Write array
--------------------------------------------------------------------------------

rzip3With
  :: (RMap xs, RApply xs)
  => (forall x. f x -> g x -> h x -> i x)
  -> Rec f xs
  -> Rec g xs
  -> Rec h xs
  -> Rec i xs
rzip3With :: (forall (x :: u). f x -> g x -> h x -> i x)
-> Rec f xs -> Rec g xs -> Rec h xs -> Rec i xs
rzip3With forall (x :: u). f x -> g x -> h x -> i x
f Rec f xs
x Rec g xs
y Rec h xs
z = (forall (x :: u). f x -> Lift (->) g (Lift (->) h i) x)
-> Rec f xs -> Rec (Lift (->) g (Lift (->) h i)) xs
forall u (rs :: [u]) (f :: u -> *) (g :: u -> *).
RMap rs =>
(forall (x :: u). f x -> g x) -> Rec f rs -> Rec g rs
rmap ((g x -> Lift (->) h i x) -> Lift (->) g (Lift (->) h i) x
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
       (x :: k).
op (f x) (g x) -> Lift op f g x
Lift ((g x -> Lift (->) h i x) -> Lift (->) g (Lift (->) h i) x)
-> (f x -> g x -> Lift (->) h i x)
-> f x
-> Lift (->) g (Lift (->) h i) x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((h x -> i x) -> Lift (->) h i x
forall l l' k (op :: l -> l' -> *) (f :: k -> l) (g :: k -> l')
       (x :: k).
op (f x) (g x) -> Lift op f g x
Lift ((h x -> i x) -> Lift (->) h i x)
-> (g x -> h x -> i x) -> g x -> Lift (->) h i x
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((g x -> h x -> i x) -> g x -> Lift (->) h i x)
-> (f x -> g x -> h x -> i x) -> f x -> g x -> Lift (->) h i x
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f x -> g x -> h x -> i x
forall (x :: u). f x -> g x -> h x -> i x
f) Rec f xs
x Rec (Lift (->) g (Lift (->) h i)) xs
-> Rec g xs -> Rec (Lift (->) h i) xs
forall u (rs :: [u]) (f :: u -> *) (g :: u -> *).
RApply rs =>
Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs
<<*>> Rec g xs
y Rec (Lift (->) h i) xs -> Rec h xs -> Rec i xs
forall u (rs :: [u]) (f :: u -> *) (g :: u -> *).
RApply rs =>
Rec (Lift (->) f g) rs -> Rec f rs -> Rec g rs
<<*>> Rec h xs
z

writeArray' :: CoreRepr i -> D (Array i v) -> ArrRepr i v -> CoreRepr v -> ArrRepr i v
writeArray' :: CoreRepr i
-> D (Array i v) -> ArrRepr i v -> CoreRepr v -> ArrRepr i v
writeArray' CoreRepr i
ixRep (DArray ixIndex :: Index i
ixIndex@(Index Prim p 'BTInt a
_) ArrValue a
valAV) ArrRepr i v
arrRep CoreRepr v
valRep =
  case CoreRepr i
ixRep of
    CRPrim D (PrimS a)
_ SVal
ixVal -> case (ArrValue a
valAV, ArrRepr i v
arrRep, CoreRepr v
valRep) of
      (ArrPrim Prim p k a
_, ARPrim SArr
arr, CRPrim D (PrimS a)
_ SVal
valVal) -> SArr -> ArrRepr i (PrimS a)
forall k (i :: k) a. SArr -> ArrRepr i (PrimS a)
ARPrim (SArr -> SVal -> SVal -> SArr
SBV.writeSArr SArr
arr SVal
ixVal SVal
valVal)
      (ArrData SSymbol name
_ Rec (Field ArrValue) fs
fieldsAV, ARData Rec (Field (ArrRepr i)) fs
fieldsAR, CRData D (Record name fs)
_ Rec (Field CoreRepr) fs
fieldsRep) ->
        Rec (Field (ArrRepr i)) fs -> ArrRepr i (Record name fs)
forall k (i :: k) (fs :: [(Symbol, *)]) (name :: Symbol).
Rec (Field (ArrRepr i)) fs -> ArrRepr i (Record name fs)
ARData ((forall (x :: (Symbol, *)).
 Field ArrValue x
 -> Field (ArrRepr i) x -> Field CoreRepr x -> Field (ArrRepr i) x)
-> Rec (Field ArrValue) fs
-> Rec (Field (ArrRepr i)) fs
-> Rec (Field CoreRepr) fs
-> Rec (Field (ArrRepr i)) fs
forall u (xs :: [u]) (f :: u -> *) (g :: u -> *) (h :: u -> *)
       (i :: u -> *).
(RMap xs, RApply xs) =>
(forall (x :: u). f x -> g x -> h x -> i x)
-> Rec f xs -> Rec g xs -> Rec h xs -> Rec i xs
rzip3With ((forall a.
 ArrValue a
 -> ArrRepr (PrimS a) a -> CoreRepr a -> ArrRepr (PrimS a) a)
-> Field ArrValue x
-> Field (ArrRepr (PrimS a)) x
-> Field CoreRepr x
-> Field (ArrRepr (PrimS a)) x
forall k (f :: k -> *) (g :: k -> *) (h :: k -> *) (i :: k -> *)
       (nv :: (Symbol, k)).
(forall (a :: k). f a -> g a -> h a -> i a)
-> Field f nv -> Field g nv -> Field h nv -> Field i nv
zip3FieldsWith (CoreRepr i
-> D (Array i a) -> ArrRepr i a -> CoreRepr a -> ArrRepr i a
forall i v.
CoreRepr i
-> D (Array i v) -> ArrRepr i v -> CoreRepr v -> ArrRepr i v
writeArray' CoreRepr i
ixRep (D (Array i a) -> ArrRepr i a -> CoreRepr a -> ArrRepr i a)
-> (ArrValue a -> D (Array i a))
-> ArrValue a
-> ArrRepr i a
-> CoreRepr a
-> ArrRepr i a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index i -> ArrValue a -> D (Array i a)
forall i a. Index i -> ArrValue a -> D (Array i a)
DArray Index i
ixIndex))
                Rec (Field ArrValue) fs
fieldsAV
                Rec (Field (ArrRepr i)) fs
Rec (Field (ArrRepr i)) fs
fieldsAR
                Rec (Field CoreRepr) fs
Rec (Field CoreRepr) fs
fieldsRep)


writeArray :: CoreRepr (Array i v) -> CoreRepr i -> CoreRepr v -> CoreRepr (Array i v)
writeArray :: CoreRepr (Array i v)
-> CoreRepr i -> CoreRepr v -> CoreRepr (Array i v)
writeArray (CRArray D (Array i a)
arrD ArrRepr i a
arrRep) CoreRepr i
ixRep CoreRepr v
valRep =
  D (Array i a) -> ArrRepr i a -> CoreRepr (Array i a)
forall k (i :: k) a.
D (Array i a) -> ArrRepr i a -> CoreRepr (Array i a)
CRArray D (Array i a)
arrD (CoreRepr i
-> D (Array i a) -> ArrRepr i a -> CoreRepr a -> ArrRepr i a
forall i v.
CoreRepr i
-> D (Array i v) -> ArrRepr i v -> CoreRepr v -> ArrRepr i v
writeArray' CoreRepr i
ixRep D (Array i a)
D (Array i a)
arrD ArrRepr i a
ArrRepr i a
arrRep CoreRepr v
CoreRepr a
valRep)

--------------------------------------------------------------------------------
--  Write Data
--------------------------------------------------------------------------------

writeDataAt
  :: RElem '(fname, a) fields i
  => SSymbol fname
  -> CoreRepr (Record rname fields)
  -> CoreRepr a
  -> CoreRepr (Record rname fields)
writeDataAt :: SSymbol fname
-> CoreRepr (Record rname fields)
-> CoreRepr a
-> CoreRepr (Record rname fields)
writeDataAt SSymbol fname
fieldSymbol (CRData D (Record name fs)
d Rec (Field CoreRepr) fs
dataRec) CoreRepr a
valRep =
  D (Record name fs)
-> Rec (Field CoreRepr) fs -> CoreRepr (Record name fs)
forall (name :: Symbol) (fs :: [(Symbol, *)]).
D (Record name fs)
-> Rec (Field CoreRepr) fs -> CoreRepr (Record name fs)
CRData D (Record name fs)
d (Rec (Field CoreRepr) fs -> CoreRepr (Record name fs))
-> Rec (Field CoreRepr) fs -> CoreRepr (Record name fs)
forall a b. (a -> b) -> a -> b
$ Field CoreRepr '(fname, a)
-> Rec (Field CoreRepr) fs -> Rec (Field CoreRepr) fs
forall k (r :: k) (rs :: [k]) (record :: (k -> *) -> [k] -> *)
       (f :: k -> *).
(RecElem record r r rs rs (RIndex r rs), RecElemFCtx record f) =>
f r -> record f rs -> record f rs
rput (SSymbol fname -> CoreRepr a -> Field CoreRepr '(fname, a)
forall k (name :: Symbol) (f :: k -> *) (a :: k).
SSymbol name -> f a -> Field f '(name, a)
Field SSymbol fname
fieldSymbol CoreRepr a
valRep) Rec (Field CoreRepr) fs
dataRec

--------------------------------------------------------------------------------
--  Coerce primitives
--------------------------------------------------------------------------------

coercePrim
  :: (MonadEvalFortran r m)
  => Prim p k b
  -> CoreRepr (PrimS a)
  -> m (CoreRepr (PrimS b))
coercePrim :: Prim p k b -> CoreRepr (PrimS a) -> m (CoreRepr (PrimS b))
coercePrim Prim p k b
prim2 (CRPrim D (PrimS a)
_ SVal
v) = D (PrimS b) -> SVal -> CoreRepr (PrimS b)
forall a. D (PrimS a) -> SVal -> CoreRepr (PrimS a)
CRPrim (Prim p k b -> D (PrimS b)
forall (p :: Precision) (k :: BasicType) a.
Prim p k a -> D (PrimS a)
DPrim Prim p k b
prim2) (SVal -> CoreRepr (PrimS b)) -> m SVal -> m (CoreRepr (PrimS b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Prim p k b -> SVal -> m SVal
forall r (m :: * -> *) (p :: Precision) (k :: BasicType) a.
MonadEvalFortran r m =>
Prim p k a -> SVal -> m SVal
coercePrimSVal Prim p k b
prim2 SVal
v