{-# LANGUAGE MonoLocalBinds         #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# OPTIONS_GHC -Wall #-}

module Language.Fortran.Model.Op.Eval where

import           Control.Monad.Reader.Class       (MonadReader (..))

import           Data.SBV                         (SDouble, SFloat, SReal, sRTZ)
import qualified Data.SBV                         as SBV
import           Data.SBV.Dynamic                 (SVal)
import qualified Data.SBV.Dynamic                 as SBV
import           Data.SBV.Internals               (SBV (..))

import           Language.Fortran.Model.Repr.Prim
import           Language.Fortran.Model.Types

--------------------------------------------------------------------------------
--  Monad
--------------------------------------------------------------------------------

class (MonadReader r m, HasPrimReprHandlers r) => MonadEvalFortran r m | m -> r where
instance (MonadReader r m, HasPrimReprHandlers r) => MonadEvalFortran r m where

--------------------------------------------------------------------------------
--  SBV Kinds
--------------------------------------------------------------------------------

coerceBy :: (SBV a -> SBV b) -> SVal -> SVal
coerceBy :: (SBV a -> SBV b) -> SVal -> SVal
coerceBy SBV a -> SBV b
f SVal
x = SBV b -> SVal
forall a. SBV a -> SVal
unSBV (SBV a -> SBV b
f (SVal -> SBV a
forall a. SVal -> SBV a
SBV SVal
x))

coerceSBVKinds :: SBV.Kind -> SBV.Kind -> (SVal -> SVal)
coerceSBVKinds :: Kind -> Kind -> SVal -> SVal
coerceSBVKinds Kind
SBV.KReal   Kind
SBV.KReal = SVal -> SVal
forall a. a -> a
id
coerceSBVKinds Kind
SBV.KFloat  Kind
SBV.KReal = (SBV Float -> SBV AlgReal) -> SVal -> SVal
forall a b. (SBV a -> SBV b) -> SVal -> SVal
coerceBy (SRoundingMode -> SBV Float -> SBV AlgReal
forall a.
IEEEFloatConvertible a =>
SRoundingMode -> SBV Float -> SBV a
SBV.fromSFloat SRoundingMode
sRTZ :: SFloat -> SReal)
coerceSBVKinds Kind
SBV.KDouble Kind
SBV.KReal = (SBV Double -> SBV AlgReal) -> SVal -> SVal
forall a b. (SBV a -> SBV b) -> SVal -> SVal
coerceBy (SRoundingMode -> SBV Double -> SBV AlgReal
forall a.
IEEEFloatConvertible a =>
SRoundingMode -> SBV Double -> SBV a
SBV.fromSDouble SRoundingMode
sRTZ :: SDouble -> SReal)
coerceSBVKinds Kind
_        k2 :: Kind
k2@Kind
SBV.KReal = Kind -> SVal -> SVal
SBV.svFromIntegral Kind
k2

coerceSBVKinds Kind
SBV.KReal   Kind
SBV.KDouble = (SBV AlgReal -> SBV Double) -> SVal -> SVal
forall a b. (SBV a -> SBV b) -> SVal -> SVal
coerceBy (SRoundingMode -> SBV AlgReal -> SBV Double
forall a.
IEEEFloatConvertible a =>
SRoundingMode -> SBV a -> SBV Double
SBV.toSDouble SRoundingMode
sRTZ :: SReal -> SDouble)
coerceSBVKinds Kind
SBV.KDouble Kind
SBV.KDouble = SVal -> SVal
forall a. a -> a
id
coerceSBVKinds Kind
SBV.KFloat  Kind
SBV.KDouble = (SBV Float -> SBV Double) -> SVal -> SVal
forall a b. (SBV a -> SBV b) -> SVal -> SVal
coerceBy (SRoundingMode -> SBV Float -> SBV Double
forall a.
IEEEFloatConvertible a =>
SRoundingMode -> SBV a -> SBV Double
SBV.toSDouble SRoundingMode
sRTZ :: SFloat -> SDouble)
coerceSBVKinds Kind
_        k2 :: Kind
k2@Kind
SBV.KDouble = Kind -> SVal -> SVal
SBV.svFromIntegral Kind
k2

coerceSBVKinds Kind
SBV.KReal   Kind
SBV.KFloat = (SBV AlgReal -> SBV Float) -> SVal -> SVal
forall a b. (SBV a -> SBV b) -> SVal -> SVal
coerceBy (SRoundingMode -> SBV AlgReal -> SBV Float
forall a.
IEEEFloatConvertible a =>
SRoundingMode -> SBV a -> SBV Float
SBV.toSFloat SRoundingMode
sRTZ :: SReal -> SFloat)
coerceSBVKinds Kind
SBV.KDouble Kind
SBV.KFloat = (SBV Double -> SBV Float) -> SVal -> SVal
forall a b. (SBV a -> SBV b) -> SVal -> SVal
coerceBy (SRoundingMode -> SBV Double -> SBV Float
forall a.
IEEEFloatConvertible a =>
SRoundingMode -> SBV a -> SBV Float
SBV.toSFloat SRoundingMode
sRTZ :: SDouble -> SFloat)
coerceSBVKinds Kind
SBV.KFloat  Kind
SBV.KFloat = SVal -> SVal
forall a. a -> a
id
coerceSBVKinds Kind
_        k2 :: Kind
k2@Kind
SBV.KFloat = Kind -> SVal -> SVal
SBV.svFromIntegral Kind
k2

coerceSBVKinds Kind
_ Kind
k2 = Kind -> SVal -> SVal
SBV.svFromIntegral Kind
k2

coercePrimSVal :: (MonadEvalFortran r m) => Prim p k a -> SVal -> m SVal
coercePrimSVal :: Prim p k a -> SVal -> m SVal
coercePrimSVal Prim p k a
p SVal
v = do
  Kind
k2 <- Prim p k a -> m Kind
forall r (m :: * -> *) (p :: Precision) (k :: BasicType) a.
(MonadReader r m, HasPrimReprHandlers r) =>
Prim p k a -> m Kind
primSBVKind Prim p k a
p
  let k1 :: Kind
k1 = SVal -> Kind
forall a. HasKind a => a -> Kind
SBV.kindOf SVal
v
  SVal -> m SVal
forall (m :: * -> *) a. Monad m => a -> m a
return (SVal -> m SVal) -> SVal -> m SVal
forall a b. (a -> b) -> a -> b
$ Kind -> Kind -> SVal -> SVal
coerceSBVKinds Kind
k1 Kind
k2 SVal
v