diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/dovetail.cabal b/dovetail.cabal new file mode 100644 --- /dev/null +++ b/dovetail.cabal @@ -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 , 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 diff --git a/src/Dovetail.hs b/src/Dovetail.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail.hs @@ -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 diff --git a/src/Dovetail/Build.hs b/src/Dovetail/Build.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/Build.hs @@ -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 "" 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 "" 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) diff --git a/src/Dovetail/Evaluate.hs b/src/Dovetail/Evaluate.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/Evaluate.hs @@ -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 diff --git a/src/Dovetail/FFI.hs b/src/Dovetail/FFI.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/FFI.hs @@ -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 ] diff --git a/src/Dovetail/FFI/Builder.hs b/src/Dovetail/FFI/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/FFI/Builder.hs @@ -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 diff --git a/src/Dovetail/FFI/Internal.hs b/src/Dovetail/FFI/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/FFI/Internal.hs @@ -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 diff --git a/src/Dovetail/Prelude.hs b/src/Dovetail/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/Prelude.hs @@ -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)) + diff --git a/src/Dovetail/REPL.hs b/src/Dovetail/REPL.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/REPL.hs @@ -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) diff --git a/src/Dovetail/Types.hs b/src/Dovetail/Types.hs new file mode 100644 --- /dev/null +++ b/src/Dovetail/Types.hs @@ -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 ""), 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 ""), 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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