From 320c184572c2e143833a4f381d2d20726582732e Mon Sep 17 00:00:00 2001 From: Mann mit Hut Date: Sat, 25 Sep 2021 17:45:44 +0200 Subject: [PATCH] Remote imports (#16) --- .github/workflows/haskell.yml | 2 +- .hlint.yaml | 68 +++++++++ README.md | 49 +++++++ grace-core/grace-core.cabal | 6 + grace-core/src/Grace/Import.hs | 124 +++++++++++++++++ grace-core/src/Grace/Import/Resolver.hs | 177 ++++++++++++++++++++++++ grace-core/src/Grace/Infer.hs | 36 ++--- grace-core/src/Grace/Interpret.hs | 115 ++++++++------- grace-core/src/Grace/Lexer.hs | 23 ++- grace-core/src/Grace/Normalize.hs | 1 - grace-core/src/Grace/Parser.hs | 30 +++- grace-core/src/Grace/Pretty.hs | 6 +- grace-core/src/Grace/TH.hs | 10 +- grace-core/src/Grace/Type.hs | 25 ++-- grace-core/tasty/Grace/Test/Resolver.hs | 62 +++++++++ grace-core/tasty/Main.hs | 32 +++-- grace-core/tasty/data/true.ffg | 1 + grace/grace.cabal | 2 +- grace/src/Grace.hs | 14 +- grace/src/Grace/Repl.hs | 32 ++--- 20 files changed, 669 insertions(+), 146 deletions(-) create mode 100644 .hlint.yaml create mode 100644 grace-core/src/Grace/Import.hs create mode 100644 grace-core/src/Grace/Import/Resolver.hs create mode 100644 grace-core/tasty/Grace/Test/Resolver.hs create mode 100644 grace-core/tasty/data/true.ffg diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 56217cf..865c953 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -36,4 +36,4 @@ jobs: - name: Build run: cabal build --enable-tests --enable-benchmarks all - name: Run tests - run: cabal test tasty + run: cabal test grace-core:tasty diff --git a/.hlint.yaml b/.hlint.yaml new file mode 100644 index 0000000..2678af0 --- /dev/null +++ b/.hlint.yaml @@ -0,0 +1,68 @@ +# HLint configuration file +# https://github.com/ndmitchell/hlint +########################## + +# This file contains a template configuration file, which is typically +# placed as .hlint.yaml in the root of your project + + +# Specify additional command line arguments +# +# - arguments: [--color, --cpp-simple, -XQuasiQuotes] + + +# Control which extensions/flags/modules/functions can be used +# +# - extensions: +# - default: false # all extension are banned by default +# - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used +# - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module +# +# - flags: +# - {name: -w, within: []} # -w is allowed nowhere +# +# - modules: +# - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' +# - {name: Control.Arrow, within: []} # Certain modules are banned entirely +# +# - functions: +# - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules + + +# Add custom hints for this project +# +# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" +# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} + +# The hints are named by the string they display in warning messages. +# For example, if you see a warning starting like +# +# Main.hs:116:51: Warning: Redundant == +# +# You can refer to that hint with `{name: Redundant ==}` (see below). + +# Turn on hints that are off by default +# +# Ban "module X(module X) where", to require a real export list +# - warn: {name: Use explicit module export list} +# +# Replace a $ b $ c with a . b $ c +# - group: {name: dollar, enabled: true} +# +# Generalise map to fmap, ++ to <> +# - group: {name: generalise, enabled: true} + + +# Ignore some builtin hints +# - ignore: {name: Use let} +# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules +- ignore: {name: Use fmap, within: Grace.Parser} +- ignore: {name: Use <$>, within: Grace.Parser} + + +# Define some custom infix operators +# - fixity: infixr 3 ~^#^~ + + +# To generate a suitable file for HLint do: +# $ hlint --default > .hlint.yaml diff --git a/README.md b/README.md index bd241b9..d4761c9 100644 --- a/README.md +++ b/README.md @@ -884,6 +884,11 @@ annotation as a last resort. ### Imports +Grace has two ways to import expressions from other sources: Filepath-based +imports and imports using URIs. + +#### Imports from files + You can import a Grace subexpression stored within a separate file by referencing the file's relative or absolute path. @@ -974,6 +979,50 @@ $ grace interpret - <<< './greet.ffg "John"' Any subexpression can be imported in this way. +#### Imports using URIs + +Imports with URIs work similar to the ones using a simple filepath. + +Suppose you do not have the `greet.ffg` stored locally but instead it resides +on a web server: `http://example.com/grace/greet.ffg` +You could either download it and reference it by its filepath like demonstrated +in the example above or let the Grace interpreter do the job: + +```bash +$ grace interpret - <<< 'http://example.com/grace/greet.ffg "John"' +``` +```dhall +"Hello, John!" +``` + +Note that if a particular URI can be handled by the Grace interpreter depends +on its (compile-time) configuration: Internally it relies on a set of _resolvers_ +that take care of all the things related to networking like downloading, caching +, verifying the integrity of retrieved file on so on. +For instance, the motivating example will unfortunately not work out-of-the box +since the grace executable has no builtin resolver for HTTP (yet). + +Grace comes with two builtin resolvers: + +1. One to resolve `env://` URIs, +2. one to resolve `file://` URIs. + +Lets have a look at the `env://` resolver first: +```bash +$ MY_VAR='"Hello !"' grace interpret - <<< 'env:///MY_VAR' +``` +```dhall +"Hello !" +``` + +The `file://` resolver is similar to the filepath-based imports we already know: +```bash +$ grace interpret - <<< 'file:///path/to/greet.ffg "John"' +``` +```dhall +"Hello, John!" +``` + ## Name Like all of my programming language projects, Grace is named after a diff --git a/grace-core/grace-core.cabal b/grace-core/grace-core.cabal index f0de6cc..40d564d 100644 --- a/grace-core/grace-core.cabal +++ b/grace-core/grace-core.cabal @@ -18,19 +18,24 @@ library , insert-ordered-containers , lens , megaparsec + , modern-uri , mtl , parser-combinators , prettyprinter , prettyprinter-ansi-terminal + , safe-exceptions , scientific , string-interpolate , template-haskell , terminal-size , text + , typed-process , unordered-containers exposed-modules: Grace.Context , Grace.Domain , Grace.Existential + , Grace.Import + , Grace.Import.Resolver , Grace.Interpret , Grace.Infer , Grace.Lexer @@ -59,6 +64,7 @@ test-suite tasty , tasty-hunit , tasty-silver , text + other-modules: Grace.Test.Resolver hs-source-dirs: tasty default-language: Haskell2010 ghc-options: -Wall diff --git a/grace-core/src/Grace/Import.hs b/grace-core/src/Grace/Import.hs new file mode 100644 index 0000000..4db0f6b --- /dev/null +++ b/grace-core/src/Grace/Import.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +{- | This module contains the functions and types that power to URI-base imports +-} + +module Grace.Import + ( Input(..) + , Resolver(..) + , resolverToCallback + , ImportError(..) + ) where + +import Control.Exception.Safe (Exception(..), throw) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) +import Grace.Location (Location) +import Grace.Pretty (Pretty(..)) +import Grace.Syntax (Syntax) +import System.FilePath (()) + +import qualified Data.Text as Text +import qualified System.FilePath as FilePath +import qualified Text.URI as URI + +{-| Input to the interpreter. + + You should prefer to use `Path` if possible (for better error messages and + correctly handling transitive imports). The `Code` constructor is intended + for cases like interpreting code read from standard input. +-} +data Input + = Path FilePath + -- ^ The path to the code + | Code String Text + -- ^ Source code: @Code name content@ + | URI URI.URI + deriving (Eq, Show) + +instance Semigroup Input where + _ <> URI uri = URI uri + + _ <> Code name code = Code name code + + Code _ _ <> Path child = Path child + Path parent <> Path child = Path (FilePath.takeDirectory parent child) + URI parent <> Path child + | FilePath.isRelative child + , Just uri <- URI.relativeTo childURI parent = + URI uri + | otherwise = + Path child + where + uriPath = do + c : cs <- traverse (URI.mkPathPiece . Text.pack) (FilePath.splitPath child) + + return (FilePath.hasTrailingPathSeparator child, c :| cs) + + childURI = + URI.URI + { URI.uriScheme = Nothing + , URI.uriAuthority = Left False + , URI.uriPath = uriPath + , URI.uriQuery = [] + , URI.uriFragment = Nothing + } + +instance Pretty Input where + pretty (Code _ code) = pretty code + pretty (Path path) = pretty path + pretty (URI uri) = pretty uri + +{- | A resolver for an URI. + + When the interpreter tries to resolve an URI pointing to some source code + it will try multiple resolvers sequentially and stops if one returns a + @Just code@ value where @code@ is the source code of an expression. + It will then try to parse and interpret that expression. + + Here are some good practices for the development of resolvers: + + * A resolver should handle exactly one URI scheme. + + * If a resolver encounters an URI which it cannot process (e.g. a + @file://@ URI is passed to a HTTP resolver) it should return @Nothing@ + as fast as possible. + + * Exceptions thrown in resolvers will be caught and rethrown as an + `ImportError` by the interpreter. +-} +newtype Resolver = Resolver + { runResolver :: Input -> IO (Maybe (Syntax Location Input)) + } + +instance Semigroup Resolver where + x <> y = Resolver \uri -> do + maybeResult <- runResolver x uri + case maybeResult of + Nothing -> runResolver y uri + _ -> return maybeResult + +instance Monoid Resolver where + mempty = Resolver (const (return Nothing)) + +-- | Convert a resolver to a callback function +resolverToCallback :: Resolver -> Input -> IO (Syntax Location Input) +resolverToCallback resolver uri = do + maybeResult <- runResolver resolver uri + case maybeResult of + Nothing -> throw UnsupportedInput + Just result -> return result + +-- | Errors that might be raised during import resolution. +data ImportError + = UnsupportedInput + deriving stock Show + +instance Exception ImportError where + displayException UnsupportedInput = "Resolving this input is not supported" diff --git a/grace-core/src/Grace/Import/Resolver.hs b/grace-core/src/Grace/Import/Resolver.hs new file mode 100644 index 0000000..df3f935 --- /dev/null +++ b/grace-core/src/Grace/Import/Resolver.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +{- | This module contains the builtin resolvers for the grace executable +-} + +module Grace.Import.Resolver + ( -- * Builtin default resolver + defaultResolver + + -- ** env:// resolver + , envResolver + , EnvResolverError(..) + + -- ** file:// resolver + , fileResolver + , FileResolverError(..) + ) where + +import Control.Exception.Safe (Exception(..), throw) +import Data.Bifunctor (first) +import Data.Foldable (foldl') +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Text (Text) +import Grace.Import (Input(..), Resolver(..)) +import Grace.Location (Location(..)) +import System.FilePath (()) +import Text.URI (Authority) + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as Text +import qualified Data.Text.IO as Text.IO +import qualified Grace.Parser as Parser +import qualified System.Environment as Environment +import qualified Text.URI as URI +import qualified Text.URI.QQ as URI.QQ + +{- | A set of default resolvers. Includes (order matters): + + * `envResolver` + * `fileResolver` +-} +defaultResolver :: Resolver +defaultResolver + = envResolver + <> fileResolver + <> codeResolver + +{- | A resolver for environment variables. + + This resolver matches URIs with the @env:@ scheme. It assumes that the + first path component is the name of the environment variable, looks it up + and expects the value to be an expression. It will then return the parsed + expression as a result. + + It will fail if the URI has an authority component, a trailing slash or + more than one path components. I.e. a valid URI looks like @env:///NAME@. +-} +envResolver :: Resolver +envResolver = Resolver \case + URI uri@URI.URI{ URI.uriScheme = Just (URI.unRText -> "env") } -> do + case URI.uriAuthority uri of + Right auth | auth /= emptyAuthority -> throw EnvInvalidURI + _ -> return () + + var <- case URI.uriPath uri of + Nothing -> throw EnvMissingVarName + Just (False, var :| []) -> return (URI.unRText var) + _ -> throw EnvInvalidURI + + code <- Environment.lookupEnv (Text.unpack var) >>= \case + Nothing -> throw (EnvVarNotFound var) + Just string -> return (Text.pack string) + + let name = "env:" <> Text.unpack var + + result <- case Parser.parse name code of + Left e -> throw e + Right result -> return result + + let locate offset = Location{..} + + return (Just (first locate result)) + _ -> return Nothing + +-- | Errors raised by `envResolver` +data EnvResolverError + = EnvInvalidURI + | EnvMissingVarName + | EnvVarNotFound Text + deriving stock Show + +instance Exception EnvResolverError where + displayException EnvInvalidURI = "Invalid URI" + displayException EnvMissingVarName = "Environment variable name is missing" + displayException (EnvVarNotFound k) = Text.unpack ("Environment variable not found: " <> k) + +{- | A resolver for files. + + This resolver matches URIs with the @file:@ scheme. The resolver takes the + path of the URI, tries to read its content and returns the parsed value as + its result. + + It will fail if the URI has an authority component. +-} +fileResolver :: Resolver +fileResolver = Resolver \case + URI uri@URI.URI{ URI.uriScheme = Just (URI.unRText -> "file") } -> do + case URI.uriAuthority uri of + Right auth | auth /= emptyAuthority -> throw FileInvalidURI + _ -> return () + + pieces <- case URI.uriPath uri of + Nothing -> throw FileMissingPath + Just (_, pieces) -> return pieces + + readPath (pathPiecesToFilePath pieces) + + Path path -> do + readPath path + + _ -> do + return Nothing + where + pathPiecesToFilePath = + foldl' () "/" . map (Text.unpack . URI.unRText) . NonEmpty.toList + + readPath path = do + code <- Text.IO.readFile path + + result <- case Parser.parse path code of + Left e -> throw e + Right result -> return result + + let locate offset = Location{ name = path, ..} + + return (Just (first locate result)) + +codeResolver :: Resolver +codeResolver = Resolver \case + Code name code -> do + result <- case Parser.parse name code of + Left e -> throw e + Right result -> return result + + let locate offset = Location{..} + + return (Just (first locate result)) + + _ -> do + return Nothing + +-- | Errors raised by `fileResolver` +data FileResolverError + = FileInvalidURI + | FileMissingPath + deriving stock Show + +instance Exception FileResolverError where + displayException FileInvalidURI = "Invalid URI" + displayException FileMissingPath = "Filepath is missing" + +-- Internal helper functions + +emptyAuthority :: Authority +emptyAuthority = URI.Authority + { URI.authUserInfo = Nothing + , URI.authHost = [URI.QQ.host||] + , URI.authPort = Nothing + } diff --git a/grace-core/src/Grace/Infer.hs b/grace-core/src/Grace/Infer.hs index 6ff0f99..3eb167c 100644 --- a/grace-core/src/Grace/Infer.hs +++ b/grace-core/src/Grace/Infer.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} @@ -37,7 +38,8 @@ module Grace.Infer import Data.Text (Text) import Control.Applicative ((<|>)) -import Control.Exception (Exception(..)) +import Control.Exception.Safe (Exception(..)) +import Control.Monad (when) import Control.Monad.Except (MonadError(..)) import Control.Monad.State.Strict (MonadState) import Data.Foldable (traverse_) @@ -97,7 +99,7 @@ push entry = State.modify (\s -> s { context = entry : context s }) -- | Retrieve the current `Context` get :: MonadState Status m => m (Context Location) -get = fmap context State.get +get = State.gets context -- | Set the `Context` to a new value set :: MonadState Status m => Context Location -> m () @@ -508,7 +510,7 @@ subtype _A0 _B0 = do -- mismatched fields present only in one record type we have to -- skip to the next step of resolving the mismatch by solving Fields -- variables. - _ <- traverse process both + traverse_ process both -- Here is where we handle fields that were only present in one -- record type. They still might be okay if one or both of the @@ -709,7 +711,7 @@ subtype _A0 _B0 = do (Context.solveType _Θ _A1) (Context.solveType _Θ _B1) - _ <- traverse process both + traverse_ process both case (alternatives0, alternatives1) of (Monotype.UnsolvedAlternatives p0, Monotype.UnsolvedAlternatives p1) -> do @@ -1213,10 +1215,8 @@ instantiateFieldsL :: (MonadState Status m, MonadError TypeInferenceError m) => Existential Monotype.Record -> Location -> Type.Record Location -> m () instantiateFieldsL p0 location r@(Type.Fields kAs rest) = do - if p0 `Type.fieldsFreeIn` Type{ node = Type.Record r, .. } - then do - throwError (NotFieldsSubtype location p0 r) - else return () + when (p0 `Type.fieldsFreeIn` Type{ node = Type.Record r, .. }) do + throwError (NotFieldsSubtype location p0 r) let process (k, _A) = do b <- fresh @@ -1257,10 +1257,8 @@ instantiateFieldsR :: (MonadState Status m, MonadError TypeInferenceError m) => Location -> Type.Record Location -> Existential Monotype.Record -> m () instantiateFieldsR location r@(Type.Fields kAs rest) p0 = do - if p0 `Type.fieldsFreeIn` Type{ node = Type.Record r, .. } - then do - throwError (NotFieldsSubtype location p0 r) - else return () + when (p0 `Type.fieldsFreeIn` Type{ node = Type.Record r, .. }) do + throwError (NotFieldsSubtype location p0 r) let process (k, _A) = do b <- fresh @@ -1328,10 +1326,8 @@ instantiateAlternativesL :: (MonadState Status m, MonadError TypeInferenceError m) => Existential Monotype.Union -> Location -> Type.Union Location -> m () instantiateAlternativesL p0 location u@(Type.Alternatives kAs rest) = do - if p0 `Type.alternativesFreeIn` Type{ node = Type.Union u, .. } - then do - throwError (NotAlternativesSubtype location p0 u) - else return () + when (p0 `Type.alternativesFreeIn` Type{ node = Type.Union u, .. }) do + throwError (NotAlternativesSubtype location p0 u) let process (k, _A) = do b <- fresh @@ -1372,10 +1368,8 @@ instantiateAlternativesR :: (MonadState Status m, MonadError TypeInferenceError m) => Location -> Type.Union Location -> Existential Monotype.Union -> m () instantiateAlternativesR location u@(Type.Alternatives kAs rest) p0 = do - if p0 `Type.alternativesFreeIn` Type{ node = Type.Union u, .. } - then do - throwError (NotAlternativesSubtype location p0 u) - else return () + when (p0 `Type.alternativesFreeIn` Type{ node = Type.Union u, .. }) do + throwError (NotAlternativesSubtype location p0 u) let process (k, _A) = do b <- fresh @@ -2138,7 +2132,7 @@ check e@Syntax{ node = Syntax.Record keyValues } _B@Type{ node = Type.Record (Ty check value (Context.solveType _Γ type_) - _ <- traverse process both + traverse_ process both let e' = Syntax diff --git a/grace-core/src/Grace/Interpret.hs b/grace-core/src/Grace/Interpret.hs index a372633..b3a83f8 100644 --- a/grace-core/src/Grace/Interpret.hs +++ b/grace-core/src/Grace/Interpret.hs @@ -1,8 +1,11 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- | This module implements the main interpretation function module Grace.Interpret @@ -15,39 +18,30 @@ module Grace.Interpret , InterpretError(..) ) where -import Control.Exception (Exception(..)) +import Control.Exception.Safe (Exception(..), Handler(..), SomeException) import Control.Monad.Except (MonadError(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Data.Bifunctor (Bifunctor(..)) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Generics.Product (the) +import Data.String.Interpolate (__i) import Data.Text (Text) +import Grace.Import (Input(..)) import Grace.Location (Location(..)) import Grace.Syntax (Node(..), Syntax(..)) import Grace.Type (Type) import Grace.Value (Value) -import System.FilePath (()) - -import qualified Control.Lens as Lens -import qualified Control.Monad.Except as Except -import qualified Data.Text.IO as Text.IO -import qualified Grace.Context as Context -import qualified Grace.Infer as Infer -import qualified Grace.Normalize as Normalize -import qualified Grace.Parser as Parser -import qualified Grace.Syntax as Syntax -import qualified System.FilePath as FilePath - -{-| Input to the `interpret` function - - You should prefer to use `Path` if possible (for better error messages and - correctly handling transitive imports). The `Code` constructor is intended - for cases like interpreting code read from standard input. --} -data Input - = Path FilePath - -- ^ The path to the code - | Code Text - -- ^ Source code + +import qualified Control.Exception.Safe as Exception +import qualified Control.Lens as Lens +import qualified Control.Monad.Except as Except +import qualified Data.Text as Text +import qualified Grace.Context as Context +import qualified Grace.Import as Import +import qualified Grace.Import.Resolver as Resolver +import qualified Grace.Infer as Infer +import qualified Grace.Normalize as Normalize +import qualified Grace.Parser as Parser +import qualified Grace.Syntax as Syntax +import qualified Text.URI as URI {-| Interpret Grace source code, return the inferred type and the evaluated result @@ -56,11 +50,9 @@ data Input -} interpret :: (MonadError InterpretError m, MonadIO m) - => Maybe (Type Location) - -- ^ Optional expected type for the input - -> Input + => Input -> m (Type Location, Value) -interpret = interpretWith [] +interpret = interpretWith [] Nothing -- | Like `interpret`, but accepts a custom list of bindings interpretWith @@ -72,31 +64,23 @@ interpretWith -> Input -> m (Type Location, Value) interpretWith bindings maybeAnnotation input = do - code <- case input of - Path file -> liftIO (Text.IO.readFile file) - Code text -> return text - - let name = case input of - Path file -> file - Code _ -> "(input)" + eitherPartiallyResolved <- do + liftIO + (Exception.catches + (fmap Right (Import.resolverToCallback Resolver.defaultResolver input)) + [ Handler (\e -> return (Left (ParseError e))) + , Handler (\e -> return (Left (ImportError input (displayException (e :: SomeException))))) + ] + ) - expression <- case Parser.parse name code of - Left message -> do - Except.throwError (ParseError message) - - Right expression -> do - let locate offset = Location{..} - - return (first locate expression) + partiallyResolved <- case eitherPartiallyResolved of + Left interpretError -> throwError interpretError + Right partiallyResolved -> return partiallyResolved - let resolve (maybeAnnotation', file) = - interpretWith bindings maybeAnnotation' (Path path) - where - path = case input of - Path parent -> FilePath.takeDirectory parent file - Code _ -> file + let process (maybeAnnotation', child) = do + interpretWith bindings maybeAnnotation' (input <> child) - resolvedExpression <- traverse resolve (annotate expression) + resolvedExpression <- traverse process (annotate partiallyResolved) let annotatedExpression = case maybeAnnotation of @@ -161,10 +145,21 @@ annotate = Lens.transform transformSyntax . fmap ((,) Nothing) -- | Errors related to interpretation of an expression data InterpretError - = TypeInferenceError Infer.TypeInferenceError + = ImportError Input String | ParseError Parser.ParseError - deriving (Eq, Show) + | TypeInferenceError Infer.TypeInferenceError + deriving stock (Eq, Show) instance Exception InterpretError where - displayException (TypeInferenceError e) = displayException e + displayException (ImportError input e) = + Text.unpack [__i| + #{renderInput} + #{e} + |] + where + renderInput = case input of + URI uri -> URI.render uri + Path path -> Text.pack path + Code _ _ -> "(input)" displayException (ParseError e) = displayException e + displayException (TypeInferenceError e) = displayException e diff --git a/grace-core/src/Grace/Lexer.hs b/grace-core/src/Grace/Lexer.hs index 0bbedd9..9931dd7 100644 --- a/grace-core/src/Grace/Lexer.hs +++ b/grace-core/src/Grace/Lexer.hs @@ -59,6 +59,7 @@ import qualified Text.Megaparsec as Megaparsec import qualified Text.Megaparsec.Char as Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as Lexer import qualified Text.Megaparsec.Error as Error +import qualified Text.URI as URI -- | Short-hand type synonym used by lexing utilities type Parser = Megaparsec.Parsec Void Text @@ -78,6 +79,7 @@ parseToken = [ -- `file` has to come before the lexer for `.` so that a file -- prefix of `.` or `..` is not lexed as a field access file + , uri , label , Combinators.choice @@ -166,7 +168,7 @@ parseToken = parseLocatedToken :: Parser LocatedToken parseLocatedToken = do - start <- fmap Offset (Megaparsec.getOffset) + start <- fmap Offset Megaparsec.getOffset token <- parseToken return LocatedToken{..} @@ -220,7 +222,23 @@ file = lexeme do suffix <- pathComponent `sepBy1` "/" - return (File (concat (map Text.unpack (prefix : List.intersperse "/" suffix)))) + return (File (concatMap Text.unpack (prefix : List.intersperse "/" suffix))) + +uri :: Parser Token +uri = do + x <- Megaparsec.lookAhead URI.parser + + let validScheme = case URI.uriScheme x of + Nothing -> False + _ -> True + + let validAuthority = case URI.uriAuthority x of + Left False -> False + _ -> True + + if validScheme && validAuthority + then lexeme (URI <$> URI.parser) + else fail "Invalid Grace URI" text :: Parser Token text = lexeme do @@ -420,6 +438,7 @@ data Token | Times | True_ | Type + | URI URI.URI deriving stock (Eq, Show) {-| A token with offset information attached, used for reporting line and diff --git a/grace-core/src/Grace/Normalize.hs b/grace-core/src/Grace/Normalize.hs index 5206f45..01269ca 100644 --- a/grace-core/src/Grace/Normalize.hs +++ b/grace-core/src/Grace/Normalize.hs @@ -2,7 +2,6 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} diff --git a/grace-core/src/Grace/Parser.hs b/grace-core/src/Grace/Parser.hs index 33b6e2f..c8d12e7 100644 --- a/grace-core/src/Grace/Parser.hs +++ b/grace-core/src/Grace/Parser.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE BlockArguments #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -27,10 +28,11 @@ module Grace.Parser import Control.Applicative (many, optional, (<|>)) import Control.Applicative.Combinators.NonEmpty (sepBy1) import Control.Applicative.Combinators (endBy, sepBy) -import Data.Functor (void) +import Data.Functor (($>), void) import Data.List.NonEmpty (NonEmpty(..), some1) import Data.Scientific (Scientific) import Data.Text (Text) +import Grace.Import (Input(..)) import Grace.Lexer (LocatedToken(LocatedToken), ParseError(ParsingFailed), Token) import Grace.Location (Location(..), Offset(..)) import Grace.Syntax (Binding(..), Syntax(..)) @@ -46,6 +48,7 @@ import qualified Grace.Monotype as Monotype import qualified Grace.Syntax as Syntax import qualified Grace.Type as Type import qualified Text.Earley as Earley +import qualified Text.URI as URI type Parser r = Prod r Text LocatedToken @@ -73,6 +76,10 @@ matchFile :: Token -> Maybe FilePath matchFile (Lexer.File f) = Just f matchFile _ = Nothing +matchURI :: Token -> Maybe URI.URI +matchURI (Lexer.URI t) = Just t +matchURI _ = Nothing + terminal :: (Token -> Maybe a) -> Parser r a terminal match = Earley.terminal match' where @@ -120,6 +127,9 @@ locatedText = locatedTerminal matchText locatedFile :: Parser r (Offset, FilePath) locatedFile = locatedTerminal matchFile +locatedURI :: Parser r (Offset, URI.URI) +locatedURI = locatedTerminal matchURI + locatedToken :: Token -> Parser r Offset locatedToken expectedToken = Earley.terminal capture render expectedToken @@ -204,8 +214,9 @@ render t = case t of Lexer.Type -> "Type" Lexer.Times -> "*" Lexer.True_ -> "True" + Lexer.URI _ -> "a URI" -grammar :: Grammar r (Parser r (Syntax Offset FilePath)) +grammar :: Grammar r (Parser r (Syntax Offset Input)) grammar = mdo expression <- rule -- The reason all of these rules use a `let f … = …` at the beginning @@ -230,6 +241,7 @@ grammar = mdo locatedName <- locatedLabel token Lexer.Arrow body <- expression + return (f lambdaOffset locatedName body) <|> do let f bindings body = Syntax{..} @@ -386,7 +398,7 @@ grammar = mdo where node = Syntax.Scalar (Syntax.Real (sign n)) - sign <- (token Lexer.Dash *> pure negate) <|> pure id + sign <- (token Lexer.Dash $> negate) <|> pure id located <- locatedReal @@ -505,12 +517,20 @@ grammar = mdo <|> do let f (location, file) = Syntax{..} where - node = Syntax.Embed file + node = Syntax.Embed (Path file) located <- locatedFile return (f located) + <|> do let f (location, uri) = Syntax{..} + where + node = Syntax.Embed (URI uri) + + located <- locatedURI + + return (f located) + <|> do token Lexer.OpenParenthesis e <- expression token Lexer.CloseParenthesis @@ -713,7 +733,7 @@ parse -- ^ Name of the input (used for error messages) -> Text -- ^ Source code - -> Either ParseError (Syntax Offset FilePath) + -> Either ParseError (Syntax Offset Input) parse name code = do tokens <- Lexer.lex name code diff --git a/grace-core/src/Grace/Pretty.hs b/grace-core/src/Grace/Pretty.hs index e164283..35d3550 100644 --- a/grace-core/src/Grace/Pretty.hs +++ b/grace-core/src/Grace/Pretty.hs @@ -32,7 +32,8 @@ import System.IO (Handle) import qualified Prettyprinter as Pretty import qualified Prettyprinter.Render.Terminal as Pretty.Terminal import qualified Prettyprinter.Render.Text as Pretty.Text -import qualified System.Console.Terminal.Size as Size +import qualified System.Console.Terminal.Size as Size +import qualified Text.URI as URI {-| Convenient wrapper around "Prettyprinter.Render.Terminal".`Pretty.Terminal.renderStrict` @@ -128,6 +129,9 @@ instance Pretty Void where instance Pretty String where pretty = Pretty.pretty +instance Pretty URI.URI where + pretty = Pretty.pretty . URI.render + instance Pretty (Doc AnsiStyle) where pretty = id diff --git a/grace-core/src/Grace/TH.hs b/grace-core/src/Grace/TH.hs index 1db19fc..ac891f0 100644 --- a/grace-core/src/Grace/TH.hs +++ b/grace-core/src/Grace/TH.hs @@ -1,3 +1,7 @@ +{- | This module provides Template Haskell functions to embed expression and + their times at compile-time. +-} + module Grace.TH ( grace @@ -60,7 +64,7 @@ grace = QuasiQuoter Syntax {location = (), node = Scalar (Text "hello")} -} expressionFromCode :: Text -> Q (TExp (Syntax () Void)) -expressionFromCode = expressionFromInput . Code +expressionFromCode = expressionFromInput . Code "(input)" -- | Like `expressionFromCode`, but takes path of a source file as input. expressionFromFile :: FilePath -> Q (TExp (Syntax () Void)) @@ -79,7 +83,7 @@ expressionFromInput = helperFunction snd Type {location = (), node = Scalar Text} -} typeOfCode :: Text -> Q (TExp (Type ())) -typeOfCode = typeOfInput . Code +typeOfCode = typeOfInput . Code "(input)" -- | Like `typeOfCode`, but takes path of a source file as input. typeOfFile :: FilePath -> Q (TExp (Type ())) @@ -93,7 +97,7 @@ typeOfInput = helperFunction fst helperFunction :: Lift r => ((Type (), Syntax () Void) -> r) -> Input -> Q (TExp r) helperFunction f input = do - eitherResult <- Except.runExceptT (Interpret.interpret Nothing input) + eitherResult <- Except.runExceptT (Interpret.interpret input) (inferred, value) <- case eitherResult of Left e -> fail (displayException e) diff --git a/grace-core/src/Grace/Type.hs b/grace-core/src/Grace/Type.hs index c1eabd6..729de14 100644 --- a/grace-core/src/Grace/Type.hs +++ b/grace-core/src/Grace/Type.hs @@ -39,6 +39,7 @@ module Grace.Type ) where import Control.Lens (Plated(..)) +import Data.Bifunctor (second) import Data.Generics.Product (the) import Data.Generics.Sum (_As) import Data.String (IsString(..)) @@ -223,9 +224,9 @@ fromMonotype monotype = Type{ location = (), node } Monotype.List τ -> List (fromMonotype τ) Monotype.Record (Monotype.Fields kτs ρ) -> - Record (Fields (map (\(k, τ) -> (k, fromMonotype τ)) kτs) ρ) + Record (Fields (map (second fromMonotype) kτs) ρ) Monotype.Union (Monotype.Alternatives kτs ρ) -> - Union (Alternatives (map (\(k, τ) -> (k, fromMonotype τ)) kτs) ρ) + Union (Alternatives (map (second fromMonotype) kτs) ρ) Monotype.Scalar scalar -> Scalar scalar @@ -321,9 +322,9 @@ substituteType a0 n _A0 Type{ node = old, .. } = Type{ node = new, .. } List _A1 -> List (substituteType a0 n _A0 _A1) Record (Fields kAs ρ) -> - Record (Fields (map (\(k, _A1) -> (k, substituteType a0 n _A0 _A1)) kAs) ρ) + Record (Fields (map (second (substituteType a0 n _A0)) kAs) ρ) Union (Alternatives kAs ρ) -> - Union (Alternatives (map (\(k, _A1) -> (k, substituteType a0 n _A0 _A1)) kAs) ρ) + Union (Alternatives (map (second (substituteType a0 n _A0)) kAs) ρ) Scalar scalar -> Scalar scalar @@ -357,13 +358,13 @@ substituteFields ρ0 n r@(Fields kτs ρ1) Type{ node = old, .. } = List (substituteFields ρ0 n r _A) Record (Fields kAs0 ρ) | VariableFields ρ0 == ρ && n == 0 -> - Record (Fields (map (\(k, _A) -> (k, substituteFields ρ0 n r _A)) kAs1) ρ1) + Record (Fields (map (second (substituteFields ρ0 n r)) kAs1) ρ1) | otherwise -> - Record (Fields (map (\(k, _A) -> (k, substituteFields ρ0 n r _A)) kAs0) ρ) + Record (Fields (map (second (substituteFields ρ0 n r)) kAs0) ρ) where - kAs1 = kAs0 <> map (\(k, τ) -> (k, fmap (\_ -> location) τ)) kτs + kAs1 = kAs0 <> map (second (fmap (const location))) kτs Union (Alternatives kAs ρ) -> - Union (Alternatives (map (\(k, _A) -> (k, substituteFields ρ0 n r _A)) kAs) ρ) + Union (Alternatives (map (second (substituteFields ρ0 n r)) kAs) ρ) Scalar scalar -> Scalar scalar @@ -396,14 +397,14 @@ substituteAlternatives ρ0 n r@(Alternatives kτs ρ1) Type{ node = old, .. } = List _A -> List (substituteAlternatives ρ0 n r _A) Record (Fields kAs ρ) -> - Record (Fields (map (\(k, _A) -> (k, substituteAlternatives ρ0 n r _A)) kAs) ρ) + Record (Fields (map (second (substituteAlternatives ρ0 n r)) kAs) ρ) Union (Alternatives kAs0 ρ) | Monotype.VariableAlternatives ρ0 == ρ && n == 0 -> - Union (Alternatives (map (\(k, _A) -> (k, substituteAlternatives ρ0 n r _A)) kAs1) ρ1) + Union (Alternatives (map (second (substituteAlternatives ρ0 n r)) kAs1) ρ1) | otherwise -> - Union (Alternatives (map (\(k, _A) -> (k, substituteAlternatives ρ0 n r _A)) kAs0) ρ) + Union (Alternatives (map (second (substituteAlternatives ρ0 n r)) kAs0) ρ) where - kAs1 = kAs0 <> map (\(k, τ) -> (k, fmap (\_ -> location) τ)) kτs + kAs1 = kAs0 <> map (second (fmap (const location))) kτs Scalar scalar -> Scalar scalar diff --git a/grace-core/tasty/Grace/Test/Resolver.hs b/grace-core/tasty/Grace/Test/Resolver.hs new file mode 100644 index 0000000..1ecb3d0 --- /dev/null +++ b/grace-core/tasty/Grace/Test/Resolver.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Grace.Test.Resolver + ( interpretCodeWithEnvURI + , interpretCodeWithFileURI + ) where + +import Grace.Interpret (Input(..), InterpretError) +import Grace.Location (Location(..)) +import Grace.Type (Type(..)) +import Test.Tasty (TestTree) + +import qualified Control.Monad.Except as Except +import qualified Data.Text as Text +import qualified Grace.Interpret as Interpret +import qualified Grace.Monotype as Monotype +import qualified Grace.Syntax as Syntax +import qualified Grace.Type as Type +import qualified Grace.Value as Value +import qualified System.Directory as Directory +import qualified System.Environment as Environment +import qualified Test.Tasty.HUnit as Tasty.HUnit + +interpret :: Input -> IO (Either InterpretError (Type Location, Value.Value)) +interpret input = Except.runExceptT (Interpret.interpret input) + +interpretCodeWithEnvURI :: TestTree +interpretCodeWithEnvURI = Tasty.HUnit.testCase "interpret code with env:// import" do + let uri = "env:///GRACE_TEST_VAR" + + Environment.setEnv "GRACE_TEST_VAR" "true" + actualValue <- interpret (Code "(input)" (Text.pack uri)) + Environment.unsetEnv "GRACE_TEST_VAR" + + let expectedValue = + Right (Type{ location, node }, Value.Scalar (Syntax.Bool True)) + where + -- TODO: Make the location match the grammar + location = Location{ name = "env:GRACE_TEST_VAR", code = "true", offset = 0 } + + node = Type.Scalar Monotype.Bool + + Tasty.HUnit.assertEqual "" expectedValue actualValue + +interpretCodeWithFileURI :: TestTree +interpretCodeWithFileURI = Tasty.HUnit.testCase "interpret code with file:// import" do + absolute <- Directory.makeAbsolute "./tasty/data/true.ffg" + + let uri = "file://" <> absolute + + actualValue <- interpret (Code "(input)" (Text.pack uri)) + + let expectedValue = + Right (Type{ location, node }, Value.Scalar (Syntax.Bool True)) + where + location = Location{ name = absolute, code = "true\n", offset = 0 } + + node = Type.Scalar Monotype.Bool + + Tasty.HUnit.assertEqual "" expectedValue actualValue diff --git a/grace-core/tasty/Main.hs b/grace-core/tasty/Main.hs index 573f679..92b026d 100644 --- a/grace-core/tasty/Main.hs +++ b/grace-core/tasty/Main.hs @@ -6,9 +6,10 @@ module Main where import Control.Exception (displayException) import Data.Text (Text) -import Grace.Interpret (Input(..)) +import Grace.Interpret (Input(..), InterpretError) import Grace.Location (Location(..)) import Grace.Pretty (Pretty(..)) +import Grace.Test.Resolver import Grace.Type (Type(..)) import System.FilePath (()) import Test.Tasty (TestTree) @@ -34,6 +35,9 @@ pretty_ x = Grace.Pretty.renderStrict False Grace.Pretty.defaultColumns (pretty x <> Pretty.hardline) +interpret :: Input -> IO (Either InterpretError (Type Location, Value.Value)) +interpret input = Except.runExceptT (Interpret.interpret input) + fileToTestTree :: FilePath -> IO TestTree fileToTestTree prefix = do let input = prefix <> "-input.ffg" @@ -43,7 +47,7 @@ fileToTestTree prefix = do let name = FilePath.takeBaseName input - eitherResult <- Except.runExceptT (Interpret.interpret Nothing (Path input)) + eitherResult <- interpret (Path input) case eitherResult of Left e -> do @@ -118,6 +122,8 @@ main = do let manualTestTree = Tasty.testGroup "Manual tests" [ interpretCode + , interpretCodeWithEnvURI + , interpretCodeWithFileURI , interpretCodeWithImport ] @@ -125,30 +131,28 @@ main = do Tasty.defaultMain tests -interpretCodeWithImport :: TestTree -interpretCodeWithImport = Tasty.HUnit.testCase "interpret code with import" do - actualValue <- Except.runExceptT (Interpret.interpret Nothing (Interpret.Code "./tasty/data/unit/plus-input.ffg")) +interpretCode :: TestTree +interpretCode = Tasty.HUnit.testCase "interpret code" do + actualValue <- interpret (Code "(input)" "2 + 2") let expectedValue = - Right (Type{ location, node }, Value.Scalar (Syntax.Natural 5)) + Right (Type{ location, node }, Value.Scalar (Syntax.Natural 4)) where - location = Location{ name = "tasty/data/unit/plus-input.ffg", code = "2 + 3\n", offset = 0 } + location = Location{ name = "(input)", code = "2 + 2", offset = 0 } node = Type.Scalar Monotype.Natural Tasty.HUnit.assertEqual "" expectedValue actualValue -interpretCode :: TestTree -interpretCode = Tasty.HUnit.testCase "interpret code with import" do - actualValue <- Except.runExceptT (Interpret.interpret Nothing (Interpret.Code "2 + 2")) +interpretCodeWithImport :: TestTree +interpretCodeWithImport = Tasty.HUnit.testCase "interpret code with import from file" do + actualValue <- interpret (Code "(input)" "./tasty/data/unit/plus-input.ffg") let expectedValue = - Right (Type{ location, node }, Value.Scalar (Syntax.Natural 4)) + Right (Type{ location, node }, Value.Scalar (Syntax.Natural 5)) where - location = Location{ name = "(input)", code = "2 + 2", offset = 0 } + location = Location{ name = "tasty/data/unit/plus-input.ffg", code = "2 + 3\n", offset = 0 } node = Type.Scalar Monotype.Natural Tasty.HUnit.assertEqual "" expectedValue actualValue - - return () diff --git a/grace-core/tasty/data/true.ffg b/grace-core/tasty/data/true.ffg new file mode 100644 index 0000000..27ba77d --- /dev/null +++ b/grace-core/tasty/data/true.ffg @@ -0,0 +1 @@ +true diff --git a/grace/grace.cabal b/grace/grace.cabal index e4d9559..54ae49b 100644 --- a/grace/grace.cabal +++ b/grace/grace.cabal @@ -12,13 +12,13 @@ library hs-source-dirs: src build-depends: base , ansi-terminal - , exceptions , grace-core , mtl , optparse-applicative , prettyprinter , prettyprinter-ansi-terminal , repline + , safe-exceptions , string-interpolate , text exposed-modules: Grace diff --git a/grace/src/Grace.hs b/grace/src/Grace.hs index c7cfb04..0c90d07 100644 --- a/grace/src/Grace.hs +++ b/grace/src/Grace.hs @@ -14,6 +14,7 @@ module Grace import Control.Applicative (many, (<|>)) import Control.Exception (Exception(..)) +import Control.Monad (void) import Data.Foldable (traverse_) import Data.String.Interpolate (__i) import Data.Void (Void) @@ -177,13 +178,12 @@ main = do Interpret{..} -> do input <- case file of "-" -> do - text <- Text.IO.getContents - return (Code text) + Code "(input)" <$> Text.IO.getContents _ -> do return (Path file) eitherResult <- do - Except.runExceptT (Interpret.interpret Nothing input) + Except.runExceptT (Interpret.interpret input) (inferred, value) <- throws eitherResult @@ -193,7 +193,7 @@ main = do | annotate = Syntax { node = - Annotation syntax (fmap (\_ -> ()) inferred) + Annotation syntax (void inferred) , location = () } | otherwise = @@ -206,9 +206,7 @@ main = do Text{..} -> do input <- case file of "-" -> do - text <- Text.IO.getContents - - return (Code text) + Code "(input)" <$> Text.IO.getContents _ -> do return (Path file) @@ -222,7 +220,7 @@ main = do let expected = Type{ node = Type.Scalar Monotype.Text, .. } eitherResult <- do - Except.runExceptT (Interpret.interpret (Just expected) input) + Except.runExceptT (Interpret.interpretWith [] (Just expected) input) (_, value) <- throws eitherResult diff --git a/grace/src/Grace/Repl.hs b/grace/src/Grace/Repl.hs index 76938f3..2455905 100644 --- a/grace/src/Grace/Repl.hs +++ b/grace/src/Grace/Repl.hs @@ -9,9 +9,8 @@ module Grace.Repl repl ) where -import Control.Monad.Catch (MonadCatch) -import Control.Exception (displayException) -import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Exception.Safe (MonadCatch, displayException) +import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.State (MonadState(..), StateT) import Data.Foldable (toList) import Data.Text (pack, strip, unpack, Text) @@ -34,7 +33,7 @@ import qualified Control.Monad.State as State import qualified Data.Text.IO as Text.IO import qualified Grace.Interpret as Interpret import qualified Grace.Normalize as Normalize -import qualified Grace.Pretty as Grace.Pretty +import qualified Grace.Pretty as Pretty import qualified System.Console.Repline as Repline import qualified System.IO as IO @@ -60,15 +59,15 @@ prompt SingleLine = return ">>> " type Status = [(Text, Type Location, Value)] -commands :: (MonadState Status m, MonadCatch m, MonadIO m) => Options m +commands :: (MonadCatch m, MonadIO m, MonadState Status m) => Options m commands = [ ("let", Repline.dontCrash . assignment) , ("type", Repline.dontCrash . infer) ] -interpret :: (MonadState Status m, MonadIO m) => Cmd m +interpret :: (MonadIO m, MonadState Status m) => Cmd m interpret string = do - let input = Code (pack string) + let input = Code "(input)" (pack string) context <- get eitherResult <- Except.runExceptT (Interpret.interpretWith context Nothing input) @@ -78,14 +77,14 @@ interpret string = do Right (_inferred, value) -> do let syntax = Normalize.quote [] value - width <- liftIO Grace.Pretty.getWidth - liftIO (Grace.Pretty.renderIO True width IO.stdout (Grace.Pretty.pretty syntax <> "\n")) + width <- liftIO Pretty.getWidth + liftIO (Pretty.renderIO True width IO.stdout (Pretty.pretty syntax <> "\n")) -assignment :: (MonadState Status m, MonadIO m) => Cmd m +assignment :: (MonadIO m, MonadState Status m) => Cmd m assignment string | (var, '=' : expr) <- break (== '=') string = do - let input = Code (pack expr) + let input = Code "(input)" (pack expr) let variable = strip (pack var) @@ -101,9 +100,9 @@ assignment string | otherwise = liftIO (putStrLn "usage: let = {expression}") -infer :: (MonadState Status m, MonadIO m) => Cmd m +infer :: (MonadIO m, MonadState Status m) => Cmd m infer expr = do - let input = Code (pack expr) + let input = Code "(input)" (pack expr) context <- get @@ -115,14 +114,13 @@ infer expr = do liftIO (Text.IO.hPutStrLn IO.stderr (pack (displayException e))) Right (type_, _) -> do - width <- liftIO Grace.Pretty.getWidth + width <- liftIO Pretty.getWidth - liftIO (Grace.Pretty.renderIO True width IO.stdout (Grace.Pretty.pretty type_ <> "\n")) + liftIO (Pretty.renderIO True width IO.stdout (Pretty.pretty type_ <> "\n")) complete :: Monad m => CompleterStyle m complete = - Combine File - (Custom (Repline.runMatcher [ (":", completeCommands) ] completeIdentifiers)) + Custom (Repline.runMatcher [ (":", completeCommands) ] completeIdentifiers) where completeCommands = Repline.listCompleter (fmap adapt (commands @(StateT Status IO)))