{-# LANGUAGE BlockArguments             #-}
{-# LANGUAGE DerivingStrategies         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FunctionalDependencies     #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ImportQualifiedPost        #-}
{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE UndecidableInstances       #-}

-- | This module provides a higher-level API on top of the 
-- "Dovetail.FFI" module. It is not as expressive as the
-- functions in that module, but has the benefit that it is much harder to use
-- this module to construct an FFI which will result in runtime errors, since
-- it attempts to synthesize the types of the Haskell implementations from the
-- types of the declared PureScript foreign imports.
module Dovetail.FFI.Builder
  ( 
  -- * FFI Builder API
    FFIBuilder
  , runFFIBuilder
  , evalFFIBuilder
  , foreignImport
  
  -- * Supported FFI types
  , FunctionType
  , string
  , char
  , boolean
  , number
  , int
  , array
  , (~>)
  , ForAll
  ) where
  
import Control.Monad.Fix (MonadFix)
import Control.Monad.Writer.Class (MonadWriter(..))
import Control.Monad.Writer.Strict (Writer, runWriter)
import Data.Text (Text)
import Data.Vector (Vector)
import Dovetail.Evaluate (EvalT, Value)
import Dovetail.Evaluate qualified as Evaluate
import Dovetail.FFI (FFI(..), ForeignImport(..))
import Dovetail.FFI.Internal qualified as Internal
import Language.PureScript qualified as P

data TypeScheme m a where
  Cons :: (FunctionType m (Value m) (EvalT m (Value m)) -> TypeScheme m a)
       -> TypeScheme m a
  Nil :: FunctionType m a r -> TypeScheme m a
            
data FunctionType m l r where
  Function  :: FunctionType m al ar
            -> FunctionType m bl br 
            -> FunctionType m (al -> br) (al -> br)
  Array    :: FunctionType m l r 
           -> FunctionType m (Vector l) (EvalT m (Vector l))
  MonoType :: MonoType m l -> FunctionType m l (EvalT m l)
  
data MonoType m a where
  String   :: MonoType m Text
  Char     :: MonoType m Char
  Boolean  :: MonoType m Bool
  Number   :: MonoType m Double
  Int      :: MonoType m Integer
  Var      :: P.SourceType -> MonoType m (Value m)
  
-- | This type class exists to facilitate the concise description of
-- PureScript type schemes using the 'foreignImport' function.
-- It is best understood via its examples:
--
-- @
-- foreignImport (Ident "identity") \a -> a ~> a
--   :: MonadFix m 
--   => (Value m -> EvalT m (Value m)) 
--   -> FFIBuilder m ()
--
-- foreignImport (Ident "flip") \a b c -> (a ~> b ~> c) ~> b ~> a ~> c
--   :: MonadFix m 
--   => ((Value m -> Value m -> EvalT m (Value m))
--   ->   Value m -> Value m -> EvalT m (Value m))
--   -> FFIBuilder m ()
-- @
--
-- These Haskell functions applications describe the PureScript type schemes for the 
-- @identity@ and @flip@ functions respectively.
--
-- Notice that the result type of these applications indicates the corresponding
-- Haskell type which must be implemented in order to satisfy the contract of the
-- FFI. Note, these types have been are inferred, which highlights why this 
-- type class is worth its seeming complexity: the goal is to allow the user to
-- express the PureScript type, and have the compiler compute the Haskell type for
-- us. This is about as simple as things can get - we cannot simply specify the
-- Haskell implementation and infer the PureScript type, because there is not a
-- single best PureScript type for every given Haskell type.
class ForAll m r a | a -> m r where
  
  -- | Create a 'TypeScheme' which describes a PureScript type from a Haskell 
  -- function, where type bindings in PureScript types are represented by
  -- function arguments in the Haskell code.
  forAll :: a -> TypeScheme m r
  
instance ForAll m a (FunctionType m a r_) where
  forAll :: FunctionType m a r_ -> TypeScheme m a
forAll = FunctionType m a r_ -> TypeScheme m a
forall (m :: * -> *) a r_. FunctionType m a r_ -> TypeScheme m a
Nil
  
instance (ForAll m r o, a ~ FunctionType m (Value m) (EvalT m (Value m))) => ForAll m r (a -> o) where
  forAll :: (a -> o) -> TypeScheme m r
forAll a -> o
f = (FunctionType m (Value m) (EvalT m (Value m)) -> TypeScheme m r)
-> TypeScheme m r
forall (m :: * -> *) a.
(FunctionType m (Value m) (EvalT m (Value m)) -> TypeScheme m a)
-> TypeScheme m a
Cons (o -> TypeScheme m r
forall (m :: * -> *) r a. ForAll m r a => a -> TypeScheme m r
forAll (o -> TypeScheme m r) -> (a -> o) -> a -> TypeScheme m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> o
f)
  
infixr 0 ~>

-- | Construct a PureScript function type
(~>) :: FunctionType m al ar
      -> FunctionType m bl br 
      -> FunctionType m (al -> br) (al -> br)
~> :: FunctionType m al ar
-> FunctionType m bl br -> FunctionType m (al -> br) (al -> br)
(~>) = FunctionType m al ar
-> FunctionType m bl br -> FunctionType m (al -> br) (al -> br)
forall (m :: * -> *) al ar bl br.
FunctionType m al ar
-> FunctionType m bl br -> FunctionType m (al -> br) (al -> br)
Function
  
-- | The PureScript string type
string  :: FunctionType m Text (EvalT m Text)
string :: FunctionType m Text (EvalT m Text)
string = MonoType m Text -> FunctionType m Text (EvalT m Text)
forall (m :: * -> *) l.
MonoType m l -> FunctionType m l (EvalT m l)
MonoType MonoType m Text
forall (m :: * -> *). MonoType m Text
String
  
-- | The PureScript char type
char  :: FunctionType m Char (EvalT m Char)
char :: FunctionType m Char (EvalT m Char)
char = MonoType m Char -> FunctionType m Char (EvalT m Char)
forall (m :: * -> *) l.
MonoType m l -> FunctionType m l (EvalT m l)
MonoType MonoType m Char
forall (m :: * -> *). MonoType m Char
Char

-- | The PureScript boolean type
boolean :: FunctionType m Bool (EvalT m Bool)
boolean :: FunctionType m Bool (EvalT m Bool)
boolean = MonoType m Bool -> FunctionType m Bool (EvalT m Bool)
forall (m :: * -> *) l.
MonoType m l -> FunctionType m l (EvalT m l)
MonoType MonoType m Bool
forall (m :: * -> *). MonoType m Bool
Boolean

-- | The PureScript number type
number :: FunctionType m Double (EvalT m Double)
number :: FunctionType m Double (EvalT m Double)
number = MonoType m Double -> FunctionType m Double (EvalT m Double)
forall (m :: * -> *) l.
MonoType m l -> FunctionType m l (EvalT m l)
MonoType MonoType m Double
forall (m :: * -> *). MonoType m Double
Number

-- | The PureScript integer type
int :: FunctionType m Integer (EvalT m Integer)
int :: FunctionType m Integer (EvalT m Integer)
int = MonoType m Integer -> FunctionType m Integer (EvalT m Integer)
forall (m :: * -> *) l.
MonoType m l -> FunctionType m l (EvalT m l)
MonoType MonoType m Integer
forall (m :: * -> *). MonoType m Integer
Int
  
-- | Construct a PureScript array type
array :: FunctionType m l r
      -> FunctionType m (Vector l) (EvalT m (Vector l))
array :: FunctionType m l r
-> FunctionType m (Vector l) (EvalT m (Vector l))
array = FunctionType m l r
-> FunctionType m (Vector l) (EvalT m (Vector l))
forall (m :: * -> *) l r.
FunctionType m l r
-> FunctionType m (Vector l) (EvalT m (Vector l))
Array
  
data ForeignImports m = ForeignImports
  { ForeignImports m -> [ForeignImport m]
foreignImports_values :: [ForeignImport m]
  }
  
instance Semigroup (ForeignImports m) where
  ForeignImports m
x <> :: ForeignImports m -> ForeignImports m -> ForeignImports m
<> ForeignImports m
y = ForeignImports :: forall (m :: * -> *). [ForeignImport m] -> ForeignImports m
ForeignImports
    { foreignImports_values :: [ForeignImport m]
foreignImports_values = ForeignImports m -> [ForeignImport m]
forall (m :: * -> *). ForeignImports m -> [ForeignImport m]
foreignImports_values ForeignImports m
x [ForeignImport m] -> [ForeignImport m] -> [ForeignImport m]
forall a. Semigroup a => a -> a -> a
<> ForeignImports m -> [ForeignImport m]
forall (m :: * -> *). ForeignImports m -> [ForeignImport m]
foreignImports_values ForeignImports m
y
    }
  
instance Monoid (ForeignImports m) where
  mempty :: ForeignImports m
mempty = ForeignImports :: forall (m :: * -> *). [ForeignImport m] -> ForeignImports m
ForeignImports 
    { foreignImports_values :: [ForeignImport m]
foreignImports_values = [ForeignImport m]
forall a. Monoid a => a
mempty 
    }
  
-- | A monad for constructing 'FFI' data structures.
--
-- For example:
--
-- @
-- FFI.'evalFFIBuilder' ('P.ModuleName' \"Example\") do
--   FFI.'foreignImport' (P.Ident \"example\")
--     (\a -> a ~> a)
--     pure
-- @
newtype FFIBuilder m a = FFIBuilder { FFIBuilder m a -> Writer (ForeignImports m) a
unFFIBuilder :: Writer (ForeignImports m) a }
  deriving newtype (a -> FFIBuilder m b -> FFIBuilder m a
(a -> b) -> FFIBuilder m a -> FFIBuilder m b
(forall a b. (a -> b) -> FFIBuilder m a -> FFIBuilder m b)
-> (forall a b. a -> FFIBuilder m b -> FFIBuilder m a)
-> Functor (FFIBuilder m)
forall a b. a -> FFIBuilder m b -> FFIBuilder m a
forall a b. (a -> b) -> FFIBuilder m a -> FFIBuilder m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
forall (m :: * -> *) a b. a -> FFIBuilder m b -> FFIBuilder m a
forall (m :: * -> *) a b.
(a -> b) -> FFIBuilder m a -> FFIBuilder m b
<$ :: a -> FFIBuilder m b -> FFIBuilder m a
$c<$ :: forall (m :: * -> *) a b. a -> FFIBuilder m b -> FFIBuilder m a
fmap :: (a -> b) -> FFIBuilder m a -> FFIBuilder m b
$cfmap :: forall (m :: * -> *) a b.
(a -> b) -> FFIBuilder m a -> FFIBuilder m b
Functor, Functor (FFIBuilder m)
a -> FFIBuilder m a
Functor (FFIBuilder m)
-> (forall a. a -> FFIBuilder m a)
-> (forall a b.
    FFIBuilder m (a -> b) -> FFIBuilder m a -> FFIBuilder m b)
-> (forall a b c.
    (a -> b -> c)
    -> FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m c)
-> (forall a b. FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b)
-> (forall a b. FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m a)
-> Applicative (FFIBuilder m)
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m a
FFIBuilder m (a -> b) -> FFIBuilder m a -> FFIBuilder m b
(a -> b -> c) -> FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m c
forall a. a -> FFIBuilder m a
forall a b. FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m a
forall a b. FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
forall a b.
FFIBuilder m (a -> b) -> FFIBuilder m a -> FFIBuilder m b
forall a b c.
(a -> b -> c) -> FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m c
forall (m :: * -> *). Functor (FFIBuilder m)
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
forall (m :: * -> *) a. a -> FFIBuilder m a
forall (m :: * -> *) a b.
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m a
forall (m :: * -> *) a b.
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
forall (m :: * -> *) a b.
FFIBuilder m (a -> b) -> FFIBuilder m a -> FFIBuilder m b
forall (m :: * -> *) a b c.
(a -> b -> c) -> FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m c
<* :: FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m a
$c<* :: forall (m :: * -> *) a b.
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m a
*> :: FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
$c*> :: forall (m :: * -> *) a b.
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
liftA2 :: (a -> b -> c) -> FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m c
$cliftA2 :: forall (m :: * -> *) a b c.
(a -> b -> c) -> FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m c
<*> :: FFIBuilder m (a -> b) -> FFIBuilder m a -> FFIBuilder m b
$c<*> :: forall (m :: * -> *) a b.
FFIBuilder m (a -> b) -> FFIBuilder m a -> FFIBuilder m b
pure :: a -> FFIBuilder m a
$cpure :: forall (m :: * -> *) a. a -> FFIBuilder m a
$cp1Applicative :: forall (m :: * -> *). Functor (FFIBuilder m)
Applicative, Applicative (FFIBuilder m)
a -> FFIBuilder m a
Applicative (FFIBuilder m)
-> (forall a b.
    FFIBuilder m a -> (a -> FFIBuilder m b) -> FFIBuilder m b)
-> (forall a b. FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b)
-> (forall a. a -> FFIBuilder m a)
-> Monad (FFIBuilder m)
FFIBuilder m a -> (a -> FFIBuilder m b) -> FFIBuilder m b
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
forall a. a -> FFIBuilder m a
forall a b. FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
forall a b.
FFIBuilder m a -> (a -> FFIBuilder m b) -> FFIBuilder m b
forall (m :: * -> *). Applicative (FFIBuilder m)
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
forall (m :: * -> *) a. a -> FFIBuilder m a
forall (m :: * -> *) a b.
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
forall (m :: * -> *) a b.
FFIBuilder m a -> (a -> FFIBuilder m b) -> FFIBuilder m b
return :: a -> FFIBuilder m a
$creturn :: forall (m :: * -> *) a. a -> FFIBuilder m a
>> :: FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
$c>> :: forall (m :: * -> *) a b.
FFIBuilder m a -> FFIBuilder m b -> FFIBuilder m b
>>= :: FFIBuilder m a -> (a -> FFIBuilder m b) -> FFIBuilder m b
$c>>= :: forall (m :: * -> *) a b.
FFIBuilder m a -> (a -> FFIBuilder m b) -> FFIBuilder m b
$cp1Monad :: forall (m :: * -> *). Applicative (FFIBuilder m)
Monad, MonadWriter (ForeignImports m)) 
  
-- | Run a computation in the 'FFIBuilder' monad, returning only the constructed
-- 'FFI'.
evalFFIBuilder :: P.ModuleName -> FFIBuilder m a -> FFI m
evalFFIBuilder :: ModuleName -> FFIBuilder m a -> FFI m
evalFFIBuilder ModuleName
mn = (a, FFI m) -> FFI m
forall a b. (a, b) -> b
snd ((a, FFI m) -> FFI m)
-> (FFIBuilder m a -> (a, FFI m)) -> FFIBuilder m a -> FFI m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> FFIBuilder m a -> (a, FFI m)
forall (m :: * -> *) a. ModuleName -> FFIBuilder m a -> (a, FFI m)
runFFIBuilder ModuleName
mn
  
-- | Run a computation in the 'FFIBuilder' monad, returning the result of the
-- computation alongside the constructed 'FFI'.
runFFIBuilder :: P.ModuleName -> FFIBuilder m a -> (a, FFI m)
runFFIBuilder :: ModuleName -> FFIBuilder m a -> (a, FFI m)
runFFIBuilder ModuleName
mn = (ForeignImports m -> FFI m) -> (a, ForeignImports m) -> (a, FFI m)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ForeignImports m -> FFI m
convert ((a, ForeignImports m) -> (a, FFI m))
-> (FFIBuilder m a -> (a, ForeignImports m))
-> FFIBuilder m a
-> (a, FFI m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer (ForeignImports m) a -> (a, ForeignImports m)
forall w a. Writer w a -> (a, w)
runWriter (Writer (ForeignImports m) a -> (a, ForeignImports m))
-> (FFIBuilder m a -> Writer (ForeignImports m) a)
-> FFIBuilder m a
-> (a, ForeignImports m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FFIBuilder m a -> Writer (ForeignImports m) a
forall (m :: * -> *) a.
FFIBuilder m a -> Writer (ForeignImports m) a
unFFIBuilder where
  convert :: ForeignImports m -> FFI m
convert (ForeignImports [ForeignImport m]
values) = FFI :: forall (m :: * -> *). ModuleName -> [ForeignImport m] -> FFI m
FFI
    { ffi_moduleName :: ModuleName
ffi_moduleName = ModuleName
mn
    , ffi_values :: [ForeignImport m]
ffi_values = [ForeignImport m]
values 
    }
  
-- | Define a value which will be implemented in Haskell.
--
-- The first argument gives a name to the value on the PureScript side.
-- 
-- The second argument is a function which describes its PureScript type.
-- See 'ForAll' for an explanation of its purpose.
--
-- The final argument is the Haskell implementation of the value.
--
-- The type checker will ensure that the PureScript and Haskell types are
-- compatible.
foreignImport 
  :: (MonadFix m, Evaluate.ToValue m a, ForAll m a ty)
  => P.Ident
  -> ty
  -> a
  -> FFIBuilder m ()
foreignImport :: Ident -> ty -> a -> FFIBuilder m ()
foreignImport = 
  \Ident
nm ty
ty a
impl -> ForeignImports m -> FFIBuilder m ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (ForeignImports m -> FFIBuilder m ())
-> ForeignImports m -> FFIBuilder m ()
forall a b. (a -> b) -> a -> b
$ ForeignImports :: forall (m :: * -> *). [ForeignImport m] -> ForeignImports m
ForeignImports
    { foreignImports_values :: [ForeignImport m]
foreignImports_values = 
        [ ForeignImport :: forall (m :: * -> *).
Ident -> SourceType -> Value m -> ForeignImport m
ForeignImport
            { fv_name :: Ident
fv_name = Ident
nm
            , fv_type :: SourceType
fv_type = TypeScheme m a -> SourceType
forall (m :: * -> *) a. MonadFix m => TypeScheme m a -> SourceType
typeSchemeToSourceType (ty -> TypeScheme m a
forall (m :: * -> *) r a. ForAll m r a => a -> TypeScheme m r
forAll ty
ty)
            , fv_value :: Value m
fv_value = a -> Value m
forall (m :: * -> *) a. ToValue m a => a -> Value m
Evaluate.toValue a
impl
            }
        ]
    }
    
typeSchemeToSourceType :: MonadFix m => TypeScheme m a -> P.SourceType
typeSchemeToSourceType :: TypeScheme m a -> SourceType
typeSchemeToSourceType (Cons FunctionType m (Value m) (EvalT m (Value m)) -> TypeScheme m a
f) = (SourceType -> SourceType) -> SourceType
Internal.forAll \SourceType
a -> TypeScheme m a -> SourceType
forall (m :: * -> *) a. MonadFix m => TypeScheme m a -> SourceType
typeSchemeToSourceType (FunctionType m (Value m) (EvalT m (Value m)) -> TypeScheme m a
f (MonoType m (Value m)
-> FunctionType m (Value m) (EvalT m (Value m))
forall (m :: * -> *) l.
MonoType m l -> FunctionType m l (EvalT m l)
MonoType (SourceType -> MonoType m (Value m)
forall (m :: * -> *). SourceType -> MonoType m (Value m)
Var SourceType
a)))
typeSchemeToSourceType (Nil FunctionType m a r
t) = FunctionType m a r -> SourceType
forall (m :: * -> *) l r.
MonadFix m =>
FunctionType m l r -> SourceType
functionTypeToSourceType FunctionType m a r
t

functionTypeToSourceType :: MonadFix m => FunctionType m l r -> P.SourceType
functionTypeToSourceType :: FunctionType m l r -> SourceType
functionTypeToSourceType (Function FunctionType m al ar
ty1 FunctionType m bl br
ty2) = 
  SourceType -> SourceType -> SourceType
Internal.function 
    (FunctionType m al ar -> SourceType
forall (m :: * -> *) l r.
MonadFix m =>
FunctionType m l r -> SourceType
functionTypeToSourceType FunctionType m al ar
ty1)
    (FunctionType m bl br -> SourceType
forall (m :: * -> *) l r.
MonadFix m =>
FunctionType m l r -> SourceType
functionTypeToSourceType FunctionType m bl br
ty2)
functionTypeToSourceType (Array FunctionType m l r
ty) =
  SourceType -> SourceType
Internal.array
    (FunctionType m l r -> SourceType
forall (m :: * -> *) l r.
MonadFix m =>
FunctionType m l r -> SourceType
functionTypeToSourceType FunctionType m l r
ty)
functionTypeToSourceType (MonoType MonoType m l
t) = MonoType m l -> SourceType
forall (m :: * -> *) a. MonadFix m => MonoType m a -> SourceType
monoTypeToSourceType MonoType m l
t

monoTypeToSourceType :: MonadFix m => MonoType m a -> P.SourceType
monoTypeToSourceType :: MonoType m a -> SourceType
monoTypeToSourceType MonoType m a
String = SourceType
P.tyString
monoTypeToSourceType MonoType m a
Char = SourceType
P.tyChar
monoTypeToSourceType MonoType m a
Boolean = SourceType
P.tyBoolean
monoTypeToSourceType MonoType m a
Number = SourceType
P.tyNumber
monoTypeToSourceType MonoType m a
Int = SourceType
P.tyInt
monoTypeToSourceType (Var SourceType
a) = SourceType
a