dovetail (empty) → 0.1.0.0
raw patch · 12 files changed
+2199/−0 lines, 12 filesdep +QuickCheckdep +ansi-terminaldep +base
Dependencies added: QuickCheck, ansi-terminal, base, containers, directory, dovetail, exceptions, filepath, generic-arbitrary, haskeline, hspec, hspec-golden, mtl, purescript, purescript-cst, quickcheck-instances, semialign, text, these, transformers, unordered-containers, vector
Files
- LICENSE +30/−0
- dovetail.cabal +81/−0
- src/Dovetail.hs +235/−0
- src/Dovetail/Build.hs +153/−0
- src/Dovetail/Evaluate.hs +517/−0
- src/Dovetail/FFI.hs +76/−0
- src/Dovetail/FFI/Builder.hs +235/−0
- src/Dovetail/FFI/Internal.hs +36/−0
- src/Dovetail/Prelude.hs +199/−0
- src/Dovetail/REPL.hs +99/−0
- src/Dovetail/Types.hs +328/−0
- test/Spec.hs +210/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Phil Freeman (c) 2021++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Author name here nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ dovetail.cabal view
@@ -0,0 +1,81 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 8e19e51ff69a860795e7b3909da11ef1e97bfc1266ab5075a42721d37c2f5f23++name: dovetail+version: 0.1.0.0+synopsis: A PureScript interpreter with a Haskell FFI.+description: Dovetail is a general-purpose PureScript corefn interpreter with an FFI to Haskell. Please see the README on GitHub at <https://github.com/paf31/dovetail#readme>, or check out the examples directory, to learn how to use the library.+category: Language+homepage: https://github.com/paf31/dovetail#readme+bug-reports: https://github.com/paf31/dovetail/issues+author: Phil Freeman+maintainer: freeman.phil@gmail.com+copyright: 2021 Phil Freeman+license: BSD3+license-file: LICENSE+build-type: Simple++source-repository head+ type: git+ location: https://github.com/paf31/dovetail++library+ exposed-modules:+ Dovetail+ Dovetail.Build+ Dovetail.Evaluate+ Dovetail.FFI+ Dovetail.FFI.Builder+ Dovetail.FFI.Internal+ Dovetail.Prelude+ Dovetail.REPL+ Dovetail.Types+ other-modules:+ Paths_dovetail+ hs-source-dirs:+ src+ ghc-options: -Wall -fwarn-unused-imports+ build-depends:+ ansi-terminal+ , base >=4.7 && <5+ , containers+ , exceptions+ , haskeline+ , mtl+ , purescript+ , purescript-cst+ , semialign+ , text+ , these+ , transformers+ , unordered-containers+ , vector+ default-language: Haskell2010++test-suite dovetail-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Paths_dovetail+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -fwarn-unused-imports+ build-depends:+ QuickCheck+ , base >=4.7 && <5+ , directory+ , dovetail+ , filepath+ , generic-arbitrary+ , hspec+ , hspec-golden+ , purescript+ , quickcheck-instances+ , text+ , vector+ default-language: Haskell2010
+ src/Dovetail.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Dovetail+ ( module Dovetail.Types+ , module Dovetail.FFI+ , module Dovetail.FFI.Builder+ + -- * High-level API+ , InterpretT+ , runInterpretT+ , runInterpret+ , liftEvalT+ + -- ** Debugging+ , runInterpretTWithDebugger+ + -- ** Error messages+ , InterpretError(..)+ , renderInterpretError+ + -- ** Foreign function interface+ , ffi+ + -- ** Building PureScript source+ , build+ , buildCoreFn+ , module Dovetail.Build+ + -- ** Evaluating expressions+ , eval+ , evalCoreFn+ , evalMain+ , module Dovetail.Evaluate+ + -- ** REPL+ , repl+ + -- * Re-exports+ , module Language.PureScript.CoreFn+ , module Language.PureScript.Names+ ) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)+import Control.Monad.Trans.State (StateT, evalStateT, get, put, modify, runStateT)+import Data.Bifunctor (first)+import Data.Functor.Identity (Identity(..))+import Data.Map qualified as Map+import Data.Text (Text)+import Dovetail.Build (BuildError(..), renderBuildError)+import Dovetail.Build qualified as Build+import Dovetail.Evaluate (Env, EvalT(..), runEvalT, Eval, runEval, + ToValue(..), ToValueRHS(..))+import Dovetail.Evaluate qualified as Evaluate+import Dovetail.FFI+import Dovetail.FFI qualified as FFI+import Dovetail.FFI.Builder+import Dovetail.REPL qualified as REPL+import Dovetail.Types +import Language.PureScript qualified as P+import Language.PureScript.CoreFn (Ann, Expr, Module)+import Language.PureScript.CoreFn qualified as CoreFn+import Language.PureScript.Names++-- | A monad transformer for high-level tasks involving PureScript code, including separate +-- compilation. Its job is to keep track of available modules, any foreign imports+-- from Haskell code, and run PureScript code.+--+-- Note: do not confuse this monad transformer with 'EvalT', which is only+-- responsible for powering evaluation of PureScript expressions.+--+-- The transformed monad is used to track any benign side effects that might be+-- exposed via the foreign function interface to PureScript code, in the same sense+-- as 'EvalT'.+newtype InterpretT m a = InterpretT { unInterpretT :: ExceptT (InterpretError m) (StateT ([P.ExternsFile], Env m) m) a }+ deriving newtype (Functor, Applicative, Monad, MonadError (InterpretError m))+ +instance MonadTrans InterpretT where+ lift = InterpretT . lift . lift++-- | Run a computation in the 'InterpretT' monad, possibly returning an error.+-- Note: errors can occur during module building or evaluation (i.e. module loading).+--+-- The 'runInterpret' function is a simpler alternative in the case where benign+-- side-effects are not needed.+--+-- For example:+--+-- @+-- runInterpret @Module do+-- -- Load the prelude+-- 'ffi' 'prelude'+-- -- Build a module from source+-- 'build' "module Main where main = \\\"example\\\"" --+--+-- runInterpret @(Eval Text) do+-- 'ffi' 'prelude'+-- _ <- 'build' "module Main where main = \\\"example\\\""+-- -- Evaluate the main function+-- 'evalMain' ('P.ModuleName' \"Main\")+-- @+runInterpretT :: Monad m => InterpretT m a -> m (Either (InterpretError m) a)+runInterpretT = flip evalStateT ([], mempty) . runExceptT . unInterpretT++-- | Like 'runInterpretT', but starts an interactive debugging session in the+-- event of a debugging error.+runInterpretTWithDebugger + :: (MonadIO m, MonadFix m, MonadMask m)+ => InterpretT m a+ -> m ()+runInterpretTWithDebugger x = do+ (e, (externs, env)) <- flip runStateT ([], mempty) $ runExceptT (unInterpretT x)+ case e of+ Left err -> do+ liftIO . putStrLn $ renderInterpretError defaultTerminalRenderValueOptions err+ case err of+ ErrorDuringEvaluation evalErr -> do+ liftIO . putStrLn $ "\nStarting the debugger. ^C to exit."+ let withEnvAtError =+ case errorContext evalErr of+ EvaluationContext (frame : _) ->+ (frameEnv frame <> env)+ _ -> env+ additionalNames = + [ P.disqualify ident+ | ident <- Map.keys (withEnvAtError Map.\\ env)+ , not (P.isQualified ident)+ ]+ REPL.defaultMain Nothing externs additionalNames withEnvAtError+ _ -> pure ()+ Right{} -> pure ()++type Interpret = InterpretT Identity++runInterpret :: Interpret a -> Either (InterpretError Identity) a+runInterpret = runIdentity . runInterpretT++-- | A convenience function for running 'EvalT' computations in 'InterpretT',+-- reporting errors via 'InterpretError'.+liftEvalT :: Monad m => EvalT m a -> InterpretT m a+liftEvalT = (>>= either (throwError . ErrorDuringEvaluation) pure) . lift . runEvalT++-- | Make an 'FFI' module available for use to subsequent operations.+--+-- For example, to make the 'Dovetail.Prelude.prelude' available:+--+-- @+-- ffi 'Dovetail.Prelude.prelude'+-- @+ffi :: Monad m => FFI m -> InterpretT m ()+ffi f = InterpretT . lift $ modify \(externs, env) -> + ( FFI.toExterns f : externs+ , env <> FFI.toEnv f+ )++-- | The type of errors that can occur in the 'InterpretT' monad.+data InterpretError m+ = ErrorDuringEvaluation (Evaluate.EvaluationError m)+ -- ^ Evaluation errors can occur during the initial evaluation of the module+ -- when it is loaded into the environment.+ | ErrorDuringBuild Build.BuildError+ -- ^ Build errors can occur if we are building modules from source or corefn.++renderInterpretError :: RenderValueOptions -> InterpretError m -> String+renderInterpretError _ (ErrorDuringBuild err) =+ "Build error: " <> Build.renderBuildError err+renderInterpretError opts (ErrorDuringEvaluation err) =+ "Evaluation error: " <> Evaluate.renderEvaluationError opts err++liftWith :: Monad m => (e -> InterpretError m) -> m (Either e a) -> InterpretT m a+liftWith f ma = InterpretT . ExceptT . lift $ fmap (first f) ma++-- | Build a PureScript module from source, and make its exported functions available+-- during subsequent evaluations.+build :: MonadFix m => Text -> InterpretT m (CoreFn.Module CoreFn.Ann)+build moduleText = do+ (externs, _) <- InterpretT (lift get)+ (m, newExterns) <- liftWith ErrorDuringBuild $ pure $ Build.buildSingleModule externs moduleText+ buildCoreFn newExterns m++-- | Build a PureScript module from corefn, and make its exported functions available+-- during subsequent evaluations.+--+-- The corefn module may be preprepared, for example by compiling from source text using the+-- functions in the "Dovetail.Build" module.+buildCoreFn :: MonadFix m => P.ExternsFile -> CoreFn.Module CoreFn.Ann -> InterpretT m (CoreFn.Module CoreFn.Ann)+buildCoreFn newExterns m = do+ (externs, env) <- InterpretT (lift get)+ newEnv <- liftWith ErrorDuringEvaluation (Evaluate.runEvalT (Evaluate.buildCoreFn env m))+ InterpretT . lift $ put (externs <> [newExterns], newEnv)+ pure m++-- | Evaluate a PureScript expression from source+eval+ :: (MonadFix m, ToValueRHS m a)+ => Maybe P.ModuleName+ -- ^ The name of the "default module" whose exports will be made available unqualified+ -- to the evaluated expression.+ -> Text+ -> InterpretT m (a, P.SourceType)+eval defaultModule exprText = do+ (externs, env) <- InterpretT (lift get)+ (expr, ty) <- liftWith ErrorDuringBuild $ pure $ Build.buildSingleExpression defaultModule externs exprText+ pure (Evaluate.fromValueRHS (Evaluate.eval env expr), ty)++-- | Evaluate a PureScript corefn expression and return the result.+-- Note: The expression is not type-checked by the PureScript typechecker. +-- See the documentation for 'ToValueRHS' for valid result types.+evalCoreFn :: (MonadFix m, ToValueRHS m a) => CoreFn.Expr CoreFn.Ann -> InterpretT m a+evalCoreFn expr = do+ (_externs, env) <- InterpretT (lift get)+ pure . Evaluate.fromValueRHS $ Evaluate.eval env expr++-- | Evaluate @main@ in the specified module and return the result.+evalMain :: (MonadFix m, ToValueRHS m a) => P.ModuleName -> InterpretT m a+evalMain moduleName = evalCoreFn (CoreFn.Var (CoreFn.ssAnn P.nullSourceSpan) (P.Qualified (Just moduleName) (P.Ident "main")))++-- | Start an interactive debugger (REPL) session.+repl + :: (MonadFix m, MonadIO m, MonadMask m) + => Maybe P.ModuleName + -- ^ The default module, whose members will be available unqualified in scope+ -> InterpretT m ()+repl defaultModule = do+ (externs, env) <- InterpretT (lift get)+ lift $ REPL.defaultMain defaultModule externs [] env
+ src/Dovetail/Build.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Dovetail.Build where++import Control.Monad (foldM)+import Control.Monad.Supply (evalSupplyT)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State (runStateT)+import Control.Monad.Trans.Writer (runWriterT)+import Data.Foldable (foldl')+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NEL+import Data.Text (Text)+import Language.PureScript qualified as P+import Language.PureScript.AST.Declarations qualified as AST+import Language.PureScript.AST.SourcePos qualified as AST+import Language.PureScript.CoreFn qualified as CoreFn+import Language.PureScript.CST qualified as CST+import Language.PureScript.Errors qualified as Errors+import Language.PureScript.Renamer qualified as Renamer+import Language.PureScript.Sugar.Names.Env qualified as Env+import Language.PureScript.TypeChecker.Monad qualified as TC++data BuildError+ = UnableToParse (NonEmpty CST.ParserError)+ | UnableToCompile Errors.MultipleErrors+ | InternalError+ deriving Show++renderBuildError :: BuildError -> String+renderBuildError (UnableToParse xs) =+ unlines $+ "Parser errors:" : NEL.toList (fmap CST.prettyPrintError xs)+renderBuildError (UnableToCompile xs) =+ Errors.prettyPrintMultipleErrors Errors.defaultPPEOptions xs+renderBuildError InternalError =+ "An internal error occurred during compilation."++-- | Parse and build a single PureScript module, returning the compiled CoreFn+-- module.+buildSingleModule :: [P.ExternsFile] -> Text -> Either BuildError (CoreFn.Module CoreFn.Ann, P.ExternsFile)+buildSingleModule externs moduleText = do+ case CST.parseFromFile "<input>" moduleText of+ (_, Left errs) ->+ Left (UnableToParse errs)+ (_, Right m) -> + case buildCoreFnOnly externs m of+ Left errs ->+ Left (UnableToCompile errs)+ Right (result, _) -> Right result++-- | Parse and build a single PureScript expression, returning the compiled CoreFn+-- module. The expression will be used to create a placeholder module with the name+-- @Main@, and a single expression named @main@, with the specified content.+buildSingleExpression+ :: Maybe P.ModuleName+ -- ^ The name of the "default module" whose exports will be made available unqualified+ -- to the evaluated expression.+ -> [P.ExternsFile]+ -> Text+ -> Either BuildError (CoreFn.Expr CoreFn.Ann, P.SourceType)+buildSingleExpression = buildSingleExpressionWith id++buildSingleExpressionWith+ :: (AST.Expr -> AST.Expr)+ -- ^ A function which can be used to modify the parsed syntax tree before compilation+ -> Maybe P.ModuleName+ -- ^ The name of the "default module" whose exports will be made available unqualified+ -- to the evaluated expression.+ -> [P.ExternsFile]+ -> Text+ -> Either BuildError (CoreFn.Expr CoreFn.Ann, P.SourceType)+buildSingleExpressionWith f defaultModule externs input = do+ let tokens = CST.lex input+ (_, parseResult) = CST.runParser (CST.ParserState tokens [] []) CST.parseExpr+ case parseResult of+ Left errs ->+ Left (UnableToParse errs)+ Right cst -> + buildSingleExpressionFromAST defaultModule externs (f (CST.convertExpr "<input>" cst))++buildSingleExpressionFromAST+ :: Maybe P.ModuleName+ -- ^ The name of the "default module" whose exports will be made available unqualified+ -- to the evaluated expression.+ -> [P.ExternsFile]+ -> AST.Expr+ -> Either BuildError (CoreFn.Expr CoreFn.Ann, P.SourceType)+buildSingleExpressionFromAST defaultModule externs expr = do+ let exprName = P.Ident "$"+ decl = AST.ValueDeclarationData+ { AST.valdeclSourceAnn = AST.nullSourceAnn+ , AST.valdeclIdent = exprName+ , AST.valdeclName = P.Public+ , AST.valdeclBinders = []+ , AST.valdeclExpression = [AST.GuardedExpr [] expr]+ }+ imports = [ P.ImportDeclaration+ AST.nullSourceAnn+ mn+ P.Implicit+ (if defaultModule == Just mn + then Nothing+ else Just mn)+ | P.ExternsFile { P.efModuleName = mn } <- externs+ ]+ m = AST.Module AST.nullSourceSpan [] (P.ModuleName "$") (imports <> [P.ValueDeclaration decl]) Nothing+ case buildCoreFnOnly externs m of + Left errs ->+ Left (UnableToCompile errs)+ Right ((result, externs'), _) -> + case (CoreFn.moduleDecls result, P.efDeclarations externs') of+ ([CoreFn.NonRec _ name1 coreFnExpr], [P.EDValue name2 ty]) + | name1 == exprName+ , name2 == exprName -> Right (coreFnExpr, ty)+ ([CoreFn.Rec [((_, name1), coreFnExpr)]], [P.EDValue name2 ty]) + | name1 == exprName+ , name2 == exprName -> Right (coreFnExpr, ty)+ _ -> Left InternalError++-- | Compile a single 'AST.Module' into a CoreFn module.+--+-- This function is based on the 'Language.PureScript.Make.rebuildModule'+-- function.+--+-- It is reproduced and modified here in order to make it simpler to build a +-- single module without all of the additional capabilities and complexity of+-- the upstream API.+buildCoreFnOnly+ :: [P.ExternsFile]+ -> AST.Module+ -> Either Errors.MultipleErrors ((CoreFn.Module CoreFn.Ann, P.ExternsFile), Errors.MultipleErrors)+buildCoreFnOnly externs m@(AST.Module _ _ moduleName _ _) = runWriterT $ do+ let withPrim = P.importPrim m+ env = foldl' (flip P.applyExternsFileToEnvironment) P.initEnvironment externs+ exEnv <- fmap fst . runWriterT $ foldM P.externsEnv Env.primEnv externs+ evalSupplyT 0 $ do+ (desugared, (exEnv', _)) <- runStateT (P.desugar externs withPrim) (exEnv, mempty)+ let modulesExports = (\(_, _, exports) -> exports) <$> exEnv'+ (checked, TC.CheckState{..}) <- runStateT (P.typeCheckModule modulesExports desugared) $ TC.emptyCheckState env+ let AST.Module ss coms _ elaborated exps = checked+ deguarded <- P.desugarCaseGuards elaborated+ regrouped <- lift . P.createBindingGroups moduleName . P.collapseBindingGroups $ deguarded+ let mod' = AST.Module ss coms moduleName regrouped exps+ corefn = CoreFn.moduleToCoreFn checkEnv mod'+ optimized = CoreFn.optimizeCoreFn corefn+ (renamedIdents, renamed) = Renamer.renameInModule optimized+ newExterns = P.moduleToExternsFile mod' checkEnv renamedIdents+ pure (renamed, newExterns)
+ src/Dovetail/Evaluate.hs view
@@ -0,0 +1,517 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Dovetail.Evaluate+ ( + -- * High-level API+ buildCoreFn+ , builtIn+ + -- * Evaluation+ + -- ** Eval/apply+ , eval+ , apply+ + -- * Conversion to and from Haskell types+ , ToValue(..)+ -- ** Higher-order functions+ , ToValueRHS(..)+ -- ** Foreign data types+ , ForeignType(..)+ -- ** Records+ , ObjectOptions(..)+ , defaultObjectOptions+ , genericToValue+ , genericFromValue+ , ToObject(..)+ + , module Dovetail.Types+ + -- ** Utilities+ , evalPSString+ ) where+ +import Control.Monad (guard, foldM, mzero, zipWithM)+import Control.Monad.Fix (MonadFix, mfix)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Maybe (MaybeT(..))+import Control.Monad.Reader.Class+import Data.Align qualified as Align+import Data.Dynamic qualified as Dynamic+import Data.Foldable (asum, fold)+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.Map qualified as Map+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Data.Text qualified as Text+import Data.These (These(..))+import Data.Typeable (Typeable, TypeRep, typeRep)+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Dovetail.Types+import GHC.Generics qualified as G+import GHC.TypeLits (KnownSymbol, symbolVal)+import Language.PureScript.CoreFn qualified as CoreFn+import Language.PureScript.Names (Qualified(..))+import Language.PureScript.Names qualified as Names+import Language.PureScript.PSString qualified as PSString++-- | Evaluate each of the bindings in a compiled PureScript module, and store+-- the evaluated values in the environment, without evaluating any main+-- expression.+buildCoreFn :: MonadFix m => Env m -> CoreFn.Module CoreFn.Ann -> EvalT m (Env m)+buildCoreFn env CoreFn.Module{ CoreFn.moduleName, CoreFn.moduleDecls } = + bind (Just moduleName) env moduleDecls+ +-- | Create an environment from a Haskell value.+--+-- It is recommended that a type annotation is given for the type of the value+-- being provided.+--+-- For example:+--+-- @+-- builtIn (ModuleName "Main") "greeting" ("Hello, World!" :: Text)+-- builtIn (ModuleName "Main") "somePrimes" ([2, 3, 5, 7, 11] :: Vector Integer)+-- @+--+-- Functions can be provided as built-ins, but the 'EvalT' monad needs to be+-- used to wrap any outputs (or values in positive position):+--+-- @+-- builtIn (ModuleName "Main") "strip" ((pure . Text.strip) :: Text -> EvalT m Text)+-- builtIn (ModuleName "Main") "map" (traverse :: (Value -> EvalT m Value) -> Vector Value -> EvalT m (Vector Value))+-- @+--+-- Polymorphic functions can also be provided as built-ins, but values with +-- polymoprhic types will need to be passed across the FFI boundary with +-- monomorphic types. The type 'Value' can always be used to represent values of+-- unknown or polymorphic type, as in the @map@ example above.+builtIn :: ToValue m a => Names.ModuleName -> Text -> a -> Env m+builtIn mn name value =+ let qualName = Names.mkQualified (Names.Ident name) mn+ in Map.singleton qualName $ toValue value++evalPSString :: MonadFix m => PSString.PSString -> EvalT m Text+evalPSString pss = + case PSString.decodeString pss of+ Just field -> pure field+ _ -> throwErrorWithContext (InvalidFieldName pss)++-- | Evaluate a PureScript CoreFn expression in the given environment.+--+-- Note: it should not be necessary to call this function directly in most+-- circumstances. It is provided as a helper function, for some more advanced+-- use cases, such as setting up a custom environment.+eval + :: forall m+ . MonadFix m+ => Env m+ -> CoreFn.Expr CoreFn.Ann+ -> EvalT m (Value m)+eval env expr = pushStackFrame env expr (evalHelper expr) where+ evalHelper (CoreFn.Literal _ lit) = + evalLit env lit+ evalHelper (CoreFn.Accessor _ pss e) = do+ val <- eval env e+ field <- evalPSString pss+ case val of+ Object o ->+ case HashMap.lookup field o of+ Just x -> pure x+ Nothing -> throwErrorWithContext (FieldNotFound field val)+ _ -> throwErrorWithContext (TypeMismatch "object" val)+ evalHelper (CoreFn.Abs _ arg body) = do+ ctx <- ask+ pure . Closure $ \v -> local (const ctx) $ eval (Map.insert (Qualified Nothing arg) v env) body+ evalHelper (CoreFn.App _ f x) = do+ x_ <- eval env x+ f_ <- eval env f+ apply f_ x_+ evalHelper (CoreFn.Var _ name) =+ case Map.lookup name env of+ Nothing -> throwErrorWithContext $ UnknownIdent name+ Just val -> pure val+ evalHelper (CoreFn.Let _ binders body) = do+ env' <- bind Nothing env binders+ eval env' body+ evalHelper (CoreFn.ObjectUpdate _ e updates) = do+ val <- eval env e+ let updateOne + :: HashMap Text (Value m)+ -> (PSString.PSString, CoreFn.Expr CoreFn.Ann)+ -> EvalT m (HashMap Text (Value m))+ updateOne o (pss, new) = do+ field <- evalPSString pss+ newVal <- eval env new+ pure $ HashMap.insert field newVal o+ case val of+ Object o -> Object <$> foldM updateOne o updates+ _ -> throwErrorWithContext (TypeMismatch "object" val)+ evalHelper (CoreFn.Case _ args alts) = do+ vals <- traverse (eval env) args+ result <- runMaybeT (asum (map (match env vals) alts))+ case result of+ Nothing -> throwErrorWithContext (InexhaustivePatternMatch vals)+ Just (newEnv, matchedExpr) -> eval (newEnv <> env) matchedExpr+ evalHelper (CoreFn.Constructor _ _tyName ctor fields) = + pure $ go fields []+ where+ go [] applied = Constructor ctor (reverse applied)+ go (_ : tl) applied = Closure \arg -> pure (go tl (arg : applied))++match :: MonadFix m+ => Env m+ -> [Value m]+ -> CoreFn.CaseAlternative CoreFn.Ann+ -> MaybeT (EvalT m) (Env m, CoreFn.Expr CoreFn.Ann)+match env vals (CoreFn.CaseAlternative binders expr) + | length vals == length binders = do+ newEnv <- fold <$> zipWithM matchOne vals binders+ case expr of+ Left guards -> (newEnv, ) <$> asum (map (uncurry (evalGuard env)) guards)+ Right e -> pure (newEnv, e)+ | otherwise = throwErrorWithContext (InvalidNumberOfArguments (length vals) (length binders))++evalGuard+ :: MonadFix m+ => Env m+ -> CoreFn.Guard CoreFn.Ann+ -> CoreFn.Expr CoreFn.Ann+ -> MaybeT (EvalT m) (CoreFn.Expr CoreFn.Ann)+evalGuard env g e = do+ test <- lift $ eval env g+ case test of+ Bool b -> guard b+ _ -> throwErrorWithContext (TypeMismatch "boolean" test )+ pure e++matchOne + :: MonadFix m+ => Value m+ -> CoreFn.Binder CoreFn.Ann+ -> MaybeT (EvalT m) (Env m)+matchOne _ (CoreFn.NullBinder _) = pure mempty+matchOne val (CoreFn.LiteralBinder _ lit) = matchLit val lit+matchOne val (CoreFn.VarBinder _ ident) = do+ pure (Map.singleton (Qualified Nothing ident) val)+matchOne val (CoreFn.NamedBinder _ ident b) = do+ env <- matchOne val b+ pure (Map.insert (Qualified Nothing ident) val env)+matchOne (Constructor ctor vals) (CoreFn.ConstructorBinder _ _tyName ctor' bs) + | ctor == Names.disqualify ctor'+ = if length vals == length bs + then fold <$> zipWithM matchOne vals bs+ else throwErrorWithContext UnsaturatedConstructorApplication+matchOne _ _ = mzero++matchLit+ :: forall m+ . MonadFix m+ => Value m+ -> CoreFn.Literal (CoreFn.Binder CoreFn.Ann)+ -> MaybeT (EvalT m) (Env m)+matchLit (Int n) (CoreFn.NumericLiteral (Left i)) + | fromIntegral i == n = pure mempty+matchLit (Number n) (CoreFn.NumericLiteral (Right d))+ | realToFrac d == n = pure mempty+matchLit (String s) (CoreFn.StringLiteral pss) = do+ s' <- lift (evalPSString pss)+ guard (s == s')+ pure mempty+matchLit (Char c) (CoreFn.CharLiteral c')+ | c == c' = pure mempty+matchLit (Bool b) (CoreFn.BooleanLiteral b')+ | b == b' = pure mempty+matchLit (Array xs) (CoreFn.ArrayLiteral bs)+ | length xs == length bs+ = fold <$> zipWithM matchOne (Vector.toList xs) bs+matchLit val@(Object o) (CoreFn.ObjectLiteral bs) = do+ let evalField (pss, b) = do+ t <- lift (evalPSString pss)+ pure (t, (t, b))+ vals <- HashMap.fromList <$> traverse evalField bs+ let matchField :: These (Value m) (Text, CoreFn.Binder CoreFn.Ann) -> MaybeT (EvalT m) (Env m)+ matchField This{} = pure mempty+ matchField (That (pss, _)) = throwErrorWithContext (FieldNotFound pss val)+ matchField (These val' (_, b)) = matchOne val' b+ fold <$> sequence (Align.alignWith matchField o vals)+matchLit _ _ = mzero++evalLit :: MonadFix m => Env m -> CoreFn.Literal (CoreFn.Expr CoreFn.Ann) -> EvalT m (Value m)+evalLit _ (CoreFn.NumericLiteral (Left int)) =+ pure $ Int (fromIntegral int)+evalLit _ (CoreFn.NumericLiteral (Right dbl)) =+ pure $ Number (realToFrac dbl)+evalLit _ (CoreFn.StringLiteral str) =+ String <$> evalPSString str+evalLit _ (CoreFn.CharLiteral chr) =+ pure $ Char chr+evalLit _ (CoreFn.BooleanLiteral b) =+ pure $ Bool b+evalLit env (CoreFn.ArrayLiteral xs) = do+ vs <- traverse (eval env) xs+ pure $ Array (Vector.fromList vs)+evalLit env (CoreFn.ObjectLiteral xs) = do+ let evalField (pss, e) = do+ field <- evalPSString pss+ val <- eval env e+ pure (field, val)+ Object . HashMap.fromList <$> traverse evalField xs++bind + :: forall m+ . MonadFix m+ => Maybe Names.ModuleName+ -> Env m+ -> [CoreFn.Bind CoreFn.Ann] + -> EvalT m (Env m)+bind scope = foldM go where+ go :: Env m -> CoreFn.Bind CoreFn.Ann -> EvalT m (Env m)+ go env (CoreFn.NonRec _ name e) = do+ val <- eval env e+ pure $ Map.insert (Qualified scope name) val env+ go env (CoreFn.Rec exprs) = mfix \newEnv -> do+ vals <- flip traverse exprs \((_, name), e) -> do+ val <- eval newEnv e+ pure $ Map.singleton (Qualified scope name) val+ pure (fold vals <> env)++-- | Apply a value which represents an unevaluated closure to an argument.+apply+ :: MonadFix m+ => Value m+ -> Value m+ -> EvalT m (Value m)+apply (Closure f) arg = f arg+apply val _ = throwErrorWithContext (TypeMismatch "closure" val)++-- | Values which can be communicated across the FFI boundary from Haskell to +-- PureScript.+--+-- Instances should identify and document any valid representations as a subset +-- of the semantic domain 'Value'. Such a subset can be identified by an+-- injective function 'toValue', and a partial inverse, 'fromValue', defined+-- on the image of 'toValue'.+--+-- Laws:+--+-- @+-- fromValue . toValue = pure+-- @+class MonadFix m => ToValue m a where+ toValue :: a -> Value m+ + -- | The default implementation uses generic deriving to identify a Haskell+ -- record type with a single data constructor with a PureScript record with+ -- the same field names.+ default toValue :: (G.Generic a, ToObject m (G.Rep a)) => a -> Value m+ toValue = genericToValue defaultObjectOptions+ + fromValue :: Value m -> EvalT m a+ + default fromValue :: (G.Generic a, ToObject m (G.Rep a)) => Value m -> EvalT m a+ fromValue = genericFromValue defaultObjectOptions+ +instance MonadFix m => ToValue m (Value m) where+ toValue = id+ fromValue = pure++-- | The Haskell 'Integer' type corresponds to PureScript's integer type.+instance MonadFix m => ToValue m Integer where+ toValue = Int+ fromValue = \case+ Int i -> pure i+ val -> throwErrorWithContext (TypeMismatch "integer" val)+ +-- | The Haskell 'Douvle' type corresponds to the subset of PureScript+-- values consisting of its Number type.+instance MonadFix m => ToValue m Double where+ toValue = Number+ fromValue = \case+ Number s -> pure s+ val -> throwErrorWithContext (TypeMismatch "number" val)++-- | The Haskell 'Text' type is represented by PureScript strings+-- which contain no lone surrogates.+instance MonadFix m => ToValue m Text where+ toValue = String+ fromValue = \case+ String s -> pure s+ val -> throwErrorWithContext (TypeMismatch "string" val)++-- | The Haskell 'Char' type is represented by PureScript characters.+instance MonadFix m => ToValue m Char where+ toValue = Char+ fromValue = \case+ Char c -> pure c+ val -> throwErrorWithContext (TypeMismatch "char" val)++-- | Haskell booleans are represented by boolean values.+instance MonadFix m => ToValue m Bool where+ toValue = Bool+ fromValue = \case+ Bool b -> pure b+ val -> throwErrorWithContext (TypeMismatch "boolean" val)+ +-- | Haskell functions are represented as closures which take valid+-- representations for the domain type to valid representations of the codomain+-- type.+instance (MonadFix m, ToValue m a, ToValueRHS m b) => ToValue m (a -> b) where+ toValue f = Closure (\v -> toValueRHS . f =<< fromValue v)+ fromValue f = pure $ \a -> fromValueRHS (apply f (toValue a))++-- | Haskell vectors are represented as homogeneous vectors of values, each of+-- which are valid representations of the element type.+instance ToValue m a => ToValue m (Vector a) where+ toValue = Array . fmap toValue+ fromValue = \case+ Array xs -> traverse fromValue xs+ val -> throwErrorWithContext (TypeMismatch "array" val)+ +-- | This type can be used to make custom Haskell types accessible to +-- PureScript code via the FFI's @foreign import data@ feature.+newtype ForeignType a = ForeignType { getForeignType :: a }++instance forall m a. (MonadFix m, Typeable a) => ToValue m (ForeignType a) where+ toValue = Foreign . Dynamic.toDyn . getForeignType+ fromValue = \case+ Foreign dyn + | Just a <- Dynamic.fromDynamic @a dyn -> pure (ForeignType a)+ val -> + let typeName = show @TypeRep (typeRep (Proxy :: Proxy a))+ in throwErrorWithContext (TypeMismatch (Text.pack typeName) val)++-- | 'ToValue' should support functions with types such as+--+-- @+-- a -> EvalT m b+-- a -> b -> EvalT m c+-- a -> b -> c -> EvalT m d+-- (a -> EvalT m b) -> EvalT m c+-- (a -> b -> EvalT m c) -> EvalT m d+-- @+--+-- Note that every type in a return position is wrapped in the 'EvalT' monad+-- transformer. This is because evaluation in general may result in errors.+-- However, a naive translation would result in too many applications of 'EvalT'.+--+-- Specifically, we do not want to require types such as these, in which 'EvalT'+-- appears on the right hand side of every function arrow:+--+-- @+-- a -> EvalT m b (b -> EvalT m c)+-- a -> EvalT m b (b -> EvalT m (c -> EvalT m d))+-- @+--+-- For this reason, the 'ToValue' instance for functions delegates to this+-- type class for the type on the right hand side of the function. It skips the+-- application of 'EvalT' for nested function types.+class ToValueRHS m a where+ toValueRHS :: a -> EvalT m (Value m)+ fromValueRHS :: EvalT m (Value m) -> a+ +instance (MonadFix m, ToValue m a, ToValueRHS m b) => ToValueRHS m (a -> b) where+ toValueRHS f = pure (Closure (\v -> toValueRHS . f =<< fromValue v))+ fromValueRHS mv a = fromValueRHS do+ v <- mv+ fromValueRHS (apply v (toValue a))+ +instance (ToValue m a, n ~ m) => ToValueRHS m (EvalT n a) where+ toValueRHS = fmap toValue+ fromValueRHS = (>>= fromValue)+ +-- | Options for customizing generic deriving of record instances+data ObjectOptions = ObjectOptions+ { toPureScriptField :: Text -> Text+ -- ^ Map a Haskell field name to a PureScript field name on the corresponding+ -- record type.+ }+ +-- | * Maps Haskell field names to PureScript field names, unmodified.+defaultObjectOptions :: ObjectOptions+defaultObjectOptions = ObjectOptions+ { toPureScriptField = id+ }++-- | Derived 'toValue' function for Haskell record types which should map to +-- corresponding PureScript record types.+genericToValue + :: (MonadFix m, G.Generic a, ToObject m (G.Rep a))+ => ObjectOptions+ -> a+ -> Value m+genericToValue opts = Object . toObject opts . G.from++-- | Derived 'fromValue' function for Haskell record types which should map to +-- corresponding PureScript record types.+genericFromValue+ :: (MonadFix m, G.Generic a, ToObject m (G.Rep a))+ => ObjectOptions+ -> Value m+ -> EvalT m a+genericFromValue opts = \case+ Object o -> G.to <$> fromObject opts o+ val -> throwErrorWithContext (TypeMismatch "object" val)+ +-- | This class is used in the default instance for 'ToValue', via generic+-- deriving, in order to identify a Haskell record type (with a single data+-- constructor and named fields) with values in the semantic domain+-- corresponding to a PureScript record type with the same field names.+class ToObject m f where+ toObject :: ObjectOptions -> f x -> HashMap Text (Value m)+ fromObject :: ObjectOptions -> HashMap Text (Value m) -> EvalT m (f x)+ +instance (Functor m, ToObject m f) => ToObject m (G.M1 G.D t f) where+ toObject opts = toObject opts . G.unM1+ fromObject opts = fmap G.M1 . fromObject opts+ +instance (Functor m, ToObject m f) => ToObject m (G.M1 G.C t f) where+ toObject opts = toObject opts . G.unM1+ fromObject opts = fmap G.M1 . fromObject opts+ +instance (MonadFix m, ToObject m f, ToObject m g) => ToObject m (f G.:*: g) where+ toObject opts (f G.:*: g) = toObject opts f <> toObject opts g+ fromObject opts o = (G.:*:) <$> fromObject opts o <*> fromObject opts o+ +instance + forall m field u s l r a+ . ( KnownSymbol field+ , ToValue m a+ ) + => ToObject m + (G.M1 + G.S+ ('G.MetaSel + ('Just field) + u s l) + (G.K1 r a)) + where+ toObject opts (G.M1 (G.K1 a)) = do+ let field = toPureScriptField opts (Text.pack (symbolVal @field (Proxy :: Proxy field)))+ in HashMap.singleton field (toValue a)+ fromObject opts o = do+ let field = toPureScriptField opts (Text.pack (symbolVal @field (Proxy :: Proxy field)))+ case HashMap.lookup field o of+ Nothing -> throwErrorWithContext (FieldNotFound field (Object o))+ Just v -> G.M1 . G.K1 <$> fromValue v
+ src/Dovetail/FFI.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++module Dovetail.FFI + ( + -- * Foreign function interface+ FFI(..)+ , ForeignImport(..)+ , toEnv+ , toExterns+ ) where++import Data.Map qualified as Map +import Dovetail.Types +import Language.PureScript qualified as P+import Language.PureScript.Externs qualified as Externs+ +-- | Describes a module which is implemented in Haskell, and made available+-- to PureScript code using its foreign function interface. +--+-- Right now, this consists only of foreign value declarations, even though+-- the FFI supports other forms of interop.+--+-- Values of this type can be constructed directly, but in many cases it is+-- simpler to use the "Dovetail.FFI.Builder" module+-- instead.+--+-- Values of this type can be consumed by the 'toExterns' and 'toEnv' functions,+-- and their results passed to the PureScript APIs or the low-level functions in+-- "Dovetail.Evaluate" and "Dovetail.Build", +-- directly, but it is more likely that you will use values of this type with the +-- higher-level 'Dovetail.ffi' function.+data FFI m = FFI+ { ffi_moduleName :: P.ModuleName+ -- ^ The module name for the module being implemented in Haskell.+ , ffi_values :: [ForeignImport m]+ -- ^ A list of values implemented in Haskell in this module.+ }+ +-- | A single value implemented in a foreign Haskell module.+data ForeignImport m = ForeignImport+ { fv_name :: P.Ident+ -- ^ The name of this value in PureScript code+ , fv_type :: P.SourceType+ -- ^ The PureScript type of this value+ , fv_value :: Value m+ -- ^ The value itself+ }++-- | Convert a foreign module into a PureScript externs file, for use during+-- separate compilation.+--+-- For advanced use cases, the result may be used with the functions in the +-- "Dovetail.Build" module.+toExterns :: FFI m -> P.ExternsFile+toExterns (FFI mn vals) =+ Externs.ExternsFile + { Externs.efVersion = "0.14.2"+ , Externs.efModuleName = mn+ , Externs.efExports = [P.ValueRef P.nullSourceSpan name | ForeignImport name _ _ <- vals]+ , Externs.efImports = [ P.ExternsImport (P.ModuleName "Prim") P.Implicit (Just (P.ModuleName "Prim"))+ , P.ExternsImport (P.ModuleName "Prim") P.Implicit Nothing+ ]+ , Externs.efFixities = []+ , Externs.efTypeFixities = []+ , Externs.efDeclarations = [Externs.EDValue name ty | ForeignImport name ty _ <- vals]+ , Externs.efSourceSpan = P.nullSourceSpan+ } ++-- | Convert a foreign module into an evaluation environment.+--+-- For advanced use cases, the result may be used with the functions in the +-- "Dovetail.Evaluate" module.+toEnv :: FFI m -> Env m+toEnv (FFI mn vals) = + Map.fromList [ (P.mkQualified name mn, val) | ForeignImport name _ val <- vals ]
+ src/Dovetail/FFI/Builder.hs view
@@ -0,0 +1,235 @@+{-# 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 = Nil+ +instance (ForAll m r o, a ~ FunctionType m (Value m) (EvalT m (Value m))) => ForAll m r (a -> o) where+ forAll f = Cons (forAll . f)+ +infixr 0 ~>++-- | Construct a PureScript function type+(~>) :: 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 = MonoType String+ +-- | The PureScript char type+char :: FunctionType m Char (EvalT m Char)+char = MonoType Char++-- | The PureScript boolean type+boolean :: FunctionType m Bool (EvalT m Bool)+boolean = MonoType Boolean++-- | The PureScript number type+number :: FunctionType m Double (EvalT m Double)+number = MonoType Number++-- | The PureScript integer type+int :: FunctionType m Integer (EvalT m Integer)+int = MonoType Int+ +-- | Construct a PureScript array type+array :: FunctionType m l r+ -> FunctionType m (Vector l) (EvalT m (Vector l))+array = Array+ +data ForeignImports m = ForeignImports+ { foreignImports_values :: [ForeignImport m]+ }+ +instance Semigroup (ForeignImports m) where+ x <> y = ForeignImports+ { foreignImports_values = foreignImports_values x <> foreignImports_values y+ }+ +instance Monoid (ForeignImports m) where+ mempty = ForeignImports + { foreignImports_values = 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 { unFFIBuilder :: Writer (ForeignImports m) a }+ deriving newtype (Functor, Applicative, 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 mn = snd . runFFIBuilder 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 mn = fmap convert . runWriter . unFFIBuilder where+ convert (ForeignImports values) = FFI+ { ffi_moduleName = mn+ , ffi_values = 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 = + \nm ty impl -> tell $ ForeignImports+ { foreignImports_values = + [ ForeignImport+ { fv_name = nm+ , fv_type = typeSchemeToSourceType (forAll ty)+ , fv_value = Evaluate.toValue impl+ }+ ]+ }+ +typeSchemeToSourceType :: MonadFix m => TypeScheme m a -> P.SourceType+typeSchemeToSourceType (Cons f) = Internal.forAll \a -> typeSchemeToSourceType (f (MonoType (Var a)))+typeSchemeToSourceType (Nil t) = functionTypeToSourceType t++functionTypeToSourceType :: MonadFix m => FunctionType m l r -> P.SourceType+functionTypeToSourceType (Function ty1 ty2) = + Internal.function + (functionTypeToSourceType ty1)+ (functionTypeToSourceType ty2)+functionTypeToSourceType (Array ty) =+ Internal.array+ (functionTypeToSourceType ty)+functionTypeToSourceType (MonoType t) = monoTypeToSourceType t++monoTypeToSourceType :: MonadFix m => MonoType m a -> P.SourceType+monoTypeToSourceType String = P.tyString+monoTypeToSourceType Char = P.tyChar+monoTypeToSourceType Boolean = P.tyBoolean+monoTypeToSourceType Number = P.tyNumber+monoTypeToSourceType Int = P.tyInt+monoTypeToSourceType (Var a) = a
+ src/Dovetail/FFI/Internal.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}++module Dovetail.FFI.Internal+ ( forAll+ , array+ , function+ ) where++import Data.List ((\\), nub)+import Data.Text (Text)+import Data.Text qualified as T+import Language.PureScript qualified as P++forAll :: (P.SourceType -> P.SourceType) -> P.SourceType+forAll f = + P.mkForAll + [(P.nullSourceAnn, (name, (Just P.kindType)))]+ (f (P.TypeVar P.nullSourceAnn name))+ where+ name = head (typeVars \\ boundTypeVars (f (P.TypeVar P.nullSourceAnn undefined)))++typeVars :: [Text]+typeVars = map T.singleton ['a'..'z'] <> map (<> "'") typeVars++boundTypeVars :: P.Type ann -> [Text]+boundTypeVars = nub . P.everythingOnTypes (++) go where+ go (P.ForAll _ name _ _ _) = [name]+ go _ = []++function :: P.SourceType -> P.SourceType -> P.SourceType+function a b = P.TypeApp P.nullSourceAnn (P.TypeApp P.nullSourceAnn P.tyFunction a) b++array :: P.SourceType -> P.SourceType+array = P.TypeApp P.nullSourceAnn P.tyArray
+ src/Dovetail/Prelude.hs view
@@ -0,0 +1,199 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- | A tiny standard library.+module Dovetail.Prelude where+ +import Control.Monad.Fix (MonadFix)+import Data.Char (chr, ord)+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Dovetail.Evaluate (ToValue, ToValueRHS)+import Dovetail.FFI (FFI(..))+import Dovetail.FFI.Builder (array, boolean, char, int, string, number, (~>))+import Dovetail.FFI.Builder qualified as FFI+import Dovetail.Types+import Language.PureScript qualified as P++stdlib :: MonadFix m => [FFI m]+stdlib = + [ prelude+ , preludeArray+ , preludeString+ , preludeChar+ , preludeNumber+ , preludeInt+ , preludeBoolean+ , preludeDebug+ ]++prelude :: MonadFix m => FFI m+prelude = FFI.evalFFIBuilder (P.ModuleName "Prelude") do+ FFI.foreignImport (P.Ident "identity") + (\a -> a ~> a)+ pure+ FFI.foreignImport (P.Ident "flip") + (\a b c -> (a ~> b ~> c) ~> b ~> a ~> c)+ flip+ +preludeArray :: MonadFix m => FFI m+preludeArray = FFI.evalFFIBuilder (P.ModuleName "Prelude.Array") do+ FFI.foreignImport (P.Ident "map") + (\a b -> (a ~> b) ~> array a ~> array b)+ traverse+ FFI.foreignImport (P.Ident "filter") + (\a -> (a ~> boolean) ~> array a ~> array a)+ Vector.filterM+ FFI.foreignImport (P.Ident "foldl") + (\a b -> (b ~> a ~> b) ~> b ~> array a ~> b)+ Vector.foldM+ FFI.foreignImport (P.Ident "zipWith") + (\a b c -> (a ~> b ~> c) ~> array a ~> array b ~> array c)+ Vector.zipWithM+ FFI.foreignImport (P.Ident "append")+ (\a -> array a ~> array a ~> array a)+ (\xs ys -> pure (xs <> ys))+ +preludeString :: MonadFix m => FFI m+preludeString = FFI.evalFFIBuilder (P.ModuleName "Prelude.String") do+ eqOps string+ ordOps string+ + FFI.foreignImport (P.Ident "append")+ (string ~> string ~> string)+ (\xs ys -> pure (xs <> ys))+ FFI.foreignImport (P.Ident "singleton")+ (char ~> string)+ (pure . Text.singleton)+ +preludeChar :: MonadFix m => FFI m+preludeChar = FFI.evalFFIBuilder (P.ModuleName "Prelude.Char") do+ eqOps char+ ordOps string+ + FFI.foreignImport (P.Ident "chr")+ (int ~> char)+ (pure . chr . fromIntegral)+ FFI.foreignImport (P.Ident "ord")+ (char ~> int)+ (pure . fromIntegral . ord)+ +preludeNumber :: MonadFix m => FFI m+preludeNumber = FFI.evalFFIBuilder (P.ModuleName "Prelude.Number") do+ numOps number+ ordOps number++ FFI.foreignImport (P.Ident "div")+ (number ~> number ~> number)+ (\x y -> pure (x / y))++ FFI.foreignImport (P.Ident "floor")+ (number ~> int)+ (pure . floor)+ FFI.foreignImport (P.Ident "ceiling")+ (number ~> int)+ (pure . ceiling)+ FFI.foreignImport (P.Ident "round")+ (number ~> int)+ (pure . round)+ FFI.foreignImport (P.Ident "truncate")+ (number ~> int)+ (pure . truncate)+ +preludeInt :: MonadFix m => FFI m+preludeInt = FFI.evalFFIBuilder (P.ModuleName "Prelude.Int") do+ eqOps int+ numOps int+ ordOps int++ FFI.foreignImport (P.Ident "div")+ (int ~> int ~> int)+ (\x y -> pure (x `div` y))++ FFI.foreignImport (P.Ident "toNumber")+ (int ~> number)+ (pure . fromIntegral)+ +preludeBoolean :: MonadFix m => FFI m+preludeBoolean = FFI.evalFFIBuilder (P.ModuleName "Prelude.Boolean") do+ eqOps boolean+ ordOps string+ + FFI.foreignImport (P.Ident "and")+ (boolean ~> boolean ~> boolean)+ (\x y -> pure (x && y))+ FFI.foreignImport (P.Ident "or")+ (boolean ~> boolean ~> boolean)+ (\x y -> pure (x || y))+ FFI.foreignImport (P.Ident "not")+ (boolean ~> boolean)+ (pure . not)+ +preludeDebug :: MonadFix m => FFI m+preludeDebug = + FFI.evalFFIBuilder (P.ModuleName "Prelude.Debug") do+ FFI.foreignImport (P.Ident "show")+ (\a -> a ~> string)+ (pure . renderValue (RenderValueOptions False Nothing))+ FFI.foreignImport (P.Ident "crash")+ (\a -> string ~> a)+ (throwErrorWithContext . OtherError)++eqOps + :: (ToValue m a, ToValueRHS m (EvalT m a), Eq a)+ => FFI.FunctionType m a (EvalT m a)+ -> FFI.FFIBuilder m ()+eqOps ty = do+ FFI.foreignImport (P.Ident "eq")+ (ty ~> ty ~> boolean)+ (\x y -> pure (x == y))+ FFI.foreignImport (P.Ident "neq")+ (ty ~> ty ~> boolean)+ (\x y -> pure (x /= y))++numOps + :: (ToValue m a, ToValueRHS m (EvalT m a), Num a)+ => FFI.FunctionType m a (EvalT m a)+ -> FFI.FFIBuilder m ()+numOps ty = do+ FFI.foreignImport (P.Ident "add")+ (ty ~> ty ~> ty)+ (\x y -> pure (x + y))+ FFI.foreignImport (P.Ident "sub")+ (ty ~> ty ~> ty)+ (\x y -> pure (x - y))+ FFI.foreignImport (P.Ident "mul")+ (ty ~> ty ~> ty)+ (\x y -> pure (x * y))+ +ordOps + :: (ToValue m a, ToValueRHS m (EvalT m a), Ord a)+ => FFI.FunctionType m a (EvalT m a)+ -> FFI.FFIBuilder m ()+ordOps ty = do+ FFI.foreignImport (P.Ident "min")+ (ty ~> ty ~> ty)+ (\x y -> pure (x `min` y))+ FFI.foreignImport (P.Ident "max")+ (ty ~> ty ~> ty)+ (\x y -> pure (x `max` y))+ + FFI.foreignImport (P.Ident "lt")+ (ty ~> ty ~> boolean)+ (\x y -> pure (x < y))+ FFI.foreignImport (P.Ident "gt")+ (ty ~> ty ~> boolean)+ (\x y -> pure (x > y))+ FFI.foreignImport (P.Ident "lte")+ (ty ~> ty ~> boolean)+ (\x y -> pure (x <= y))+ FFI.foreignImport (P.Ident "gte")+ (ty ~> ty ~> boolean)+ (\x y -> pure (x >= y))+
+ src/Dovetail/REPL.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Dovetail.REPL (defaultMain) where++import Control.Monad.Catch (MonadMask)+import Control.Monad.Fix (MonadFix)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (lift)+import Data.Map qualified as Map+import Data.Text qualified as Text+import Dovetail.Build qualified as Build+import Dovetail.Evaluate qualified as Evaluate+import Dovetail.Types+import Language.PureScript qualified as P+import Language.PureScript.AST.Binders qualified as AST+import Language.PureScript.AST.Declarations qualified as AST+import Language.PureScript.CoreFn qualified as CoreFn+import System.Console.Haskeline++renderOptions :: RenderValueOptions+renderOptions = RenderValueOptions+ { colorOutput = True+ , maximumDepth = Nothing+ }++-- | Starts a minimal interactive debugger (REPL) session. +--+-- It is more likely that you will want to use the 'Dovetail.repl' function to+-- start a REPL session from within an 'Dovetail.InterpretT' block.+defaultMain + :: forall m+ . (MonadFix m, MonadIO m, MonadMask m)+ => Maybe P.ModuleName+ -- ^ The default module, whose members will be available unqualified in scope.+ -> [P.ExternsFile]+ -- ^ Any externs files to load+ -> [P.Ident]+ -- ^ Any additional identifiers which are available in the environment, but not+ -- given types in the externs file. These will be made available without type+ -- information, for debugging purposes.+ -> Env m+ -- ^ The evaluation environment+ -> m ()+defaultMain defaultModule externs additionalIdentsInScope env = runInputT settings loop where+ loop :: InputT m ()+ loop = do+ minput <- getInputLine "> "+ case minput of+ Nothing -> return ()+ Just input -> do+ case Build.buildSingleExpressionWith abstractAdditionalInputs defaultModule externs (Text.pack input) of+ Right (expr, _) -> do+ let appliedExpr = applyAdditionalInputs expr+ mresult <- lift . runEvalT $ Evaluate.eval env appliedExpr+ case mresult of+ Right result ->+ outputStrLn . Text.unpack $ renderValue renderOptions result+ Left err ->+ outputStrLn $ renderEvaluationError renderOptions err+ Left err ->+ outputStrLn $ Build.renderBuildError err+ loop+ + -- Since we might have additional identifiers in scope which are not defined+ -- in the externs files (for example, if we stopped at an error), we need to+ -- introduce those names into scope another way, without running afoul of the+ -- typechecker. We do this by binding them to the arguments of a temporary+ -- function, typechecking _that_ function, and applying it in the evaluator+ -- after type checking is complete.+ abstractAdditionalInputs expr =+ foldl (\e name -> + AST.Abs (AST.VarBinder P.nullSourceSpan name) e)+ expr + additionalIdentsInScope+ + applyAdditionalInputs expr =+ foldl (\e name -> + CoreFn.App (CoreFn.ssAnn P.nullSourceSpan) e + (CoreFn.Var (CoreFn.ssAnn P.nullSourceSpan)+ (P.Qualified Nothing name))) + expr + additionalIdentsInScope+ + settings = setComplete completionFunc defaultSettings+ + completionFunc = completeWord Nothing " \t" \s ->+ pure + [ simpleCompletion (Text.unpack ident)+ | ident <- allCompletions+ , Text.isPrefixOf (Text.pack s) ident+ ]+ + allCompletions = map (P.showQualified P.showIdent) (Map.keys env)
+ src/Dovetail/Types.hs view
@@ -0,0 +1,328 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}++module Dovetail.Types (+ -- * Evaluation+ -- ** Value types+ Value(..)+ + -- ** Evaluation monad+ , Env+ , EvalT(..)+ , runEvalT+ , Eval+ , runEval+ + -- ** Evaluation errors+ , EvaluationError(..)+ , EvaluationErrorType(..)+ , renderEvaluationError+ + -- ** Evaluation contexts+ , EvaluationContext(..)+ + -- *** Stack frames+ , EvaluationStackFrame(..)+ , pushStackFrame+ , throwErrorWithContext+ + -- * Debugging+ , renderValue+ , RenderValueOptions(..)+ , defaultTerminalRenderValueOptions+ ) where+ +import Control.Monad.Error.Class (MonadError(..))+import Control.Monad.Reader.Class (MonadReader(..))+import Control.Monad.Fix (MonadFix(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Except (ExceptT, runExceptT)+import Control.Monad.Trans.Reader (ReaderT, runReaderT)+import Data.Dynamic (Dynamic)+import Data.Foldable (fold)+import Data.Functor.Identity (Identity(..))+import Data.HashMap.Strict (HashMap)+import Data.HashMap.Strict qualified as HashMap+import Data.List (sortBy)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Maybe (listToMaybe)+import Data.Ord (comparing)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Language.PureScript qualified as P+import Language.PureScript.CoreFn qualified as CoreFn+import Language.PureScript.Errors qualified as Errors+import Language.PureScript.Names (Ident(..), Qualified(..))+import Language.PureScript.Names qualified as Names+import Language.PureScript.PSString qualified as PSString+import System.Console.ANSI.Types qualified as Color++-- | The representation of values used by the interpreter - essentially, the+-- semantic domain for a simple untyped lambda calculus with records and ADTs.+--+-- Any additional side effects which might occur in FFI calls to Haskell code+-- are tracked by a monad in the type argument.+data Value m+ = Object (HashMap Text (Value m))+ -- ^ Records are represented as hashmaps from their field names to values+ | Array (Vector (Value m))+ | String Text+ | Char Char+ | Number Double+ | Int Integer+ | Bool Bool+ | Closure (Value m -> EvalT m (Value m))+ -- ^ Closures, represented in higher-order abstract syntax style.+ | Constructor (Names.ProperName 'Names.ConstructorName) [Value m]+ -- ^ Fully-applied data constructors+ | Foreign Dynamic+ -- ^ Foreign data types++-- | Options when rendering values as strings using 'renderValue'.+data RenderValueOptions = RenderValueOptions+ { colorOutput :: Bool+ -- ^ Should ANSI terminal color codes be emitted+ , maximumDepth :: Maybe Int+ -- ^ The maximum depth of a subexpression to render, or 'Nothing'+ -- to render the entire 'Value'.+ }++-- | Some sensible default rendering options for use on a terminal+-- which supports color.+defaultTerminalRenderValueOptions :: RenderValueOptions+defaultTerminalRenderValueOptions = RenderValueOptions+ { colorOutput = True+ , maximumDepth = Just 1+ }++-- | Render a 'Value' as human-readable text.+--+-- As a general rule, apart from any closures, the rendered text should evaluate+-- to the value you started with (when 'maximumDepth' is not set).+renderValue :: RenderValueOptions -> Value m -> Text+renderValue RenderValueOptions{ colorOutput, maximumDepth } = fst . go 0 where+ go :: Int -> Value m -> (Text, Bool)+ go n _ | maybe False (n >=) maximumDepth = ("⋯", True)+ go _ (String s) = (Text.pack (yellow (show @Text s)), True)+ go _ (Char c) = (Text.pack (yellow (show @Char c)), True)+ go _ (Number d) = (Text.pack (green (show @Double d)), True)+ go _ (Int i) = (Text.pack (green (show @Integer i)), True)+ go _ (Bool True) = (Text.pack (blue "true"), True)+ go _ (Bool False) = (Text.pack (blue "false"), True)+ go _ (Closure{}) = (Text.pack (blue "<closure>"), True)+ go n (Object o) = ( "{ " <> Text.intercalate ", " + [ Text.pack (yellow (show @Text k)) <> ": " <> fst (go (n + 1) x) + | (k, x) <- sortBy (comparing fst) (HashMap.toList o)+ ] <> " }"+ , True+ )+ go n (Array xs) = ( "[ " <> Text.intercalate ", " + [ fst (go (n + 1) x) + | x <- Vector.toList xs+ ] <> " ]"+ , True+ )+ go n (Constructor ctor args) = (Text.unwords (P.runProperName ctor : map (goParens (n + 1)) args), null args)+ go _ (Foreign{}) = (Text.pack (blue "<foreign>"), True)++ goParens :: Int -> Value m -> Text+ goParens n x = + case go n x of+ (result, True) -> result+ (result, False) -> "(" <> result <> ")"+ + color :: (Color.ColorIntensity, Color.Color) -> String -> String+ color c + | colorOutput = (Errors.ansiColor c <>) . (<> Errors.ansiColorReset)+ | otherwise = id++ yellow :: String -> String+ yellow = color (Color.Dull, Color.Yellow)++ green :: String -> String+ green = color (Color.Dull, Color.Green)++ blue :: String -> String+ blue = color (Color.Vivid, Color.Blue)+ +-- | An environment, i.e. a mapping from names to evaluated values.+--+-- An environment for a single built-in function can be constructed+-- using the 'builtIn' function, and environments can be combined+-- easily using the 'Monoid' instance for 'Map'.+type Env m = Map (Qualified Ident) (Value m)++-- | An evaluation context currently consists of an evaluation stack, which+-- is only used for debugging purposes.+--+-- The context type is parameterized by a monad @m@, because stack frames can+-- contain environments, which can in turn contain 'Value's, which may contain+-- monadic closures. This can be useful for inspecting values or resuming execution+-- in the event of an error.+newtype EvaluationContext m = EvaluationContext + { getEvaluationContext :: [EvaluationStackFrame m] }+ +-- | A single evaluation stack frame+-- TODO: support frames for foreign function calls+data EvaluationStackFrame m = EvaluationStackFrame+ { frameEnv :: Env m+ -- ^ The current environment in this stack frame + , frameSource :: P.SourceSpan+ -- ^ The source span of the expression whose evaluation created this stack frame.+ , frameExpr :: CoreFn.Expr CoreFn.Ann+ -- ^ The expression whose evaluation created this stack frame.+ }+ +-- | Create a stack frame for the evaluation of an expression, and push it onto+-- the stack.+pushStackFrame :: Monad m => Env m -> CoreFn.Expr CoreFn.Ann -> EvalT m a -> EvalT m a+pushStackFrame env expr = + local \(EvaluationContext frames) ->+ EvaluationContext (frame : frames)+ where+ frame = EvaluationStackFrame + { frameEnv = env+ , frameSource = let (ss, _, _, _) = CoreFn.extractAnn expr in ss+ , frameExpr = expr+ }++-- | Throw an error which captures the current execution context.+throwErrorWithContext + :: ( MonadError (EvaluationError x) m+ , MonadReader (EvaluationContext x) m+ ) + => EvaluationErrorType x+ -> m a+throwErrorWithContext errorType = do+ errorContext <- ask+ throwError EvaluationError + { errorType+ , errorContext+ }+ +-- | The monad used by the interpreter, which supports error reporting for errors+-- which can occur during evaluation.+--+-- The transformed monad is used to track any benign side effects that might be+-- exposed via the foreign function interface to PureScript code.+newtype EvalT m a = EvalT { unEvalT :: ReaderT (EvaluationContext m) (ExceptT (EvaluationError m) m) a }+ deriving newtype + ( Functor+ , Applicative+ , Monad+ , MonadError (EvaluationError m)+ , MonadReader (EvaluationContext m)+ , MonadFix+ )++instance MonadTrans EvalT where+ lift = EvalT . lift . lift++runEvalT :: EvalT m a -> m (Either (EvaluationError m) a)+runEvalT = runExceptT . flip runReaderT (EvaluationContext []) . unEvalT++-- | Non-transformer version of `EvalT`, useful in any settings where the FFI+-- does not use any side effects during evaluation.+type Eval = EvalT Identity++runEval :: Eval a -> Either (EvaluationError Identity) a+runEval = runIdentity . runEvalT++-- | An evaluation error containing the evaluation context at the point the+-- error was raised.+data EvaluationError m = EvaluationError+ { errorType :: EvaluationErrorType m+ -- ^ The type of error which was raised+ , errorContext :: EvaluationContext m+ -- ^ The evaluation context at the point the error was raised.+ } ++-- | Errors which can occur during evaluation of PureScript code.+-- +-- PureScript is a typed language, and tries to prevent runtime errors.+-- However, in the context of this interpreter, we can receive data from outside+-- PureScript code, so it is possible that runtime errors can occur if we are+-- not careful. This is similar to how PureScript code can fail at runtime+-- due to errors in the FFI.+data EvaluationErrorType m+ = UnknownIdent (Qualified Ident)+ -- ^ A name was not found in the environment+ | TypeMismatch Text (Value m)+ -- ^ The runtime representation of a value did not match the expected+ -- representation+ | FieldNotFound Text (Value m)+ -- ^ A record field did not exist in an 'Object' value.+ | InexhaustivePatternMatch [Value m]+ -- ^ A pattern match failed to match its argument+ | InvalidNumberOfArguments Int Int+ -- ^ A pattern match received the wrong number of arguments+ | UnsaturatedConstructorApplication+ -- ^ A pattern match occurred against a partially-applied data constructor+ | InvalidFieldName PSString.PSString+ -- ^ A PureScript string which contains lone surrogates which could not be+ -- decoded. See 'PSString.PSString'.+ | OtherError Text+ -- ^ An error occurred in a foreign function which is not tracked by+ -- any of the other error types.++-- | Render an 'EvaluationError' as a human-readable string.+renderEvaluationError :: RenderValueOptions -> EvaluationError m -> String+renderEvaluationError opts (EvaluationError{ errorType, errorContext }) =+ unlines $+ [ maybe "Error"+ (("Error " <>) . Text.unpack . renderSourceSpan)+ (listToMaybe (getEvaluationContext errorContext))+ ] <>+ [ ""+ , " " <> renderEvaluationErrorType opts errorType+ , ""+ , "In context:"+ ] <> concat+ [ [ " " <> Text.unpack (Names.showIdent (P.disqualify ident))+ , " = " <> Text.unpack (renderValue opts value)+ , ""+ ]+ | headFrame <- take 1 (getEvaluationContext errorContext)+ , (ident, value) <- Map.toList (frameEnv headFrame)+ , P.isUnqualified ident+ ] <> + [ Text.unpack (renderSourceSpan frame)+ | frame <- drop 1 (getEvaluationContext errorContext)+ ]+ where+ renderSourceSpan frame =+ "at " <> fold+ [ P.displaySourcePos (P.spanStart (frameSource frame)) + , " - " + , P.displaySourcePos (P.spanEnd (frameSource frame))+ ]+ +renderEvaluationErrorType :: RenderValueOptions -> EvaluationErrorType m -> String+renderEvaluationErrorType _ (UnknownIdent x) =+ "Identifier not in scope: " <> Text.unpack (Names.showQualified Names.showIdent x)+renderEvaluationErrorType opts (TypeMismatch x val) =+ "Type mismatch, expected " <> Text.unpack x <> ", but got value " <> Text.unpack (renderValue opts val)+renderEvaluationErrorType opts (FieldNotFound x val) =+ "Record field " <> show x <> " was not present in value: " <> Text.unpack (renderValue opts val)+renderEvaluationErrorType _ InexhaustivePatternMatch{} =+ "Inexhaustive pattern match"+renderEvaluationErrorType _ (InvalidNumberOfArguments given expected) =+ "Invalid number of arguments, given " <> show given <> ", but expected " <> show expected+renderEvaluationErrorType _ UnsaturatedConstructorApplication =+ "Unsaturated constructor application"+renderEvaluationErrorType _ (InvalidFieldName x) =+ "Invalid field name: " <> PSString.decodeStringWithReplacement x+renderEvaluationErrorType _ (OtherError x) =+ "Other error: " <> Text.unpack x
+ test/Spec.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE ImportQualifiedPost #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Main where+ +import Control.Monad (guard)+import Data.Bifunctor (first)+import Data.Foldable (for_, traverse_)+import Data.Functor (($>))+import Data.Functor.Identity+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as IO+import Data.Vector qualified as Vector+import Dovetail+import Dovetail.Prelude (prelude, stdlib)+import GHC.Generics (Generic)+import Language.PureScript qualified as P+import Language.PureScript.CoreFn qualified as CoreFn+import System.FilePath (takeFileName, (</>))+import System.Directory (listDirectory)+import Test.Hspec+import Test.Hspec.Golden+import Test.QuickCheck+import Test.QuickCheck.Arbitrary.Generic+import Test.QuickCheck.Instances.Text ()+ +renderOpts :: RenderValueOptions+renderOpts = RenderValueOptions+ { colorOutput = False+ , maximumDepth = Nothing + }+ +main :: IO ()+main = hspec do+ describe "Evaluation" do+ describe "ToValue" do+ let roundtrip + :: forall a+ . ( Arbitrary a+ , Show a+ , Eq a+ , ToValue Identity a+ )+ => Property+ roundtrip = property \x -> + either (const Nothing) Just + (runEval (fromValue (toValue @_ @a x))) === Just x+ + it "should roundtrip Integer" $ + roundtrip @Integer+ it "should roundtrip Double" $ + roundtrip @Double+ it "should roundtrip Text" $ + roundtrip @Text+ it "should roundtrip records" $ + roundtrip @ExampleRecord1+ + let roundtrip1+ :: forall a b+ . ( CoArbitrary a+ , Arbitrary a, Arbitrary b+ , Show a, Show b+ , Eq a, Eq b+ , ToValue Identity a+ , ToValue Identity b+ )+ => Property+ roundtrip1 = forAllBlind arbitrary \f -> property \a -> + either (const Nothing) Just + (runEval (fromValueRHS (pure (toValue @_ @(a -> Eval b) (pure . f))) a)) === Just (f a)+ + it "should roundtrip Text -> Text" $ + roundtrip1 @Text @Text+ it "should roundtrip Integer -> Text" $ + roundtrip1 @Integer @Text+ it "should roundtrip Text -> Integer" $ + roundtrip1 @Integer @Text+ it "should roundtrip Text -> records" $ + roundtrip1 @Text @ExampleRecord1+ + describe "Build" do+ describe "InterpretT" do+ let buildSingleModuleWithPrelude + :: forall a+ . ToValueRHS Identity a+ => Text+ -> Either String a+ buildSingleModuleWithPrelude moduleText =+ first (renderInterpretError renderOpts) $+ runInterpret do+ ffi prelude+ m <- build moduleText+ evalMain (CoreFn.moduleName m)+ + it "should build single modules from source" $+ fmap (first (renderEvaluationError renderOpts) . runEval) + (buildSingleModuleWithPrelude @(Eval Integer) + "module Main where main = 42")+ `shouldBe` Right (Right 42)+ + it "should support imports" $+ fmap (first (renderEvaluationError renderOpts) . runEval) + (buildSingleModuleWithPrelude @(Eval Integer) + "module Main where\n\+ \import Prelude\n\+ \main = identity 42")+ `shouldBe` Right (Right 42)+ + it "should support returning functions" $+ fmap (first (renderEvaluationError renderOpts) . runEval . ($ "testing")) + (buildSingleModuleWithPrelude @(Text -> Eval Text) + "module Main where\n\+ \import Prelude\n\+ \main x = x")+ `shouldBe` Right (Right "testing")+ + it "should support records" $+ fmap (first (renderEvaluationError renderOpts) . runEval . ($ "testing")) + (buildSingleModuleWithPrelude @(Text -> Eval ExampleRecord1) + "module Main where\n\+ \import Prelude\n\+ \main x = { foo: 42, bar: 1.0, baz: true, quux: x }")+ `shouldBe` Right (Right (ExampleRecord1 42 1.0 True "testing"))++ it "should support mixing module and expression evaluation" do+ let x = runInterpret do+ traverse_ ffi stdlib+ let moduleText =+ "module Main where\n\+ \import Prelude.Array\n\+ \main = map _.foo"+ CoreFn.Module { CoreFn.moduleName = mn } <- build moduleText+ runEval . fst <$> eval (Just mn) "main [{ foo: 42 }]"+ fmap (first (renderEvaluationError renderOpts)) (first (renderInterpretError renderOpts) x)+ `shouldBe` Right (Right (Vector.fromList [42 :: Integer]))+ + let buildSingleExpressionWithPrelude + :: forall a+ . ToValueRHS Identity a+ => Bool+ -> [FFI Identity]+ -> Text+ -> Either String (a, P.SourceType)+ buildSingleExpressionWithPrelude importPreludeUnqualified ffiModules exprText =+ first (renderInterpretError renderOpts) $+ runInterpret do+ traverse_ ffi ffiModules+ let defaultModule = guard importPreludeUnqualified $> P.ModuleName "Prelude"+ eval defaultModule exprText+ + it "should compile and evaluate literals" $+ fmap (first (first (renderEvaluationError renderOpts) . runEval)) + (buildSingleExpressionWithPrelude @(Eval Integer) False [prelude] "42")+ `shouldBe` Right (Right 42, P.tyInt)+ + it "should compile and evaluate simple expressions" $+ fmap (first (first (renderEvaluationError renderOpts) . runEval)) + (buildSingleExpressionWithPrelude @(Eval Integer) False [prelude] "Prelude.identity 42")+ `shouldBe` Right (Right 42, P.tyInt)+ + it "should compile and evaluate simple expressions with unqualified names from the default module" $+ fmap (first (first (renderEvaluationError renderOpts) . runEval)) + (buildSingleExpressionWithPrelude @(Eval Integer) True [prelude] "identity 42")+ `shouldBe` Right (Right 42, P.tyInt)+ + describe "Golden expression tests" do+ testFiles <- map takeFileName <$> runIO (listDirectory "test-files")+ + for_ testFiles \name -> do+ input <- runIO (IO.readFile ("test-files" </> name </> "input.purs"))+ let actualOutput = + case buildSingleExpressionWithPrelude @(Eval Text) True stdlib input of+ Left err -> + Text.pack err + Right (value, _) -> + case runEval value of+ Left err ->+ Text.pack (renderEvaluationError renderOpts err)+ Right result ->+ result+ it ("generates the correct output for test case " <> show name) $+ Golden {+ Test.Hspec.Golden.output = actualOutput,+ encodePretty = Text.unpack,+ writeToFile = IO.writeFile,+ readFromFile = IO.readFile,+ goldenFile = "test-files" </> name </> "golden",+ actualFile = Just ("test-files" </> name </> "actual"),+ failFirstTime = False+ }+ +data ExampleRecord1 = ExampleRecord1+ { foo :: Integer+ , bar :: Double+ , baz :: Bool+ , quux :: Text+ } deriving stock (Show, Eq, Generic) + deriving anyclass (ToValue m)+ deriving Arbitrary via GenericArbitrary ExampleRecord1