diff --git a/bricks.cabal b/bricks.cabal --- a/bricks.cabal +++ b/bricks.cabal @@ -1,14 +1,16 @@ --- This file has been generated from package.yaml by hpack version 0.18.1. +-- This file has been generated from package.yaml by hpack version 0.20.0. -- -- see: https://github.com/sol/hpack +-- +-- hash: edb5a78c7015968892083343d6c79fc374ae3408d793f8921575ed36fe3a3803 name: bricks -version: 0.0.0.2 +version: 0.0.0.4 synopsis: Bricks is a lazy functional language based on Nix. description: Bricks is a lazy functional language based on Nix. This package provides parsing, rendering, and - evaluation (forthcoming) for the Bricks language. + evaluation for the Bricks language. category: Language homepage: https://github.com/chris-martin/bricks#readme bug-reports: https://github.com/chris-martin/bricks/issues @@ -28,22 +30,25 @@ src ghc-options: -Wall build-depends: - base >= 4.9 && < 4.10 - , containers >= 0.5.7 && < 0.6 - , parsec >= 3.1.6 && < 3.2 - , text >= 1.2.2 && < 1.3 + base >=4.9 && <4.11 + , bricks-internal + , bricks-parsec + , bricks-rendering + , bricks-syntax + , containers >=0.5.7 && <0.6 + , mtl + , parsec >=3.1.6 && <3.2 + , text >=1.2.2 && <1.3 + , transformers exposed-modules: Bricks - Bricks.Expression - Bricks.Expression.Construction - Bricks.IndentedString - Bricks.Keyword - Bricks.Parsing - Bricks.Rendering - Bricks.UnquotedString - Bricks.Internal.Prelude - Bricks.Internal.Seq - Bricks.Internal.Text + Bricks.BuiltinFunctions + Bricks.Evaluation + Bricks.ExpressionToTerm + Bricks.Prelude + Bricks.Term + Bricks.Type + Bricks.Internal.Monad other-modules: Paths_bricks default-language: Haskell2010 @@ -55,54 +60,42 @@ test ghc-options: -Wall -threaded build-depends: - base >= 4.9 && < 4.10 - , containers >= 0.5.7 && < 0.6 - , parsec >= 3.1.6 && < 3.2 - , text >= 1.2.2 && < 1.3 - , bricks - , base >= 4.9 && < 4.10 - , doctest >= 0.11 && < 0.14 - other-modules: - Bricks.Test.Hedgehog - Bricks.Test.QQ - default-language: Haskell2010 - -test-suite parsing - type: exitcode-stdio-1.0 - main-is: parsing.hs - hs-source-dirs: - test - ghc-options: -Wall -threaded - build-depends: - base >= 4.9 && < 4.10 - , containers >= 0.5.7 && < 0.6 - , parsec >= 3.1.6 && < 3.2 - , text >= 1.2.2 && < 1.3 - , bricks - , base >= 4.9 && < 4.10 - , hedgehog >= 0.5 && < 0.6 - , template-haskell >= 2.2 && < 2.12 + base >=4.9 && <4.11 + , bricks-internal + , bricks-parsec + , bricks-rendering + , bricks-syntax + , containers >=0.5.7 && <0.6 + , doctest >=0.11 && <0.14 + , mtl + , parsec >=3.1.6 && <3.2 + , text >=1.2.2 && <1.3 + , transformers other-modules: - Bricks.Test.Hedgehog - Bricks.Test.QQ + Paths_bricks default-language: Haskell2010 -test-suite rendering +test-suite evaluation type: exitcode-stdio-1.0 - main-is: rendering.hs + main-is: evaluation.hs hs-source-dirs: test ghc-options: -Wall -threaded build-depends: - base >= 4.9 && < 4.10 - , containers >= 0.5.7 && < 0.6 - , parsec >= 3.1.6 && < 3.2 - , text >= 1.2.2 && < 1.3 + base >=4.9 && <4.11 , bricks - , base >= 4.9 && < 4.10 - , hedgehog >= 0.5 && < 0.6 - , template-haskell >= 2.2 && < 2.12 + , bricks-internal + , bricks-internal-test + , bricks-parsec + , bricks-rendering + , bricks-syntax + , containers >=0.5.7 && <0.6 + , hedgehog >=0.5 && <0.6 + , mtl + , parsec >=3.1.6 && <3.2 + , template-haskell >=2.2 && <2.13 + , text >=1.2.2 && <1.3 + , transformers other-modules: - Bricks.Test.Hedgehog - Bricks.Test.QQ + Paths_bricks default-language: Haskell2010 diff --git a/src/Bricks.hs b/src/Bricks.hs --- a/src/Bricks.hs +++ b/src/Bricks.hs @@ -1,41 +1,42 @@ -{- | __Bricks__ is a lazy functional language that strongly resembles Nix. - -Notable differences from Nix: +{- | -- No built-in null, integer, or boolean types -- No @builtins@ and no infix operators (@+@, @-@, @//@) -- No URI literals -- No escape sequences in indented strings (@''@...@''@) -- The inline comment keyword is @--@ rather than @#@ -- There are block comments in the form @{\-@...@-\}@ -- The concept of "set" is referred to as "dict" (this is not actually a language - difference, we just use a different word to talk about the same concept) +__Bricks__ is a lazy functional language that resembles +. -The following modules are re-exported from this module in their entireties: +This module serves as fairly exhaustive overview of the entire package, and +should usually serve as your go-to place to start when reading the Bricks +documentation if you want an /in-depth/ understanding of how everything works. +It is a fairly /large/ module, and probably ought to be used via a qualified +import. -- "Bricks.Expression" - Defines most of the types, notably 'Expression' -- "Bricks.IndentedString" - Deals with the whitespace cleanup performed when - parsing indented strings (@''@...@''@) -- "Bricks.Keyword" - Enumerates the language's keywords -- "Bricks.Parsing" - Defines all of the Parsec parsers for parsing Bricks code - into 'Expression's -- "Bricks.Rendering" - Defines all of the renderers for turning 'Expression's - into Bricks code -- "Bricks.UnquotedString" - Defines the rules for what strings are allowed to - appear unquoted in Bricks code +> import qualified Bricks -Other modules: +If you just want to use Bricks for common cases, look at the simple API in +"Bricks.Prelude" instead. That module is much smaller and is designed to be +imported unqualified. -- "Bricks.Expression.Construction" - Functions for constructing 'Expression's - in a way that matches their 'Show' implementations. +> import Bricks.Prelude -} module Bricks ( ------------------------------------------------- + + -- * Module overview + -- $module-overview + + ------------------------------------------------- + + -- * Differences from Nix + -- $differences-from-nix + + ------------------------------------------------- + -- * Expressions Expression (..) + , expression'source + , expression'discardSource -- ** Rendering expressions , render'expression , render'expression'listContext @@ -47,18 +48,35 @@ -- ** Parsing expressions , parse'expression , parse'expression'paren + , parse'expression'antiquote , parse'expression'dictKey -- ** Parsing lists of expressions , parse'expressionList , parse'expressionList'1 , parse'expressionList'1'noDot + ------------------------------------------------- + + -- * Variables + , Var (..) + , var'text + , render'var + , parse'var + , var'to'str'static + , var'to'str'dynamic + , var'discardSource + + ------------------------------------------------- + -- * Strings , str'escape , parse'str'within'normalQ , parse'str'escape'normalQ -- ** Static strings - , Str'Static + , Str'Static (..) + , str'static'append + , str'static'discardSource + , str'static'to'dynamic , render'strStatic'unquotedIfPossible , render'strStatic'quoted , parse'strStatic @@ -67,137 +85,452 @@ -- ** Dynamic strings , Str'Dynamic (..) , Str'1 (..) - , strDynamic'toList - , strDynamic'fromList - , strDynamic'singleton + , str'1'discardSource + , str'dynamic'append + , str'dynamic'normalize + , str'dynamic'discardSource + , str'dynamic'to'static , render'strDynamic'unquotedIfPossible , render'strDynamic'quoted - , parse'strDynamic'quoted - , parse'strDynamic'normalQ - , parse'strDynamic'indentedQ + , render'str'1 + , parse'str'dynamic -- ** Unquoted strings - , Str'Unquoted (..) - , str'tryUnquoted - , str'unquoted'orThrow - , str'canRenderUnquoted - , char'canRenderUnquoted - , render'strUnquoted + , UnquotedString + , unquotedString'try + , unquotedString'orThrow + , unquotedString'text + , text'canBeUnquoted + , char'canBeUnquoted , parse'strUnquoted - -- ** String conversions - , str'dynamicToStatic - , str'staticToDynamic - , str'unquotedToDynamic -- ** Indented strings , InStr (..) + , InStr'1 (..) + , inStr'1'toStrParts , inStr'toList - , inStr'join + , inStr'to'strDynamic , inStr'level , inStr'dedent , inStr'trim - , render'inStr'1 + , inStr'discardSource + , inStr'1'discardSource + , render'str'indented + , render'str'indented'1 , parse'inStr , parse'inStr'1 - -- ** Single line of an indented string - , InStr'1 (..) - , inStr'1'nonEmpty - , inStr'1'empty - , inStr'1'modifyLevel + ------------------------------------------------- + -- * Lists , List (..) + , list'discardSource , render'list , parse'list + ------------------------------------------------- + -- * Dicts , Dict (..) , keyword'rec + , dict'discardSource , render'dict , parse'dict , parse'dict'rec , parse'dict'noRec -- ** Dict bindings , DictBinding (..) + , dictBinding'discardSource , render'dictBinding , parse'dictBinding , parse'dictBinding'inherit , parse'dictBinding'eq -- ** Dict lookup (dot) , Dot (..) + , dot'discardSource , expression'applyDots , render'dot , parse'dot'rhs'chain + ------------------------------------------------- + -- * Functions -- ** Lambdas , Lambda (..) + , lambda'discardSource , render'lambda , parse'lambda -- ** Function parameters , Param (..) + , param'discardSource , render'param , parse'param , parse'param'var , parse'param'noVar -- ** Dict patterns , DictPattern (..) + , dictPattern'discardSource , DictPattern'1 (..) + , dictPattern'1'discardSource , render'dictPattern , render'dictPattern'1 , parse'dictPattern , parse'dictPattern'start -- ** Function application , Apply (..) + , apply'discardSource , expression'applyArgs , render'apply + ------------------------------------------------- + -- * @let@ , Let (..) + , let'discardSource , keyword'let , keyword'in , render'let , parse'let -- ** @let@ bindings , LetBinding (..) + , letBinding'discardSource , render'letBinding , parse'letBinding , parse'letBinding'eq , parse'letBinding'inherit - ------------------------------------------------- - -- * @with@ - , With (..) - , keyword'with - , render'with - , parse'with + ------------------------------------------------- + -- * @inherit@ - , Inherit (..) , keyword'inherit - , render'inherit - , parse'inherit + ------------------------------------------------- + -- * Keywords , Keyword , keywords , keywordString , keywordText , parse'keyword + ------------------------------------------------- + -- * Comments and whitespace , keyword'inlineComment , parse'spaces , parse'comment , parse'comment'inline , parse'comment'block + ------------------------------------------------- - -- * Miscellanea + + -- * Rendering , Render - , parse'antiquote + , RenderContext (..) + , renderContext'default + , renderContext'terse + ------------------------------------------------- + ) where import Bricks.Expression -import Bricks.IndentedString import Bricks.Keyword -import Bricks.Parsing +import Bricks.Parsec import Bricks.Rendering import Bricks.UnquotedString + +{- $module-overview + +== Modules that are re-exported from "Bricks" + +The following modules are re-exported from this top-level "Bricks" module in +their entireties. + +Modules related to syntax: + + - "Bricks.Keyword" - Enumerates the language's keywords + - "Bricks.UnquotedString" - Defines the rules for what strings are allowed to + appear unquoted in Bricks code + - "Bricks.Expression" - Defines most of the types related to the AST, notably + 'Expression' + - "Bricks.Parsec" - Defines all of the Parsec parsers for parsing Bricks code + into 'Expression's + - "Bricks.Rendering" - Defines all of the renderers for turning 'Expression's + into Bricks code + +Modules related to evaluation: + + - "Bricks.Term" - ... + - "Bricks.ExpressionToTerm" - ... + - "Bricks.Evaluation" - ... + +== Modules that are /not/ re-exported from "Bricks" + + - "Bricks.Expression.Construction" - Functions for constructing 'Expression's + in a way that matches their 'Show' implementations. + +-} + +{- $differences-from-nix + +Bricks is heavily based on +, +but there are a number of significant differences. Most of the differences +involve the /removal/ of some feature for the sake of simplicity in both +implementation and use. + +This list is not comprehensive. + +== Top-level Bricks expressions may contain no free variables + +There are a number of cases where variables are allowed to appear free in a +top-level Nix expression: @true@, @false@, @null@, @builtins@, and anything +within the body of a @with@ expression (sort of - we'll elaborate on that +complicated issue further below). None of those cases are present in Bricks: +__/All variables must be explicitly bound/__. + +Throughout this section we will more thoroughly address specific Nix built-in +variables and how to translate Nix expressions that use them into equivalent +Bricks code. + +== Bricks has no built-in Boolean values + +Nix has built-in @true@ and @false@ variables, a handful of operators on them +(@&&@, @||@, @!@), and an @if@-@then@-@else@ construct. + +> nix-repl> true && false +> false + +> nix-repl> true || false +> true + +> nix-repl> !true +> false + +> nix-repl> if true then "a" else "b" +> "a" + +None of these features are present in Bricks. + +__todo:__ Show how we can use the standard library instead. + +== Bricks has no built-in @null@ + +__todo:__ Show how we can use the standard library instead. + +== Bricks has no integer literals + +__todo:__ Show how we can use the standard library instead. + +== Bricks has no built-in @builtins@ + +__todo:__ Show how we can use the standard library instead. + +== Bricks has no infix operators (@+@, @-@, @//@, et cetera) + +__todo:__ Show how we can use the standard library instead. + +== Bricks has no @with@ expression + +The Nix language has a @with@ construct which introduces the contents of a dict +into the lexical scope. + +The simple reason for omitting this feature is that it can easily lead to code +that is difficult to trace. When @with@ expressions are nested, it is often +unclear where a variable has come into scope from. + +The more subtle reason not to include the @with@ construct is that it introduces +a significant departure from the lambda calulus. Consider the expression @(with +d; x)@. In this expression, is @x@ free or bound? It is neither; it exists in +some state of uncertainty where it /may or may not be/ bound, depending on the +value of @d@. + +This has a practical consequence: When you use a @with@ expression, you +sacrifice referential transparency. Consider the following Nix expression: + +> nix-repl> let v = (with { x = "a"; }; x); in (x: v) "b" +> "a" + +If we attempt to reduce this expression by replacing @v@ with its definition, + +> nix-repl> (x: (with { x = "a"; }; x)) "b" +> "b" + +then it no longer evaluates to the same value. We find this unacceptable. +Bricks avoids the problem by simply not implementing this feature. + +== Bricks allows a list on the right-hand side of the @.@ operator + +The following example is syntactically valid Nix code, but it fails to evaluate: + +> nix-repl> { x = "a"; y = "b"; }.${[ "x" "y" ]} +> error: value is a list while a string was expected + +We expand the meaning of the @.@ operator such that if the expression on the +right-hand side evaluates to a list, then the entire expression evaluates to a +list: + +> bricks-repl> { x = "a"; y = "b"; }.${[ "x" "y" ]} +> [ "a" "b" ] + +Furthermore, when the expression on the right-hand side is a list literal (an +expression of the form @[@ ... @]@), the antiquotation (wrapping the expression +in @${@ ... @}@) may be omitted: + +> bricks-repl> { x = "a"; y = "b"; }.[ "x" "y" ] +> [ "a" "b" ] + +This provides a convenient alternative to many situations in which one might use +the @with@ keyword in Nix. For example, where in Nix we might write + +> ghcWithPackages (p: with p; [ base containers text ]); + +we may write this equivalently in Bricks as + +> ghcWithPackages (p: p.[ "base" "containers" "text" ]); + +== Bricks does not have URI literals + +If a string literal is a URI, it can be written in Nix without quotes. + +We have chosen not to include this feature because it provides very little +convenience and steals some syntax from lambda expressions. Consider the +following Nix example: + +> nix-repl> (let x = "a"; in y: x) "b" +> "a" + +If we remove the space between after the colon (@:@), we get something entirely +different: + +> nix-repl> (let x = "a"; in y:x) "b" +> error: attempt to call something which is not +> a function but a string, at (string):1:1 + +Because @y:x@ contains a colon, Nix interprets it as a URI and parses it as the +string @"y:x"@ (this is the "string" to which the error message refers), rather +than as a lambda. + +In Bricks, by contrast, the colon in a lambda is /not/ required to be followed +by whitespace, and the previous example works as we would like. + +> bricks-repl> (let x = "a"; in y:x) "b" +> "a" + +== Bricks does not have path literals + +In Nix, an unquoted string that contains a slash is interpreted as a filesystem +path. + +Path literals have some subtle syntax rules. A common mistake is forgetting +to always include a slash in the path. For an example, @./foo.nix@ is a URI: + +> nix-repl> ./foo.nix +> /home/chris/foo.nix + +But @foo.nix@, without the leading @./@, is parsed differently: + +> nix-repl> foo.nix +> error: undefined variable ‘foo’ at (string):1:1 + +As with URI literals, we find that the unquoted form for paths does not provide +enough convenience to compensate for its potential for confusion, so we have +opted to omit it. + +== Bricks does not have a built-in @import@ function + +In Nix, a path literal that does not start with a slash (such as @./foo.nix@) is +interpreted as a /relative/ path, and the Nix parser immediately resolves it +with respect to the directory in which the Nix file resides (as we saw in the +example above, where it resolved to @\/home\/chris\/foo.nix@). + +We love being able to use relative imports, but we don't like needing a built-in +language feature to do it. Fortunately, Bricks can achieve the same effect by +using an ordinary function instead. + +__todo:__ Explain how imports work in the standard library, once it is +implemented. + +In doing this, we buy back some purity that Nix's @import@ lacks. By passing the +path argument through a function parameter, rather than deriving it implicitly +from the context of "which file did the expression /come from/?" we eliminate a +case where an expression's meaning depends on something other than the values of +the formal parameters that bind its free variables. + +There is another benefit to the Bricks approach: While Nix import syntax is +restricted to static paths only (the argument to @import@ cannot contain free +variables), Bricks has no such limitation. + +== Bricks uses Haskell-style comments + +The Bricks inline comment keyword is @--@; in Nix it is @#@. + +The Bricks block comment form is @{\-@ ... @-\}@; in Nix it is @/*@ ... @*/@. + +This decision was made merely due to the Bricks authors' aesthetic preference +and affinity for Haskell. + +== Bricks block comments may be nested + +Although Nix does have block comments, + +> nix-repl> /* */ "a" +> "a" + +Nix does not support /nested/ block comments: + +> nix-repl> /* /* */ */ "a" +> error: syntax error, unexpected '*', at (string):1:10 + +Bricks does: + +@ +bricks-repl> {\- {\- -\} -\} "a" +"a" +@ + +== Bricks does not support escape sequences in indented strings + +Within the indented string form (@''@ ... @''@), Nix supports the following +unorthodox escape sequences: + + - @''${@ → @${@ + - @'''@ → @''@ + - @''\\n@ → newline + - @''\\r@ → carriage return + - @''\\t@ → tab + +> nix-repl> ''ab''\ncd'' +> "ab\ncd" + +Bricks does not support any of these. If you want to include any of these +strings within an indented string, you can use antiquotation: + +> bricks-repl> ''ab${"\n"}cd'' +> "ab\ncd" + +Or you can interpret escape sequences at runtime by passing your string through +some function in the standard library that does this sort of thing (__todo:__ +discuss said function, once it exists). + +== Bricks does not allow quotes in /let/ bindings + +In Nix, the left-hand side of a /let/ binding is allowed to be a quoted string. +This lets you create variables that aren't valid as variable expressions (when +you /refer to/ a variable, it may /not/ be quoted), which puts you in a weird +sitation where there is a variable in scope which can only be referred to by +inheriting it into a dict. + +> nix-repl> let "a b" = "c"; in { inherit "a b"; } +> { "a b" = "c"; } + +This oddity does not seem to serve any real purpose, so we have omitted it. + +== The Nix "set" concept is renamed to "dict" in Bricks + +The Nix concept of "set" is referred to as "dict" in Bricks. This is not +actually a language difference; we just use a different word to talk about the +same thing. We believe that "dict" is a more familiar term for this data +structure, and that Nix's use of "set" conflicts unnecessarily with the more +common usage of the word. + +-} diff --git a/src/Bricks/BuiltinFunctions.hs b/src/Bricks/BuiltinFunctions.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/BuiltinFunctions.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Bricks.BuiltinFunctions where + +import Bricks.Term +import Bricks.Type + +-- Bricks internal +import Bricks.Internal.Prelude +import Bricks.Internal.Text (Text) +import qualified Bricks.Internal.Text as Text + +-- Containers +import qualified Data.Map as Map +import Data.Set (Set) + +-- Base +import Data.Dynamic (fromDynamic, toDyn) +import Data.Typeable (Typeable) +import Prelude (Integer, Num (..)) +import Text.Read (readMaybe) + +term'data :: forall a. Typeable a => Type a -> a -> Term +term'data (Type n) = Term'Data n . toDyn @a + +fn'pure'parametric'arity1 :: (Term -> Term) -> Term +fn'pure'parametric'arity1 f = + Term'Function $ \x -> pure $ + f x + +fn'pure'parametric'arity2 :: (Term -> Term -> Term) -> Term +fn'pure'parametric'arity2 f = + Term'Function $ \x -> pure $ + fn'pure'parametric'arity1 $ f x + +fn'pure'parametric'arity3 :: (Term -> Term -> Term -> Term) -> Term +fn'pure'parametric'arity3 f = + Term'Function $ \x -> pure $ + fn'pure'parametric'arity2 $ f x + +fn'id :: Term +fn'id = fn'pure'parametric'arity1 id + +fn'const :: Term +fn'const = fn'pure'parametric'arity2 const + +{- | Function composition, in the traditional "backwards" order. + +Read @f `fn'comp` g@ as "/f/ after /g/." -} + +fn'comp :: Term +fn'comp = fn'pure'parametric'arity3 $ \f g x -> f /@\ (g /@\ x) + +fn'flip :: Term +fn'flip = fn'pure'parametric'arity3 $ \f x y -> f /@@\ (y, x) + +fn'dict'lookup :: Term +fn'dict'lookup = + Term'Function $ \x -> do + map <- reduce'dict'keys x + pure $ Term'Function $ \y -> do + key <- cast'data type'string y + case Map.lookup key map of + Nothing -> bottom . Bottom $ "Key " <> key <> " not found in dict" + Just a -> pure a + +fn'or :: Term +fn'or = + Term'Function $ \x -> cast'data type'boolean x <&> + \case + True -> fn'const /@\ term'data type'boolean True + False -> assert'type type'boolean + +fn'and :: Term +fn'and = + Term'Function $ \x -> cast'data type'boolean x <&> + \case + False -> fn'const /@\ term'data type'boolean False + True -> assert'type type'boolean + +fn'string'append :: Term +fn'string'append = + Term'Function $ \x -> cast'data type'string x <&> \x' -> + Term'Function $ \y -> cast'data type'string y <&> \y' -> + term'data type'string (Text.append x' y') + +fn'dict'disallowExtraKeys :: Set Text -> Term +fn'dict'disallowExtraKeys _allowedKeys = + Term'Function $ undefined + +fn'dict'merge'preferLeft :: Term +fn'dict'merge'preferLeft = + Term'Function $ \x -> reduce'dict'keys x <&> \x' -> + Term'Function $ \y -> reduce'dict'keys y <&> \y' -> + Term'Dict'ReducedKeys $ Map.union x' y' + +fn'dict'merge'preferRight :: Term +fn'dict'merge'preferRight = fn'flip /@\ fn'dict'merge'preferLeft + +cast'data :: (MonadEval m, Typeable a) => Type a -> Term -> m a +cast'data = req fst + +-- | Like 'fn'id', but fails if the argument is not of the given type. +assert'type :: Typeable a => Type a -> Term +assert'type t = Term'Function $ req snd t + +req :: forall a b m. (MonadEval m, Typeable a) + => ((a, Term) -> b) + -> Type a + -> Term + -> m b +req s (Type n) = reduce'term >=> \case + t@(Term'Data n' x) -> + case fromDynamic @a x of + Nothing -> bottom . Bottom $ "Expected " <> n <> ", got " <> n' + Just a -> pure (s (a, t)) + x -> + termTypeName x >>= \n' -> + bottom . Bottom $ "Expected " <> n <> ", got " <> n' + +fn'int'add :: Term +fn'int'add = + Term'Function $ \x -> cast'data type'integer x <&> \x' -> + Term'Function $ \y -> cast'data type'integer y <&> \y' -> + term'data type'integer (x' + y') + +fn'int'constructor :: Term +fn'int'constructor = + Term'Function $ cast'data type'string >=> ( + Text.unpack >>> readMaybe @Integer >>> + maybe (bottom . Bottom $ "invalid integer") + (pure . term'data type'integer) + ) + +standard'library :: Term +standard'library = + Term'Dict'ReducedKeys . Map.fromList $ + [ ("add", fn'int'add) + , ("integer", fn'int'constructor) + , ("and", fn'and) + , ("or", fn'or) + , ("id", fn'id) + , ("const", fn'const) + ] diff --git a/src/Bricks/Evaluation.hs b/src/Bricks/Evaluation.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Evaluation.hs @@ -0,0 +1,286 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} + +{- | + +This module lets you evaluate Bricks expressions. First 'expression'to'term's +converts the abstract syntax tree ('Expression') into an enriched version of the +lambda calculus ('Term'). Then we perform /graph reduction/, repeatedly applying +simplifications until we arrive at an irreducible term. + +When we substitute an argument into a lambda body to perform beta-conversion, we +do so by substituting a 'Pointer' of the argument rather than the term itself. +This gives rise to /sharing/, thus turning the tree into a general graph, and +helps avoid reducing the same expression more than once. + += /The Implementation of Functional Programming Languages/ + +The design of Bricks evaluation is in large part based on Simon Peyton Jones's +1987 book +. +In attempt to keep the Bricks API documentation mostly self-contained, we avoid +making frequent references to this work throughout. Instead, here we give a list +of some important connections to the book: + + - The rationale for immediately converting the AST into another data structure + rather than performing any transformations directly on the AST comes from + page 38. + + - A Bricks function defined using a dict pattern turns into a + "pattern-matching lambda abstraction"; this term is introduced on page 61. + + - Page 185 introduces the style of drawing ASTs to which the '/@\' operator + alludes. + + - /Pointer substitution/ is described on page 208. + + - The implementation of 'term'substitute' closely follows the description of + /Instantiate/, page 210. + + - Page 20 introduces the name capture problem. Pages 199 and 210 discuss how + we avoid it by only reducing the top-level redex, which has no free + variables. + + - On page 233 starts the discussion of how letrec expressions are instantiated + as cyclic graphcs. + +-} +module Bricks.Evaluation where + +-- Bricks +import Bricks.BuiltinFunctions +import Bricks.Term +import Bricks.Type + +-- Bricks internal +import Bricks.Internal.Map (Map) +import qualified Bricks.Internal.Map as Map +import Bricks.Internal.Monad +import Bricks.Internal.Prelude +import Bricks.Internal.Text (Text) +import qualified Bricks.Internal.Text as Text + +-- Containers +import qualified Data.Set as Set + +-- Base +import Data.Typeable (Typeable) +import Prelude (error) +import System.IO (IO) + +newtype Eval a = Eval { unEval :: ExceptT Bottom IO a } + deriving (Functor, Applicative, Monad, MonadError Bottom, MonadIO) + +instance MonadEval Eval + where + + reduce'term :: Term -> Eval Term + reduce'term = + \case + Term'Pointer p -> + readTermPtr p >>= reduce'term + + t@(Term'Data _ _) -> pure t + t@(Term'Function _) -> pure t + t@(Term'Lambda _ _) -> pure t + t@(Term'List _) -> pure t + t@(Term'Dict _) -> pure t + t@(Term'Dict'ReducedKeys _) -> pure t + Term'Var x -> + bottom . Bottom $ "Free variable: " <> x + + Term'LetRec map body -> do + -- Create a pointer for each of the let bindings + map' <- traverse create'pointer map :: Eval (Map Text Term) + -- Substitute each of the bindings into each of the others + traverse_ (instantiate'many map') map' + -- Substitute all of the bindings into the body + instantiate'many map' body >>= reduce'term + + Term'Apply f value -> + reduce'term f >>= \case + + Term'Function f' -> + f' value >>= reduce'term + + -- The function is a lambda, so it can be applied to an argument. + Term'Lambda pattern body -> + case pattern of + + -- A simple single-variable pattern + TermPattern'Simple var -> + create'pointer value >>= \value'ptr -> + instantiate'one var value'ptr body + + -- A dict pattern + TermPattern'Dict vars -> + reduce'dict'keys value >>= \values -> + case Map.exactKeys values vars of + Left missingKeys -> bottom . Bottom $ + "Dict lookup failed: " <> + Text.show (Set.toList missingKeys) + Right values' -> instantiate'many values' body + + t -> + termTypeName t >>= \n -> + bottom . Bottom $ "Expected function, got " <> n + + reduce'dict'keys :: Term -> Eval (Map Text Term) + reduce'dict'keys = reduce'term >=> \case + Term'Dict _ -> + undefined + Term'Dict'ReducedKeys x -> + pure x + x -> + termTypeName x >>= \n' -> + bottom . Bottom $ "Expected dict, got " <> n' + +does'termPattern'bind :: Text -> TermPattern -> Bool +does'termPattern'bind n = \case + TermPattern'Simple x -> n == x + TermPattern'Dict xs -> n `Set.member` xs + +{- | @instantiate var value body@ produces a copy of the term @body@, +substituting @value@ for free occurrences of @var@. -} + +instantiate'one + :: forall m. MonadEval m + => Text -- ^ @var@ - Variable name + -> Term -- ^ @value@ - The argument being substituted. We assume that this + -- term has no free variables; or else we will suffer + -- the /name capture problem/. + -> Term -- ^ @body@ - The term being copied ("instantiated") + -> m Term + +-- The numbered comments within this definition are nearly verbatim from +-- page 210 of /The Implementation of Functional Programming Languages/. +-- There SPJ denotes this construction as body[value/var]. + +instantiate'one var value = + go + where + go :: Term -> m Term + go body = case body of + Term'Var x -> + + -- 1. If /body/ is a variable x and /var/ = x, then return /value/ + -- (here we substitute /value/ for an occurrence of /var/). + if x == var then pure value + + -- 2. If /body/ is a variable x and /var/ ≠ x, then return /body/. + else pure body + + -- 3. If /body/ is a constant or built-in function, then return /body/. + Term'Data _ _ -> pure body -- constant + Term'Function _ -> pure body -- built-in function + + -- 4. If /body/ is an application (e1 e2), then return the application + -- (e1[value/var] e2[value/var]). + Term'Apply a b -> Term'Apply <$> go a <*> go b + + Term'Lambda a b -> + -- 5. If /body/ is a lambda abstraction λx.E and /var/ = x, then return + -- /body/ - the new lambda abstraction binds /var/ anew, so no + -- substitutions should occur inside it, and hence we can avoid + -- instantiating it altogether. + if does'termPattern'bind var a then pure body + + -- 6. If /body/ is a lambda abstraction λx.E and /var/ ≠ x, then return + -- λx.E[value/var] - we must instantiate the body in case there are + -- any free occurrences of /var/ inside it. + else Term'Lambda a <$> go b + + Term'LetRec a b -> + -- The same reasoning as (5) and (6) - If the let expression binds + -- /var/, then we do nothing. Otherwise we substitute everywhere. + if Map.member var a then pure body + else Term'LetRec <$> traverse go a <*> go b + + Term'List xs -> Term'List <$> traverse go xs + + Term'Dict _ -> Term'Dict <$> undefined + + Term'Dict'ReducedKeys x -> Term'Dict'ReducedKeys <$> traverse go x + + Term'Pointer p -> go =<< readTermPtr p + -- todo - let this function return whether it made any substitutions. + -- If it didn't, then just return the pointer. + +instantiate'many + :: forall m. MonadEval m + => Map Text Term -- ^ @values@ + -> Term -- ^ @body@ + -> m Term +instantiate'many values body = + foldr f (pure body) (Map.toList values) + where + f :: (Text, Term) -> m Term -> m Term + f (var, value) bod = instantiate'one var value =<< bod + +reduce'to'type :: Typeable a => Type a -> Term -> IO (Either Bottom a) +reduce'to'type typ = + (reduce'term >=> cast'data typ) >>> unEval >>> runExceptT + +reduce'to'type'or'throw :: (HasCallStack, Typeable a) => Type a -> Term -> IO a +reduce'to'type'or'throw typ = + reduce'to'type typ >=> + either (error . Text.unpack . displayBottom) pure + +{- + -- The function is a lambda with a dict pattern. + Term'Lambda'DictPattern dp body -> + + -- Reduce the argument, and require it to be a dict. + reduce'term value >>= \case + Term'Dict dict -> undefined + x -> termTypeName x >>= \n -> evalError ("Expected dict, got " <> n) +-} + +{- + t@(Term'Pointer p) -> + (readTermPtr p >>= reduce >>= writeTermPtr p) $> t + x -> pure x +-} + +{- + case t of + + Term'Apply f x -> + create'pointer x >>= \value -> + reduce'term f >>= \case + Term'Lambda var body -> term'substitute var value body + Term'Lambda'DictPattern pattern body -> + -- Reduce the argument, and require it to be a dict. + reduce'term value >>= \case + Term'Dict dict -> undefined + -- Reduce all of the dict's keys. + + _ -> pure $ Term'Error "Expected dict, got something else" + + -- todo: + -- - + -- - fail if there are extra keys and no ellipsis + -- - fail if there are missing keys + -- - perform substitutions + _ -> pure $ Term'Error "Expected function, got something else" + + Term'Var x -> pure $ Term'Error $ + "Unbound variable: " <> render'strStatic'unquotedIfPossible x + + Term'Pointer (Pointer ref) -> do + t' <- readIORef ref + t'' <- reduce'term t' + writeIORef ref t'' + pure t'' + + _ -> pure t + +-} diff --git a/src/Bricks/Expression.hs b/src/Bricks/Expression.hs deleted file mode 100644 --- a/src/Bricks/Expression.hs +++ /dev/null @@ -1,583 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - -module Bricks.Expression - ( - -- * Expressions - Expression (..) - - -- * Strings - , Str'Static - , Str'Dynamic (..) - , Str'1 (..) - , strDynamic'toList - , strDynamic'fromList - , strDynamic'singleton - - -- * String conversions - , str'dynamicToStatic - , str'staticToDynamic - , str'unquotedToDynamic - - -- * Lists - , List (..) - - -- * Dicts - , Dict (..) - , DictBinding (..) - - -- * Dict lookup - , Dot (..) - , expression'applyDots - - -- * Lambdas - , Lambda (..) - - -- * Function parameters - , Param (..) - , DictPattern (..) - , DictPattern'1 (..) - - -- * Function application - , Apply (..) - , expression'applyArgs - - -- * @let@ - , Let (..) - , LetBinding (..) - - -- * @with@ - , With (..) - - -- * @inherit@ - , Inherit (..) - - ) where - --- Bricks -import Bricks.UnquotedString - --- Bricks internal -import Bricks.Internal.Prelude -import Bricks.Internal.Seq (Seq) -import qualified Bricks.Internal.Seq as Seq -import Bricks.Internal.Text (Text) -import qualified Bricks.Internal.Text as Text - --- Base -import Data.Foldable (Foldable) -import qualified Data.Foldable as Foldable -import Prelude (Int) - -data Expression - = Expr'Var Str'Unquoted - -- ^ A /variable/, such as @x@. - | Expr'Str Str'Dynamic - -- ^ A /string/ may be quoted either in the traditional form using a - -- single double-quote (@"@...@"@): - -- - -- > "one\ntwo" - -- - -- or in the "indented string" form using two single-quotes (@''@...@''@): - -- - -- > '' - -- > one - -- > two - -- > '' - -- - -- Both of these examples reduce to the same value, because leading - -- whitespace is stripped from indented strings. - -- - -- Either may contain "antiquotation" (also known as "string - -- interpolation") to conveniently concatenate string-valued variables - -- into the string. - -- - -- > "Hello, my name is ${name}!" - -- - -- Normal strings may contain the following escape sequences: - -- - -- - @\\\\@ → @\\@ - -- - @\\"@ → @"@ - -- - @\\${@ → @${@ - -- - @\\n@ → newline - -- - @\\r@ → carriage return - -- - @\\t@ → tab - -- - -- The indented string form does not interpret any escape sequences. - | Expr'List List - -- ^ A /list/ is an ordered collection of expressions. - -- - -- The empty list: - -- - -- > [ ] - -- - -- A list containing three variables: - -- - -- > [ a b c ] - -- - -- Lambdas, function applications, @let@-@in@ expressions, and @with@ - -- expressions must be parenthesized when in a list. - -- - -- > [ - -- > (x: f x y) - -- > (g y) - -- > (let a = y; in f a a) - -- > (with d; f x a) - -- > ] - | Expr'Dict Dict - -- ^ A /dict/ is an unordered extensional mapping from strings. - -- - -- The empty dict (with no bindings): - -- - -- > { } - -- - -- A dict with two bindings: - -- - -- > { - -- > a = "one"; - -- > b = "one two"; - -- > } - -- - -- By default, dict bindings cannot refer to each other. For that, you - -- need the @rec@ keyword to create a /recursive/ dict. - -- - -- > rec { - -- > a = "one"; - -- > b = "${a} two"; - -- > } - -- - -- In either case, the order of the bindings does not matter. - -- - -- The left-hand side of a dict binding may be a quoted string (in the - -- traditional @"@...@"@ style, not the indented-string @''@ style), - -- which make it possible for them to be strings that otherwise couldn't - -- be expressed unquoted, such as strings containing spaces: - -- - -- > { "a b" = "c"; } - -- - -- The left-hand side of a dict may even be an arbitrary expression, - -- using the @${@ ... @}@ form: - -- - -- > let x = "a b"; in { ${x} = "c"; } - -- - -- Dicts also support the @inherit@ keyword: - -- - -- > { inherit a; inherit (x) c d; } - -- - -- The previous expression is equivalent to: - -- - -- > { a = a; c = x.c; d = x.d; } - | Expr'Dot Dot - -- ^ A /dot/ expression (named after the @.@ character it contains) - -- looks up the value in a dict. - -- - -- The examples in this section all reduce to "Z". - -- - -- > { a = "Z"; }.a - -- - -- > let x = { a = "Z"; }; in x.a - -- - -- > { x = { a = "Z"; }; }.x.a - -- - -- The right-hand side of a dot may be a quoted string (in the - -- traditional @"@...@"@ style, not the indented-string @''@ style): - -- - -- > { a = "Z"; }."a" - -- - -- The right-hand side of a dot may even be an arbitrary expression, - -- using the @${@ ... @}@ form: - -- - -- > { a = "Z"; }.${ let b = "a"; in b } - | Expr'Lambda Lambda - -- ^ A /lambda/ expression @x: y@ where @x@ is the parameter. - -- - -- This is a function that turns a name into a greeting: - -- - -- > name: "Hello, ${name}!" - -- - -- The function parameter can also be a /dict pattern/, which looks like - -- this: - -- - -- > { a, b, c ? "another" }: "Hello, ${a}, ${b}, and ${c}!" - -- - -- That function accepts a dict and looks up the keys @a@, @b@, and @c@ - -- from it, applying the default value @"another"@ to @c@ if it is not - -- present in the dict. Dict patterns therefore give us something that - -- resembles functions with named parameters and default arguments. - -- - -- By default, a lambda defined with a dict pattern fails to evaluate if - -- the dict argument contains keys that are not listed in the pattern. - -- To prevent it from failing, you can end the pattern with @...@: - -- - -- > ({ a, ... }: x) { a = "1"; b = "2"; } - -- - -- Every function has a single parameter. If you need multiple - -- parameters, you have to curry: - -- - -- > a: b: [ a b ] - | Expr'Apply Apply - -- ^ Function /application/: - -- - -- > f x - -- - -- If a function has multiple (curried) parameters, you can chain them - -- together like so: - -- - -- > f x y z - | Expr'Let Let - -- ^ A /let/-/in/ expression: - -- - -- > let - -- > greet = x: "Hello, ${x}!"; - -- > name = "Chris"; - -- > in - -- > greet name - -- - -- /Let/ bindings, like dict bindings, may also use the @inherit@ keyword. - -- - -- > let - -- > d = { greet = x: "Hello, ${x}!"; name = "Chris"; } - -- > inherit (d) greet name; - -- > in - -- > greet name - -- - -- The previous example also demonstrates how the bindings in a /let/ - -- expression may refer to each other (much like a dict with the @rec@ - -- keyword). As with dicts, the order of the bindings does not matter. - | Expr'With With - -- ^ A /with/ expression is similar to a /let/-/in/ expression, but the - -- bindings come from a dict. - -- - -- > with { - -- > greet = x: "Hello, ${x}!"; - -- > name = "Chris"; - -- > }; - -- > greet name - -{- | A fixed string value. We use the description "static" to mean the string -may not contain antiquotation, in contrast with 'Str'Dynamic' which can. -} -type Str'Static = Text - -{- | A quoted string expression, which may be a simple string like @"hello"@ or -a more complex string containing antiquotation like @"Hello, my name is -${name}!"@. See 'Expr'Str'. - -We use the description "dynamic" to mean the string may contain antiquotation, -in contrast with 'Str'Static' which cannot. -} -newtype Str'Dynamic = Str'Dynamic { strDynamic'toSeq :: Seq Str'1 } - deriving (Monoid, Semigroup) - -strDynamic'toList :: Str'Dynamic -> [Str'1] -strDynamic'toList = - Seq.toList . strDynamic'toSeq - -strDynamic'fromList :: [Str'1] -> Str'Dynamic -strDynamic'fromList = - Str'Dynamic . Seq.fromList - -strDynamic'singleton :: Str'1 -> Str'Dynamic -strDynamic'singleton = - Str'Dynamic . Seq.singleton - -str'dynamicToStatic :: Str'Dynamic -> Maybe Str'Static -str'dynamicToStatic = strDynamic'toList >>> \case - [Str'1'Literal x] -> Just x - _ -> Nothing - -str'staticToDynamic :: Str'Static -> Str'Dynamic -str'staticToDynamic = - strDynamic'singleton . Str'1'Literal - -str'unquotedToDynamic :: Str'Unquoted -> Str'Dynamic -str'unquotedToDynamic = - str'staticToDynamic . str'unquotedToStatic - --- | One part of a 'Str'Dynamic'. -data Str'1 - = Str'1'Literal Str'Static - | Str'1'Antiquote Expression - --- | A function expression. See 'Expr'Lambda'. -data Lambda = - Lambda - { lambda'head :: Param - -- ^ Declaration of the function's parameter - , lambda'body :: Expression - -- ^ Body of the function; what it evaluates to - } - --- | A function application expression. See 'Expr'Apply'. -data Apply = - Apply - { apply'func :: Expression - -- ^ The function being called - , apply'arg :: Expression - -- ^ The argument to the function - } - -{- | A parameter to a 'Lambda'. All functions have a single parameter, but it's -more complicated than that because it may also include dict destructuring. -} -data Param - = Param'Name Str'Unquoted - -- ^ A simple single-parameter function - | Param'DictPattern DictPattern - -- ^ Dict destructuring, which gives you something resembling multiple - -- named parameters with default values - | Param'Both Str'Unquoted DictPattern - -- ^ Both a param name /and/ a dict pattern, separated by the @\@@ - -- keyword - --- | A type of function parameter ('Param') that does dict destructuring. -data DictPattern = - DictPattern - { dictPattern'items :: Seq DictPattern'1 - -- ^ The list of keys to pull out of the dict, along with any default - -- value each may have - , dictPattern'ellipsis :: Bool - -- ^ Whether to allow additional keys beyond what is listed in the - -- items, corresponding to the @...@ keyword - } - --- | One item within a 'DictPattern'. -data DictPattern'1 = - DictPattern'1 - { dictPattern'1'name :: Str'Unquoted - -- ^ The name of the key to pull out of the dict - , dictPattern'1'default :: Maybe Expression - -- ^ The default value to be used if the key is not present in the dict - } - -{- | A list literal expression, starting with @[@ and ending with @]@. -See 'Expr'List'. -} -newtype List = List (Seq Expression) - deriving (Monoid, Semigroup) - -{- | A dict literal expression, starting with @{@ or @rec {@ and ending with -@}@. See 'Expr'Dict'. -} -data Dict = - Dict - { dict'rec :: Bool - -- ^ Whether the dict is recursive (denoted by the @rec@ keyword) - , dict'bindings :: Seq DictBinding - -- ^ The bindings (everything between @{@ and @}@) - } - --- | A binding of the form @x = y;@ within a 'DictLiteral' or 'LetExpr'. -data DictBinding - = DictBinding'Eq Expression Expression - | DictBinding'Inherit Inherit - -{- | An expression of the form @person.name@ that looks up a key from a dict. -See 'Expr'Dot'. -} -data Dot = - Dot - { dot'dict :: Expression - , dot'key :: Expression - } - --- | A @let@-@in@ expression. See 'Expr'Let'. -data Let = - Let - { let'bindings :: Seq LetBinding - -- ^ The bindings (everything between the @let@ and @in@ keywords) - , let'value :: Expression - -- ^ The value (everything after the @in@ keyword) - } - -{- | A semicolon-terminated binding within the binding list of a 'Let' -expression. -} -data LetBinding - = LetBinding'Eq Str'Static Expression - -- ^ A binding with an equals sign, of the form @x = y;@ - | LetBinding'Inherit Inherit - -- ^ A binding using the @inherit@ keyword, of the form @inherit a b;@ - -- or @inherit (x) a b;@ - --- | A @with@ expression. See 'Expr'With'. -data With = - With - { with'context :: Expression - , with'value :: Expression - } - -data Inherit = - Inherit - { inherit'source :: Maybe Expression - , inherit'names :: Seq Str'Static - } - -expression'applyArgs - :: Expression -- ^ Function - -> [Expression] -- ^ Args - -> Expression -- ^ Function application -expression'applyArgs = - foldl (\acc b -> Expr'Apply (Apply acc b)) - -expression'applyDots - :: Expression -- ^ Dict - -> [Expression] -- ^ Lookups - -> Expression -- ^ Dot expression -expression'applyDots = - foldl (\acc b -> Expr'Dot (Dot acc b)) - --------------------------------------------------------------------------------- --- Show --------------------------------------------------------------------------------- - -{- | This instance is designed for doctests and REPL experimentation. The -format is designed to strike a balance in verbosity between the derived 'Show' -implementations (which are unwieldily long) and the Bricks language itself -(which is quite terse but unsuitable for demonstrating the parser, as -outputting a Bricks rendering of parse result wouldn't illumunate anyone's -understanding of the AST that the 'Show' instances are here to depict). -} -instance Show Expression where showsPrec = showsPrec' - -instance Show Str'Dynamic where showsPrec = showsPrec' -instance Show Str'1 where showsPrec = showsPrec' -instance Show List where showsPrec = showsPrec' -instance Show Dict where showsPrec = showsPrec' -instance Show DictBinding where showsPrec = showsPrec' -instance Show Dot where showsPrec = showsPrec' -instance Show Lambda where showsPrec = showsPrec' -instance Show Param where showsPrec = showsPrec' -instance Show DictPattern where showsPrec = showsPrec' -instance Show DictPattern'1 where showsPrec = showsPrec' -instance Show Apply where showsPrec = showsPrec' -instance Show Let where showsPrec = showsPrec' -instance Show LetBinding where showsPrec = showsPrec' -instance Show With where showsPrec = showsPrec' -instance Show Inherit where showsPrec = showsPrec' - -showsPrec' :: Show' a => Int -> a -> String -> String -showsPrec' _ x = (Text.unpack (show' x) <>) - -class Show' a - where - show' :: a -> Text - -instance Show' Expression - where - show' = \case - Expr'Var x -> show'var x - Expr'Str x -> show' x - Expr'List x -> show' x - Expr'Dict x -> show' x - Expr'Dot x -> show' x - Expr'Lambda x -> show' x - Expr'Apply x -> show' x - Expr'Let x -> show' x - Expr'With x -> show' x - -instance Show' Str'Dynamic - where - show' x = - Text.unwords ["str", show'list (strDynamic'toList x)] - -instance Show' Str'1 - where - show' = \case - Str'1'Literal x -> show'quoted' x - Str'1'Antiquote x -> Text.unwords ["antiquote", show'paren x] - -instance Show' List - where - show' (List xs) = Text.unwords ["list", show'list xs] - -instance Show' Dict - where - show' (Dict r bs) = - Text.unwords - [if r then "rec'dict" else "dict", show'list bs] - -instance Show' DictBinding - where - show' = \case - DictBinding'Eq a b -> Text.unwords ["binding", show'paren a, show'paren b] - DictBinding'Inherit x -> show' x - -instance Show' Dot - where - show' (Dot a b) = Text.unwords ["dot", show'paren a, show'paren b] - -instance Show' Lambda - where - show' (Lambda a b) = Text.unwords ["lambda", show'paren a, show'paren b] - -instance Show' Param - where - show' = \case - Param'Name a -> show'param a - Param'DictPattern b -> show' b - Param'Both a b -> Text.intercalate " <> " [ show'param a, show' b ] - -instance Show' DictPattern - where - show' = \case - DictPattern xs e -> - Text.intercalate " <> " $ - [Text.unwords ["pattern", show'list xs]] <> - (if e then ["ellipsis"] else []) - -instance Show' DictPattern'1 - where - show' (DictPattern'1 a mb) = - Text.unwords $ - show'param a : - maybe [] (\b -> [Text.unwords ["& def", show'paren b]]) mb - -instance Show' Apply - where - show' (Apply a b) = Text.unwords ["apply", show'paren a, show'paren b] - -instance Show' Let - where - show' (Let xs y) = Text.unwords ["let'in", show'list xs, show'paren y] - -instance Show' LetBinding - where - show' = \case - LetBinding'Eq a b -> Text.unwords ["binding", show'static a, show'paren b] - LetBinding'Inherit x -> show' x - -instance Show' With - where - show' = \case - With a b -> Text.unwords ["with", show'paren a, show'paren b] - -instance Show' Inherit - where - show' (Inherit mf xs) = - Text.unwords $ - (maybe ("inherit":) (\a -> ("inherit'from" :) . (show'paren a :)) mf) $ - [show'list' $ fmap show'quoted' xs] - -show'list :: (Foldable f, Show' a) => f a -> Text -show'list = - show'list' . fmap show' . Foldable.toList - -show'list' :: Foldable f => f Text -> Text -show'list' x = - "[" <> Text.intercalate ", " x <> "]" - -show'quoted' :: Text -> Text -show'quoted' = - Text.pack . show @Text - -show'paren :: Show' a => a -> Text -show'paren x = - "(" <> show' x <> ")" - -show'static :: Str'Static -> Text -show'static x = - Text.unwords ["str", show'quoted' x] - -show'param :: Str'Unquoted -> Text -show'param x = - Text.unwords ["param", show'quoted' (str'unquotedToStatic x)] - -show'var :: Str'Unquoted -> Text -show'var x = - Text.unwords ["var", show'quoted' (str'unquotedToStatic x)] diff --git a/src/Bricks/Expression/Construction.hs b/src/Bricks/Expression/Construction.hs deleted file mode 100644 --- a/src/Bricks/Expression/Construction.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NoImplicitPrelude #-} - -{- | Functions for constructing 'Expression's that match the 'Show' -implementations. - -This module is only designed for testing and REPL use. It isn't re-exported -into the main Bricks API because it's a bit messy: - -- It introduces some superfluous typeclasses for the sake of brevity. -- There are a lot of terse function names here that would clash with other - things easily. -- Some functions are partial, such as those that require strings that can be - rendered unquoted. -- It uses string overloading in a way that the regular API probably shouldn't. -- The functions are oriented toward constructing 'Expression's, skipping over - the intermediary types they're composed of, which is convenient but may make - them insufficient for some use cases. - --} -module Bricks.Expression.Construction where - --- Bricks -import Bricks.Expression -import Bricks.UnquotedString - --- Bricks internal -import Bricks.Internal.Prelude -import qualified Bricks.Internal.Seq as Seq -import Bricks.Internal.Text (Text) -import qualified Bricks.Internal.Text as Text - --- Base -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.String (IsString (fromString)) - - --------------------------------------------------------------------------------- --- Lambdas --------------------------------------------------------------------------------- - -lambda :: Param'Builder -> Expression -> Expression -lambda a b = - Expr'Lambda $ Lambda (buildParam a) b - - --------------------------------------------------------------------------------- --- Function application --------------------------------------------------------------------------------- - -apply :: Expression -> Expression -> Expression -apply a b = - Expr'Apply $ Apply a b - - --------------------------------------------------------------------------------- --- Variables --------------------------------------------------------------------------------- - -var :: Text -> Expression -var = - Expr'Var . str'unquoted'orThrow - - --------------------------------------------------------------------------------- --- Dots --------------------------------------------------------------------------------- - -dot :: Expression -> Expression -> Expression -dot a b = - Expr'Dot $ Dot a b - - --------------------------------------------------------------------------------- --- Let --------------------------------------------------------------------------------- - -let'in :: [LetBinding] -> Expression -> Expression -let'in a b = - Expr'Let $ Let (Seq.fromList a) b - - --------------------------------------------------------------------------------- --- Dicts --------------------------------------------------------------------------------- - -dict :: [DictBinding] -> Expression -dict = - Expr'Dict . Dict False . Seq.fromList - -rec'dict :: [DictBinding] -> Expression -rec'dict = - Expr'Dict . Dict False . Seq.fromList - - --------------------------------------------------------------------------------- --- Overloaded 'binding' function --------------------------------------------------------------------------------- - -class Binding a b | b -> a - where - binding :: a -> Expression -> b - -instance Binding Expression DictBinding - where - binding = DictBinding'Eq - -instance Binding Text LetBinding - where - binding = LetBinding'Eq - - --------------------------------------------------------------------------------- --- Overloaded 'inherit' functions --------------------------------------------------------------------------------- - -class IsInherit a - where - fromInherit :: Inherit -> a - -instance IsInherit DictBinding - where - fromInherit = DictBinding'Inherit - -instance IsInherit LetBinding - where - fromInherit = LetBinding'Inherit - -inherit :: IsInherit a => [Text] -> a -inherit = - fromInherit . Inherit Nothing . Seq.fromList - -inherit'from :: IsInherit a => Expression -> [Text] -> a -inherit'from x y = - fromInherit $ Inherit (Just x) (Seq.fromList y) - - --------------------------------------------------------------------------------- --- Dynamic strings --------------------------------------------------------------------------------- - -str :: [Str'1'] -> Expression -str = - Expr'Str . Str'Dynamic . Seq.fromList . fmap unStr'1' - -antiquote :: Expression -> Str'1' -antiquote = - Str'1' . Str'1'Antiquote - --- | A newtype for 'Str'1' just so we can give it the 'IsString' instance --- which would be dubiously appropriate for the actual 'Str'1' type. -newtype Str'1' = Str'1' { unStr'1' :: Str'1 } - -instance IsString Str'1' - where - fromString = Str'1' . Str'1'Literal . Text.pack - - --------------------------------------------------------------------------------- --- Overloaded 'param' function --------------------------------------------------------------------------------- - -class IsParam a - where - param :: Text -> a - -instance IsParam Param'Builder - where - param x = paramBuilder $ Param'Name $ str'unquoted'orThrow x - -instance IsParam DictPattern'1 - where - param x = DictPattern'1 (str'unquoted'orThrow x) Nothing - - --------------------------------------------------------------------------------- --- Param builder --------------------------------------------------------------------------------- - -newtype Param'Builder = Param'Builder (NonEmpty Param) - deriving Semigroup - -buildParam :: Param'Builder -> Param -buildParam (Param'Builder xs) = - foldr1 mergeParams xs - -paramBuilder :: Param -> Param'Builder -paramBuilder x = - Param'Builder (x :| []) - -pattern :: [DictPattern'1] -> Param'Builder -pattern xs = - paramBuilder $ Param'DictPattern $ DictPattern (Seq.fromList xs) False - -def :: Expression -> DictPattern'1 -> DictPattern'1 -def b (DictPattern'1 a _) = - DictPattern'1 a (Just b) - -ellipsis :: Param'Builder -ellipsis = - paramBuilder $ Param'DictPattern $ DictPattern Seq.empty True - -{- | Combine two params, merging dict patterns with 'mergeDictPatterns' and -preferring the right-hand-side when names conflict. -} -mergeParams :: Param -> Param -> Param -mergeParams = (+) - where - (+) :: Param -> Param -> Param - -- A name on the right overrides a name on the left - Param'Both _n1 p1 + Param'Name n2 = Param'Both n2 p1 - -- The simplest combinations: turning one or the other into both - Param'Name n + Param'DictPattern p = Param'Both n p - Param'DictPattern p + Param'Name n = Param'Both n p - -- Otherwise a name on the left gets overridden by anything on the right - Param'Name _n + x = x - -- Combinations that require merging the dict patterns - Param'DictPattern p1 + Param'DictPattern p2 = - Param'DictPattern (mergeDictPatterns p1 p2) - Param'DictPattern p1 + Param'Both n p2 = - Param'Both n (mergeDictPatterns p1 p2) - Param'Both _n1 p1 + Param'Both n2 p2 = - Param'Both n2 (mergeDictPatterns p1 p2) - Param'Both n p1 + Param'DictPattern p2 = - Param'Both n (mergeDictPatterns p1 p2) - -{- | Combine two dict patterns, taking the concatenation of the item list, and -the Boolean /or/ of the ellipsis flag. -} -mergeDictPatterns :: DictPattern -> DictPattern -> DictPattern -mergeDictPatterns = (+) - where - DictPattern xs1 e1 + DictPattern xs2 e2 = - DictPattern (xs1 <> xs2) (e1 || e2) diff --git a/src/Bricks/ExpressionToTerm.hs b/src/Bricks/ExpressionToTerm.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/ExpressionToTerm.hs @@ -0,0 +1,181 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | + +Conversion from 'Expression' (the AST produced by the parser) to 'Term' +(an augmented form of the lambda calculus used for evaluation). + +-} +module Bricks.ExpressionToTerm where + +-- Bricks +import Bricks.BuiltinFunctions +import Bricks.Expression +import Bricks.Term +import Bricks.Type + +-- Bricks internal +import qualified Bricks.Internal.List as List +import Bricks.Internal.Prelude +import qualified Bricks.Internal.Seq as Seq +import Bricks.Internal.Text (Text) + +-- Containers +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + +-- Base +import Control.Applicative (liftA2) +import System.IO (IO) + +expression'to'term :: Expression -> IO Term +expression'to'term = + \case + Expr'Var x -> var'to'term x + Expr'Str x -> str'to'term x + Expr'Str'Indented x -> str'to'term (inStr'to'strDynamic x) + Expr'List x -> list'to'term x + Expr'Dict x -> dict'to'term x + Expr'Dot x -> dot'to'term x + Expr'Lambda x -> lambda'to'term x + Expr'Apply x -> apply'to'term x + Expr'Let x -> let'to'term x + +var'to'term :: Var -> IO Term +var'to'term = pure . Term'Var . var'text + +apply'to'term :: Apply -> IO Term +apply'to'term x = + do + a <- expression'to'term (apply'func x) + b <- expression'to'term (apply'arg x) + pure $ a /@\ b + +str'to'term :: Str'Dynamic -> IO Term +str'to'term x = + case Seq.toList (strDynamic'toSeq x) of + [] -> pure $ term'data type'string "" + ys -> foldr1 (liftA2 f) $ fmap str'1'to'term ys + where + f a b = fn'string'append /@@\ (a, b) + +str'1'to'term :: Str'1 -> IO Term +str'1'to'term = \case + Str'1'Literal x -> pure $ term'data type'string (str'static'text x) + Str'1'Antiquote x -> expression'to'term x + +list'to'term :: List -> IO Term +list'to'term x = + Term'List <$> traverse expression'to'term (list'expressions x) + +dict'to'term :: Dict -> IO Term +dict'to'term = undefined + +dot'to'term :: Dot -> IO Term +dot'to'term x = + do + a <- expression'to'term (dot'dict x) + b <- expression'to'term (dot'key x) + pure $ fn'dict'lookup /@@\ (a, b) + +let'to'term :: Let -> IO Term +let'to'term x = + Term'LetRec <$> bindings <*> body + + where + bindings :: IO (Map Text Term) + bindings = + Map.fromList . List.concat <$> + traverse letBinding'to'term (let'bindings x) + + body :: IO Term + body = + expression'to'term $ let'value x + +letBinding'to'term :: LetBinding -> IO [(Text, Term)] +letBinding'to'term = + \case + LetBinding'Eq a b -> + do + b' <- expression'to'term b + pure [(var'text a, b')] + LetBinding'Inherit d xs -> + do + -- Use a pointer for the dict we're inheriting from, to avoid + -- having to reduce it more than once. + p <- newTermPtr =<< expression'to'term d + + pure + $ fmap (\x -> + ( var'text x + , fn'dict'lookup /@@\ (p, term'data type'string (var'text x)) + )) + $ Seq.toList xs + + +-------------------------------------------------------------------------------- +-- Converting a lambda expression to a lambda term +-------------------------------------------------------------------------------- + +lambda'to'term :: Lambda -> IO Term +lambda'to'term x = + do + body <- expression'to'term (lambda'body x) + case lambda'head x of + Param'Name var -> lambda'to'term'simple var body + Param'DictPattern dp -> lambda'to'term'dictPattern dp body + Param'Both var dp -> lambda'to'term'both var dp body + +lambda'to'term'simple :: Var -> Term -> IO Term +lambda'to'term'simple var body = + -- For a simple named parameter, the AST translates directly into the + -- lambda calculus. + pure $ TermPattern'Simple (var'text var) |-> body + +lambda'to'term'dictPattern :: DictPattern -> Term -> IO Term +lambda'to'term'dictPattern dp body = do + -- For dict patterns, we have to do a few more things: + let names = dictPattern'names dp + + -- 1. If there is no ellipsis, add a check to fail if there are + -- extra keys in the argument. + let h = if dictPattern'ellipsis dp then fn'id + else fn'dict'disallowExtraKeys names + + defs <- dictPattern'defaults dp + + -- 2. Insert a dict-merging function to apply default arguments. + let g = fn'dict'merge'preferLeft /@\ Term'Dict'ReducedKeys defs + + let f = TermPattern'Dict names |-> body + + pure $ fn'comp /@@\ (fn'comp /@@\ (f, g), h) + +lambda'to'term'both :: Var -> DictPattern -> Term -> IO Term +lambda'to'term'both var dp body = + -- For a named parameter /and/ a dict pattern, we nest the dict pattern + -- lambda inside a regular lambda. + lambda'to'term'simple var =<< lambda'to'term'dictPattern dp body + +dictPattern'names :: DictPattern -> Set Text +dictPattern'names (DictPattern xs _) = + Set.fromList . fmap f . Seq.toList $ xs + where + f = var'text . dictPattern'1'name + +dictPattern'defaults :: DictPattern -> IO (Map Text Term) +dictPattern'defaults (DictPattern xs _) = + Map.fromList . catMaybes <$> traverse f (Seq.toList xs) + where + f :: DictPattern'1 -> IO (Maybe (Text, Term)) + f x = + case dictPattern'1'default x of + Nothing -> pure Nothing + Just d -> + do + a <- expression'to'term d + pure $ Just (var'text (dictPattern'1'name x), a) diff --git a/src/Bricks/IndentedString.hs b/src/Bricks/IndentedString.hs deleted file mode 100644 --- a/src/Bricks/IndentedString.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -module Bricks.IndentedString - ( - -- * Indented string - InStr (..) - , inStr'join - , inStr'level - , inStr'dedent - , inStr'trim - , inStr'toList - - -- * Single line of an indented string - , InStr'1 (..) - , inStr'1'nonEmpty - , inStr'1'empty - , inStr'1'modifyLevel - - ) where - --- Bricks -import Bricks.Expression - --- Bricks internal -import Bricks.Internal.Prelude -import Bricks.Internal.Seq (Seq, (<|)) -import qualified Bricks.Internal.Seq as Seq -import qualified Bricks.Internal.Text as Text - -{- | An "indented string literal," delimited by two single-quotes @''@. - -This type of literal is called "indented" because the parser automatically -removes leading whitespace from the string ('inStr'dedent'), which makes it -convenient to use these literals for multi-line strings within an indented -expression without the whitespace from indentation ending up as part of the -string. -} -newtype InStr = InStr { inStr'toSeq :: Seq InStr'1 } - deriving (Monoid, Semigroup) - -instance Show InStr - where - show = show . inStr'toList - -inStr'toList :: InStr -> [InStr'1] -inStr'toList = - Seq.toList . inStr'toSeq - --- | One line of an 'InStr'. -data InStr'1 = - InStr'1 - { inStr'1'level :: Natural - -- ^ The number of leading space characters. We store this separately - -- for easier implementation of 'inStr'dedent'. - , inStr'1'str :: Str'Dynamic - -- ^ The rest of the line after any leading spaces. - } - -instance Show InStr'1 - where - show (InStr'1 n s) = "indent-" <> show n <> " " <> show s - -{- | Join 'InStr's with newlines interspersed. -} -inStr'join :: InStr -> Str'Dynamic -inStr'join xs = - Str'Dynamic . Seq.concat $ - Seq.intersperse - (Seq.singleton (Str'1'Literal "\n")) - (f <$> inStr'toSeq xs) - where - f :: InStr'1 -> Seq Str'1 - f (InStr'1 n parts) = Str'1'Literal (Text.replicate (fromIntegral n) " ") - <| strDynamic'toSeq parts - -{- | Determines whether an 'InStr'1' contains any non-space -characters. The opposite of 'inStr'1'nonEmpty'. - -This is used to determine whether this line should be considered when -calculating the number of space characters to strip in 'inStr'dedent'. -} -inStr'1'nonEmpty :: InStr'1 -> Bool -inStr'1'nonEmpty = - not . inStr'1'empty - --- | The opposite of 'inStr'1'nonEmpty'. -inStr'1'empty :: InStr'1 -> Bool -inStr'1'empty (InStr'1{ inStr'1'str = Str'Dynamic x }) = - Seq.null x - -{- | Determine how many characters of whitespace to strip from an indented -string. -} -inStr'level :: InStr -> Natural -inStr'level = - maybe 0 id - . Seq.minimum - . Seq.map inStr'1'level - . Seq.filter inStr'1'nonEmpty - . inStr'toSeq - --- | Modify an 'InStr' by applying a function to its number of leading spaces. -inStr'1'modifyLevel :: (Natural -> Natural) -> (InStr'1 -> InStr'1) -inStr'1'modifyLevel f x@InStr'1{inStr'1'level = a} = - x{ inStr'1'level = f a } - -{- | Determine the minimum indentation of any nonempty line, and remove that -many space characters from the front of every line. -} -inStr'dedent :: InStr -> InStr -inStr'dedent xs = - let - b = inStr'level xs - f a = if a >= b then a - b else 0 - in - InStr $ inStr'1'modifyLevel f <$> inStr'toSeq xs - --- | Remove any empty lines from the beginning or end of an indented string. -inStr'trim :: InStr -> InStr -inStr'trim = - InStr . trimWhile inStr'1'empty . inStr'toSeq - where - trimWhile f = Seq.dropWhileL f . Seq.dropWhileR f diff --git a/src/Bricks/Internal/Monad.hs b/src/Bricks/Internal/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Internal/Monad.hs @@ -0,0 +1,16 @@ +module Bricks.Internal.Monad + ( + -- * IO + MonadIO (..) + + -- * Error + , MonadError (..), ExceptT (..), runExceptT + + -- * Reader + , ReaderT (..) + + ) where + +-- mtl +import Control.Monad.Except +import Control.Monad.Reader diff --git a/src/Bricks/Internal/Prelude.hs b/src/Bricks/Internal/Prelude.hs deleted file mode 100644 --- a/src/Bricks/Internal/Prelude.hs +++ /dev/null @@ -1,43 +0,0 @@ -module Bricks.Internal.Prelude - - ( (<&>) - - , module Control.Applicative - , module Control.Arrow - , module Control.Monad - , module Data.Bool - , module Data.Char - , module Data.Either - , module Data.Eq - , module Data.Foldable - , module Data.Function - , module Data.Functor - , module Data.Maybe - , module Data.Monoid - , module Data.Semigroup - , module Data.String - , module Numeric.Natural - , module Text.Show - - ) where - -import Control.Applicative (pure, (*>), (<*), (<*>), (<|>)) -import Control.Arrow ((>>>)) -import Control.Monad ((>>=)) -import Data.Bool (Bool (False, True), not, (&&), (||)) -import Data.Char (Char) -import Data.Either (Either (..)) -import Data.Eq (Eq ((/=), (==))) -import Data.Foldable (asum, fold, foldMap, foldl, foldl1, foldr, foldr1) -import Data.Function (id, ($), (&), (.)) -import Data.Functor (Functor, fmap, void, ($>), (<$), (<$>)) -import Data.Maybe (Maybe (Just, Nothing), catMaybes, maybe) -import Data.Monoid (Monoid (mappend, mempty)) -import Data.Semigroup (Semigroup ((<>))) -import Data.String (String) -import Numeric.Natural (Natural) -import Text.Show (Show (show, showList, showsPrec), shows) - -(<&>) :: Functor f => f a -> (a -> b) -> f b -(<&>) = flip fmap -infixl 1 <&> diff --git a/src/Bricks/Internal/Seq.hs b/src/Bricks/Internal/Seq.hs deleted file mode 100644 --- a/src/Bricks/Internal/Seq.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Bricks.Internal.Seq - - ( Seq - - , (<|), (|>) - - , concat - , dropWhileL - , dropWhileR - , empty - , filter - , fromList - , intersperse - , map - , minimum - , null - , toList - , singleton - - ) where - --- Containers -import Data.Sequence (Seq, dropWhileL, dropWhileR, empty, filter, fromList, - null, singleton, (<|), (|>)) - --- Base -import Data.Foldable (Foldable, fold, toList) -import Data.Functor (fmap) -import qualified Data.List as List -import Data.Maybe (Maybe (..)) -import Data.Ord (Ord) - -intersperse :: a -> Seq a -> Seq a -intersperse x xs = - fromList (List.intersperse x (toList xs)) - -concat :: Foldable f => f (Seq a) -> Seq a -concat = fold - -minimum :: Ord a => Seq a -> Maybe a -minimum xs = - if null xs then Nothing else Just (List.minimum (toList xs)) - -map :: (a -> b) -> Seq a -> Seq b -map = fmap diff --git a/src/Bricks/Internal/Text.hs b/src/Bricks/Internal/Text.hs deleted file mode 100644 --- a/src/Bricks/Internal/Text.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} - -module Bricks.Internal.Text - - ( Text - - , all - , concat - , intercalate - , null - , pack - , replace - , replicate - , singleton - , unpack - , unwords - - ) where - --- Text -import Data.Text (Text, all, null, pack, replace, replicate, - singleton, unpack, unwords) -import qualified Data.Text as Text - --- Base -import Data.Foldable (Foldable, toList) -import Data.Function ((.)) - -concat :: Foldable f => f Text -> Text -concat = - Text.concat . toList - -intercalate :: Foldable f => Text -> f Text -> Text -intercalate x = - Text.intercalate x . toList diff --git a/src/Bricks/Keyword.hs b/src/Bricks/Keyword.hs deleted file mode 100644 --- a/src/Bricks/Keyword.hs +++ /dev/null @@ -1,67 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Bricks.Keyword - ( - -- * Type - Keyword - - -- * List of keywords - , keywords - - -- * The keywords - , keyword'rec - , keyword'let - , keyword'in - , keyword'with - , keyword'inherit - , keyword'inlineComment - - -- * Type conversion - , keywordString - , keywordText - - ) where - --- Bricks internal -import Bricks.Internal.Prelude -import Bricks.Internal.Text (Text) -import qualified Bricks.Internal.Text as Text - -newtype Keyword = - Keyword - { keywordText :: Text - } - -{- | All of the keywords. This list is used when parsing and rendering because -an unquoted string cannot have a name that is exactly the same as a keyword. -} -keywords :: [Keyword] -keywords = - [ keyword'rec - , keyword'let - , keyword'in - , keyword'with - , keyword'inherit - , keyword'inlineComment - ] - -keywordString :: Keyword -> String -keywordString = Text.unpack . keywordText - -keyword'rec :: Keyword -keyword'rec = Keyword "rec" - -keyword'let :: Keyword -keyword'let = Keyword "let" - -keyword'in :: Keyword -keyword'in = Keyword "in" - -keyword'with :: Keyword -keyword'with = Keyword "with" - -keyword'inherit :: Keyword -keyword'inherit = Keyword "inherit" - -keyword'inlineComment :: Keyword -keyword'inlineComment = Keyword "--" diff --git a/src/Bricks/Parsing.hs b/src/Bricks/Parsing.hs deleted file mode 100644 --- a/src/Bricks/Parsing.hs +++ /dev/null @@ -1,679 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -{- | Parsec 'Parser's for the Bricks language. - -Most parsers consume trailing whitespace, except ones that operate within -quoted string environments where whitespace is significant. - --} -module Bricks.Parsing - ( - -- * Expressions - parse'expression - , parse'expression'paren - , parse'expression'dictKey - - -- * Expression lists - , parse'expressionList - , parse'expressionList'1 - , parse'expressionList'1'noDot - - -- * Strings - , parse'strUnquoted - , parse'strStatic - , parse'strStatic'quoted - , parse'strStatic'unquoted - , parse'strDynamic'quoted - , parse'strDynamic'normalQ - , parse'strDynamic'indentedQ - , parse'str'within'normalQ - , parse'str'escape'normalQ - , parse'inStr - , parse'inStr'1 - - -- * Lists - , parse'list - - -- * Dicts - , parse'dict - , parse'dict'rec - , parse'dict'noRec - , parse'dictBinding - , parse'dictBinding'inherit - , parse'dictBinding'eq - - -- * Dict lookup - , parse'dot'rhs'chain - - -- * Lambdas - , parse'lambda - - -- * Function parameters - , parse'param - , parse'param'var - , parse'param'noVar - , parse'dictPattern - , parse'dictPattern'start - - -- * @let@ - , parse'let - , parse'letBinding - , parse'letBinding'eq - , parse'letBinding'inherit - - -- * @with@ - , parse'with - - -- * @inherit@ - , parse'inherit - - -- * Comments and whitespace - , parse'spaces - , parse'comment - , parse'comment'inline - , parse'comment'block - - -- * Keywords - , parse'keyword - - -- * Antiquotation - , parse'antiquote - - ) where - --- Bricks -import Bricks.Expression -import Bricks.IndentedString -import Bricks.Keyword -import Bricks.UnquotedString - --- Bricks internal -import Bricks.Internal.Prelude -import Bricks.Internal.Seq (Seq, (|>)) -import qualified Bricks.Internal.Seq as Seq -import Bricks.Internal.Text (Text) -import qualified Bricks.Internal.Text as Text - --- Parsec -import Text.Parsec (()) -import qualified Text.Parsec as P -import Text.Parsec.Text (Parser) - --- Base -import Control.Monad (fail) -import Prelude (succ) - -{- $setup - ->>> import Data.Foldable (length) ->>> import Text.Parsec (parseTest) - --} - -parse'spaces :: Parser () -parse'spaces = - (void $ P.many (void (P.space "") <|> parse'comment)) - -parse'comment :: Parser () -parse'comment = - parse'comment'inline <|> parse'comment'block - -parse'comment'inline :: Parser () -parse'comment'inline = - void $ P.try (P.string "--" "") *> P.manyTill P.anyChar (P.char '\n') - -parse'comment'block :: Parser () -parse'comment'block = - start <* P.manyTill middle end - where - start = void $ P.try (P.string "{-" "") - middle = parse'comment'block <|> void P.anyChar - end = P.try (P.string "-}") - --- | Backtracking parser for a particular keyword. -parse'keyword :: Keyword -> Parser () -parse'keyword k = - P.try $ do - -- Consume the keyword - _ <- P.string (keywordString k) - - -- Do /not/ consume any subsequent character that are allowed to be part - -- of a valid identifier. For example, this prevents this parser from - -- interpreting the beginning of an identifier named "letter" as the - -- keyword "let". - _ <- P.notFollowedBy (P.satisfy char'canRenderUnquoted) - - -- As usual, consume trailing spaces. - _ <- parse'spaces - - pure () - -{- | Parser for an unquoted string. Unquoted strings are restricted to a -conservative set of characters, and they may not be any of the keywords. - ->>> parseTest parse'strUnquoted "abc" -unquoted "abc" - ->>> parseTest parse'strUnquoted "x{y" -unquoted "x" - ->>> parseTest parse'strUnquoted "let" -parse error at (line 1, column 4): -unexpected end of input - --} -parse'strUnquoted :: Parser Str'Unquoted -parse'strUnquoted = - do - -- Consume at least one character - a <- Text.pack <$> P.many1 (P.satisfy char'canRenderUnquoted) - - -- Fail if what we just parsed isn't a valid unquoted string - case str'tryUnquoted a of - Nothing -> P.parserZero - Just b -> parse'spaces $> b - -{- | Parser for a static string which may be either quoted or unquoted. - ->>> parseTest parse'strStatic "\"hello\"" -"hello" - ->>> parseTest parse'strStatic "hello" -"hello" - ->>> parseTest parse'strStatic "\"a b\"" -"a b" - ->>> parseTest parse'strStatic "a b" -"a" - -By "static," we mean that the string may /not/ contain antiquotation. - ->>> parseTest parse'strStatic "\"a${x}b\" xyz" -parse error at (line 1, column 5): -antiquotation is not allowed in this context - --} -parse'strStatic :: Parser Str'Static -parse'strStatic = - (parse'strStatic'quoted <|> parse'strStatic'unquoted) "static string" - --- | Parser for a static string that is quoted. -parse'strStatic'quoted :: Parser Str'Static -parse'strStatic'quoted = - P.char '"' *> parse'str'within'normalQ <* asum - [ P.char '"' *> parse'spaces - , P.string "${" *> fail "antiquotation is not allowed in this context" - ] - --- | Parser for an unquoted static string. -parse'strStatic'unquoted :: Parser Str'Static -parse'strStatic'unquoted = - parse'strUnquoted <&> str'unquotedToStatic - -{- | Parser for a dynamic string that is quoted. It may be a "normal" quoted -string delimited by one double-quote @"@...@"@ ('parse'strDynamic'normalQ') or -an "indented" string delimited by two single-quotes @''@...@''@ -('parse'strDynamic'indentedQ'). -} -parse'strDynamic'quoted :: Parser Str'Dynamic -parse'strDynamic'quoted = - parse'strDynamic'normalQ <|> parse'strDynamic'indentedQ - --- | Parser for a dynamic string enclosed in "normal" quotes (@"@...@"@). -parse'strDynamic'normalQ :: Parser Str'Dynamic -parse'strDynamic'normalQ = - P.char '"' *> go Seq.empty - where - go :: Seq Str'1 -> Parser Str'Dynamic - go previousParts = - asum - [ end $> Str'Dynamic previousParts - , asum - [ parse'str'within'normalQ <&> Str'1'Literal - , anti - ] - >>= \x -> go $ previousParts |> x - ] - - -- Read the closing " character - end = P.char '"' *> parse'spaces - - -- Read an antiquote - anti = fmap Str'1'Antiquote $ - P.try (P.string "${") *> parse'spaces *> parse'expression <* P.char '}' - -{- | Parser for at least one normal character, within a normally-quoted string -context, up to but not including the end of the string or the start of an -antiquotation. -} -parse'str'within'normalQ :: Parser Text -parse'str'within'normalQ = do - fmap Text.concat $ P.many1 $ asum - [ P.satisfy (\c -> c /= '$' && c /= '"' && c /= '\\') <&> Text.singleton - , P.try $ P.char '$' <* P.notFollowedBy (P.char '{') <&> Text.singleton - , parse'str'escape'normalQ - ] - -parse'str'escape'normalQ :: Parser Text -parse'str'escape'normalQ = - P.char '\\' *> asum - [ P.char '\\' $> "\\" - , P.char '"' $> "\"" - , P.char 'n' $> "\n" - , P.char 'r' $> "\r" - , P.char 't' $> "\t" - , P.string "${" $> "${" - ] - -{- | Parser for a dynamic string enclosed in "indented string" format, -delimited by two single-quotes @''@...@''@. This form of string does not have -any escape sequences. -} -parse'strDynamic'indentedQ :: Parser Str'Dynamic -parse'strDynamic'indentedQ = - inStr'join . inStr'dedent . inStr'trim <$> parse'inStr - -{- | Parser for an indented string. This parser produces a representation of -the lines from the source as-is, before the whitespace is cleaned up. -} -parse'inStr :: Parser InStr -parse'inStr = - P.string "''" *> go Seq.empty - where - go :: Seq InStr'1 -> Parser InStr - go previousLines = - do - line <- parse'inStr'1 - let newLines = previousLines |> line - asum - [ P.string "''" *> parse'spaces $> InStr newLines - , P.char '\n' *> go newLines - ] - --- | Parser for a single line of an 'InStr'. -parse'inStr'1 :: Parser InStr'1 -parse'inStr'1 = - do - a <- parse'count (P.char ' ') - b <- go Seq.empty - pure $ InStr'1 a b - where - go :: Seq Str'1 -> Parser Str'Dynamic - go previousParts = - asum - [ end $> Str'Dynamic previousParts - , chars >>= \x -> go (previousParts |> x) - , parse'antiquote >>= \(Str'Dynamic xs) -> go (previousParts <> xs) - ] - - end = P.lookAhead $ asum - [ void $ P.char '\n' - , void $ P.try (P.string "''") - ] - - chars = fmap (Str'1'Literal . Text.pack) $ P.many1 $ asum - [ P.satisfy (\c -> c /= '$' && c /= '\'' && c /= '\n') - , P.try $ P.char '$' <* P.notFollowedBy (P.char '{') - , P.try $ P.char '\'' <* P.notFollowedBy (P.char '\'') - ] - -parse'antiquote :: Parser Str'Dynamic -parse'antiquote = - (P.try (P.string "${") *> parse'spaces *> parse'expression <* P.char '}') - <&> \case - Expr'Str x -> x - x -> strDynamic'singleton (Str'1'Antiquote x) - -{- | Parser for a function parameter (the beginning of a 'Lambda'), including -the colon. This forms part of 'parse'expression', so it backtracks in places -where it has overlap with other types of expressions. -} -parse'param :: Parser Param -parse'param = - parse'param'var <|> parse'param'noVar - -{- | Parser for a parameter that starts with a variable. This could be a simple -param that consists only of /only/ the variable, or the variable may be -followed by a dict pattern. -} -parse'param'var :: Parser Param -parse'param'var = do - -- This part backtracks because until we get to the : or @, we don't - -- know whether the variable name we're reading is a lambda parameter - -- or just the name by itself (and not part of a lambda). - (a, b) <- P.try $ do - a <- parse'strUnquoted <* parse'spaces - b <- ((P.char ':' $> False) <|> (P.char '@' $> True)) <* parse'spaces - pure (a, b) - if b - -- If we read an @, then the next thing is a pattern. - then parse'dictPattern <* P.char ':' <* parse'spaces <&> Param'Both a - -- Otherwise it's just the variable and we're done. - else pure $ Param'Name a - -{- | Parser for a param that has no variable, only a a dict pattern. This -parser backtracks because the beginning of a dict pattern looks like the -beginning of a dict expression. -} -parse'param'noVar :: Parser Param -parse'param'noVar = Param'DictPattern <$> do - -- First we look ahead to determine whether it looks like a lambda. - _ <- P.try . P.lookAhead $ parse'dictPattern'start - - -- And if so, then we go on and parse the dict pattern with no - -- further backtracking. - parse'dictPattern <* P.char ':' <* parse'spaces - -{- | Parser for a dict pattern (the type of lambda parameter that does dict -destructuring. This parser does not backtrack. -} -parse'dictPattern :: Parser DictPattern -parse'dictPattern = - P.char '{' *> parse'spaces *> go Seq.empty - where - go :: Seq DictPattern'1 -> Parser DictPattern - go previousItems = - asum - [ end $> DictPattern previousItems False - , ellipsis $> DictPattern previousItems True - , do - newItems <- item <&> \x -> previousItems |> x - asum - [ P.char ',' *> parse'spaces *> go newItems - , end $> DictPattern newItems False - ] - ] - - item = DictPattern'1 <$> parse'strUnquoted <*> P.optionMaybe def - - ellipsis = P.string "..." *> parse'spaces *> end - - def = P.char '?' *> parse'spaces *> parse'expression - - end = P.char '}' *> parse'spaces - -{- | This is used in a lookahead by 'parse'param' to determine whether we're -about to start parsing a 'DictPattern'. -} -parse'dictPattern'start :: Parser () -parse'dictPattern'start = - P.char '{' *> parse'spaces *> asum - [ void $ P.string "..." - , void $ P.char '}' *> parse'spaces *> P.char ':' - , void $ parse'strUnquoted *> (P.char ',' <|> P.char '?' <|> P.char '}') - ] - -{- | Parser for a lambda expression (@x: y@). - ->>> parseTest parse'lambda "x: [x x \"a\"]" -lambda (param "x") (list [var "x", var "x", str ["a"]]) - ->>> parseTest parse'lambda "{a,b}:a" -lambda (pattern [param "a", param "b"]) (var "a") - ->>> parseTest parse'lambda "{ ... }: \"x\"" -lambda (pattern [] <> ellipsis) (str ["x"]) - ->>> parseTest parse'lambda "a@{ f, b ? g x, ... }: f b" -lambda (param "a" <> pattern [param "f", param "b" & def (apply (var "g") (var "x"))] <> ellipsis) (apply (var "f") (var "b")) - ->>> parseTest parse'lambda "a: b: \"x\"" -lambda (param "a") (lambda (param "b") (str ["x"])) - --} -parse'lambda :: Parser Lambda -parse'lambda = - Lambda <$> parse'param <*> parse'expression - -{- | Parser for a list expression (@[ ... ]@). - ->>> parseTest parse'list "[]" -list [] - ->>> parseTest parse'list "[x \"one\" (a: b) (c d)]" -list [var "x", str ["one"], lambda (param "a") (var "b"), apply (var "c") (var "d")] - --} -parse'list :: Parser List -parse'list = - (start *> parse'expressionList <* end) <&> List . Seq.fromList - where - start = P.char '[' *> parse'spaces - end = P.char ']' <* parse'spaces - -{- | Parser for a dict expression, either recursive (@rec@ keyword) or not. - ->>> parseTest parse'dict "{}" -dict [] - ->>> parseTest parse'dict "rec { }" -rec'dict [] - ->>> parseTest parse'dict "{ a = b; inherit (x) y z \"s t\"; }" -dict [binding (str ["a"]) (var "b"), inherit'from (var "x") ["y", "z", "s t"]] - --} -parse'dict :: Parser Dict -parse'dict = - asum - [ parse'dict'noRec <&> Dict False - , parse'dict'rec <&> Dict True - ] - -{- | Parser for a recursive (@rec@ keyword) dict. - ->>> parseTest parse'dict "rec { }" -rec'dict [] - ->>> parseTest parse'dict "rec { a = \"1\"; b = \"${a}2\"; }" -rec'dict [binding (str ["a"]) (str ["1"]), binding (str ["b"]) (str [antiquote (var "a"), "2"])] - --} -parse'dict'rec :: Parser (Seq DictBinding) -parse'dict'rec = - parse'keyword keyword'rec *> parse'dict'noRec - -{- | Parser for a non-recursive (no @rec@ keyword) dict. - ->>> parseTest parse'dict "{ }" -dict [] - ->>> parseTest parse'dict "{ a = \"1\"; b = \"${a}2\"; }" -dict [binding (str ["a"]) (str ["1"]), binding (str ["b"]) (str [antiquote (var "a"), "2"])] - --} -parse'dict'noRec :: Parser (Seq DictBinding) -parse'dict'noRec = - P.char '{' *> parse'spaces *> go Seq.empty - where - go :: Seq DictBinding -> Parser (Seq DictBinding) - go previousBindings = asum - [ P.char '}' *> parse'spaces $> previousBindings - , parse'dictBinding >>= \a -> go (previousBindings |> a) - ] - -{- | Parser for a chain of dict lookups (like @.a.b.c@) on the right-hand side -of a 'Dot' expression. - ->>> parseTest parse'dot'rhs'chain "" -[] - ->>> parseTest parse'dot'rhs'chain ".abc" -[str ["abc"]] - ->>> parseTest parse'dot'rhs'chain ".a.${b}.\"c\".\"d${e}\"" -[str ["a"],var "b",str ["c"],str ["d", antiquote (var "e")]] - --} -parse'dot'rhs'chain :: Parser [Expression] -parse'dot'rhs'chain = - P.many $ - P.char '.' *> parse'spaces *> parse'expression'dictKey <* parse'spaces - -parse'let :: Parser Let -parse'let = - parse'keyword keyword'let *> go Seq.empty - where - go :: Seq LetBinding -> Parser Let - go previousBindings = - asum - [ end <&> Let previousBindings - , parse'letBinding >>= \a -> go (previousBindings |> a) - ] - - end = parse'keyword keyword'in *> parse'expression - -parse'with :: Parser With -parse'with = - With - <$> (parse'keyword keyword'with *> parse'expression) - <*> (P.char ';' *> parse'spaces *> parse'expression) - -parse'dictBinding :: Parser DictBinding -parse'dictBinding = - parse'dictBinding'inherit <|> parse'dictBinding'eq - -parse'dictBinding'inherit :: Parser DictBinding -parse'dictBinding'inherit = - DictBinding'Inherit <$> parse'inherit - -parse'dictBinding'eq :: Parser DictBinding -parse'dictBinding'eq = - DictBinding'Eq - <$> (parse'expression'dictKey <* parse'spaces <* P.char '=' <* parse'spaces) - <*> (parse'expression <* parse'spaces <* P.char ';' <* parse'spaces) - -parse'letBinding :: Parser LetBinding -parse'letBinding = - parse'letBinding'inherit <|> parse'letBinding'eq - -parse'letBinding'eq :: Parser LetBinding -parse'letBinding'eq = - LetBinding'Eq - <$> (parse'strStatic <* parse'spaces <* P.char '=' <* parse'spaces) - <*> (parse'expression <* parse'spaces <* P.char ';' <* parse'spaces) - -parse'letBinding'inherit :: Parser LetBinding -parse'letBinding'inherit = - LetBinding'Inherit <$> parse'inherit - -parse'inherit :: Parser Inherit -parse'inherit = - Inherit - <$> (parse'keyword keyword'inherit *> P.optionMaybe parse'expression'paren) - <*> go Seq.empty - where - go :: Seq Str'Static -> Parser (Seq Str'Static) - go previousList = - asum - [ P.char ';' *> parse'spaces $> previousList - , parse'strStatic >>= \x -> go (previousList |> x) - ] - -{- | The primary, top-level expression parser. This is what you use to parse a -@.nix@ file. - ->>> parseTest parse'expression "" -parse error at (line 1, column 1): -unexpected end of input -expecting expression - --} -parse'expression :: Parser Expression -parse'expression = - p "expression" - where - p = asum - [ parse'let <&> Expr'Let - , parse'with <&> Expr'With - , parse'lambda <&> Expr'Lambda - , parse'expressionList >>= \case - [] -> P.parserZero - f : args -> pure $ expression'applyArgs f args - ] - -{- | Parser for a list of expressions in a list literal (@[ x y z ]@) or in a -chain of function arguments (@f x y z@). - ->>> parseTest parse'expressionList "" -[] - ->>> parseTest (length <$> parse'expressionList) "x \"one two\" (a: b) (c d)" -4 - ->>> parseTest (length <$> parse'expressionList) "(x \"one two\" (a: b) (c d))" -1 - --} -parse'expressionList :: Parser [Expression] -parse'expressionList = - P.many parse'expressionList'1 "expression list" - -{- | Parser for a single item within an expression list ('expressionListP'). -This expression is not a lambda, a function application, a @let@-@in@ -expression, or a @with@ expression. - ->>> parseTest parse'expressionList'1 "ab.xy" -dot (var "ab") (str ["xy"]) - ->>> parseTest parse'expressionList'1 "(x: f x x) y z" -lambda (param "x") (apply (apply (var "f") (var "x")) (var "x")) - ->>> parseTest parse'expressionList'1 "{ a = b; }.a y" -dot (dict [binding (str ["a"]) (var "b")]) (str ["a"]) - --} -parse'expressionList'1 :: Parser Expression -parse'expressionList'1 = - expression'applyDots - <$> parse'expressionList'1'noDot - <*> parse'dot'rhs'chain - "expression list item" - -{- | Like 'parse'expressionList'1', but with the further restriction that the -expression may not be a 'Dot'. - ->>> parseTest parse'expressionList'1'noDot "ab.xy" -var "ab" - ->>> parseTest parse'expressionList'1'noDot "(x: f x x) y z" -lambda (param "x") (apply (apply (var "f") (var "x")) (var "x")) - ->>> parseTest parse'expressionList'1'noDot "{ a = b; }.a y" -dict [binding (str ["a"]) (var "b")] - --} -parse'expressionList'1'noDot :: Parser Expression -parse'expressionList'1'noDot = - asum - [ parse'strDynamic'quoted <&> Expr'Str - , parse'list <&> Expr'List - , parse'dict <&> Expr'Dict - , parse'strUnquoted <&> Expr'Var - , parse'expression'paren - ] - "expression list item without a dot" - -{- | Parser for a parenthesized expression, from opening parenthesis to closing -parenthesis. -} -parse'expression'paren :: Parser Expression -parse'expression'paren = - P.char '(' *> parse'spaces *> parse'expression <* P.char ')' <* parse'spaces - -{- | Parser for an expression in a context that is expecting a dict key. - -One of: - -- an unquoted string -- a quoted dynamic string -- an arbitrary expression wrapped in antiquotes (@${@...@}@) - --} -parse'expression'dictKey :: Parser Expression -parse'expression'dictKey = - asum - [ parse'strDynamic'quoted <&> Expr'Str - , P.string "${" *> parse'spaces *> parse'expression - <* P.char '}' <* parse'spaces - , parse'strUnquoted <&> Expr'Str . str'unquotedToDynamic - ] - -parse'count :: Parser a -> Parser Natural -parse'count p = go 0 - where - go :: Natural -> Parser Natural - go n = (p *> go (succ n)) <|> pure n diff --git a/src/Bricks/Prelude.hs b/src/Bricks/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Prelude.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Bricks.Prelude + ( bricks'eval + , bricks'eval'stdlib + ) where + +-- Bricks +import Bricks +import Bricks.BuiltinFunctions +import Bricks.Evaluation +import Bricks.ExpressionToTerm +import Bricks.Term +import Bricks.Type + +-- Bricks internal +import Bricks.Internal.Prelude +import Bricks.Internal.Text (Text) + +-- Parsec +import qualified Text.Parsec as P + +-- Base +import Data.Typeable (Typeable) + +bricks'eval :: (HasCallStack, Typeable a) => Type a -> Text -> IO a +bricks'eval typ src = + do + term <- source'to'term src + reduce'to'type'or'throw typ term + +bricks'eval'stdlib :: (HasCallStack, Typeable a) => Type a -> Text -> IO a +bricks'eval'stdlib typ src = + do + term <- source'to'term src + reduce'to'type'or'throw typ (term /@\ standard'library) + +source'to'term :: HasCallStack => Text -> IO Term +source'to'term src = + do + expr <- either (error . show) pure (P.parse parse'expression "" src) + expression'to'term expr diff --git a/src/Bricks/Rendering.hs b/src/Bricks/Rendering.hs deleted file mode 100644 --- a/src/Bricks/Rendering.hs +++ /dev/null @@ -1,281 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Bricks.Rendering - ( - -- * @Render@ - Render - - -- * Expressions - , render'expression - , render'expression'listContext - , render'expression'dotLeftContext - , render'expression'applyLeftContext - , render'expression'applyRightContext - , render'expression'inParens - , render'expression'dictKey - - -- * Strings - , str'escape - , render'strUnquoted - , render'strStatic'unquotedIfPossible - , render'strStatic'quoted - , render'strDynamic'unquotedIfPossible - , render'strDynamic'quoted - , render'inStr'1 - - -- * Lists - , render'list - - -- * Dicts - , render'dict - , render'dictBinding - - -- * Dict lookup - , render'dot - - -- * Lambdas - , render'lambda - - -- * Function parameters - , render'param - , render'dictPattern - , render'dictPattern'1 - - -- * Function application - , render'apply - - -- * @let@ - , render'let - , render'letBinding - - -- * @with@ - , render'with - - -- * @inherit@ - , render'inherit - - ) where - --- Bricks -import Bricks.Expression -import Bricks.IndentedString -import Bricks.Keyword -import Bricks.UnquotedString - --- Bricks internal -import Bricks.Internal.Prelude -import qualified Bricks.Internal.Seq as Seq -import Bricks.Internal.Text (Text) -import qualified Bricks.Internal.Text as Text - --- Base -import Prelude (fromIntegral) - -type Render a = a -> Text - --- | Insert escape sequences for rendering normal double-quoted (@"@) strings. -str'escape :: Text -> Text -str'escape = - Text.replace "\"" "\\\"" . - Text.replace "${" "\\${" . - Text.replace "\n" "\\n" . - Text.replace "\r" "\\r" . - Text.replace "\t" "\\t" . - Text.replace "\\" "\\\\" - --- | Render an unquoted string in unquoted form. -render'strUnquoted :: Render Str'Unquoted -render'strUnquoted = str'unquotedToStatic - --- | Render a static string, in unquoted form if possible. -render'strStatic'unquotedIfPossible :: Render Str'Static -render'strStatic'unquotedIfPossible x = - if str'canRenderUnquoted x then x else render'strStatic'quoted x - --- | Render a static string, in quoted form. -render'strStatic'quoted :: Render Str'Static -render'strStatic'quoted x = - "\"" <> str'escape x <> "\"" - --- | Render a dynamic string, in unquoted form if possible. -render'strDynamic'unquotedIfPossible :: Render Str'Dynamic -render'strDynamic'unquotedIfPossible d = - case str'dynamicToStatic d of - Just s -> render'strStatic'unquotedIfPossible s - Nothing -> render'strDynamic'quoted d - --- | Render a dynamic string, in quoted form. -render'strDynamic'quoted :: Render Str'Dynamic -render'strDynamic'quoted xs = - "\"" <> foldMap r (strDynamic'toSeq xs) <> "\"" - where - r = \case - Str'1'Literal x -> str'escape x - Str'1'Antiquote x -> "${" <> render'expression x <> "}" - --- | Render one line of an indented string ('InStr'). -render'inStr'1 :: Render InStr'1 -render'inStr'1 (InStr'1 n xs) = - Text.replicate (fromIntegral n) " " <> foldMap r (strDynamic'toSeq xs) - where - r = \case - Str'1'Literal x -> x - Str'1'Antiquote x -> "${" <> render'expression x <> "}" - --- | Render a lambda parameter: everything from the beginning of a lambda, up --- to but not including the @:@ that separates the head from the body of the --- lambda. -render'param :: Render Param -render'param = - \case - Param'Name a -> render'strUnquoted a - Param'DictPattern b -> render'dictPattern b - Param'Both a b -> render'strUnquoted a <> "@" <> - render'dictPattern b - --- | Render a dict pattern (@{ a, b ? c, ... }@). -render'dictPattern :: Render DictPattern -render'dictPattern (DictPattern bs e) = - if Seq.null xs - then "{ }" - else "{ " <> Text.intercalate ", " xs <> " }" - where - xs = - Seq.map render'dictPattern'1 bs <> - if e then Seq.singleton "..." else Seq.empty - --- | Render a single item in a 'DictPattern'. -render'dictPattern'1 :: Render DictPattern'1 -render'dictPattern'1 = - \case - DictPattern'1 a Nothing -> render'strUnquoted a - DictPattern'1 a (Just b) -> render'strUnquoted a <> " ? " <> render'expression b - --- | Render a lambda expression (@x: y@). -render'lambda :: Render Lambda -render'lambda (Lambda a b) = - render'param a <> ": " <> render'expression b - --- | Render a function application expression (@f x@). -render'apply :: Render Apply -render'apply (Apply a b) = - render'expression'applyLeftContext a <> " " <> - render'expression'applyRightContext b - --- | Render a list literal (@[ ... ]@). -render'list :: Render List -render'list (List xs) = - "[ " <> r xs <> "]" - where - r = Text.concat . fmap (\x -> render'expression'listContext x <> " ") - --- | Render a dict literal (@{ ... }@). -render'dict :: Render Dict -render'dict = - \case - Dict False bs -> "{ " <> r bs <> "}" - Dict True bs -> "rec { " <> r bs <> "}" - where - r = Text.concat . fmap (\b -> render'dictBinding b <> "; ") - --- | Render a binding within a 'Dict', without the trailing semicolon. -render'dictBinding :: Render DictBinding -render'dictBinding = - \case - DictBinding'Eq a b -> - render'expression'dictKey a <> " = " <> render'expression b - DictBinding'Inherit x -> - render'inherit x - --- | Render a dot expression (@a.b@). -render'dot :: Render Dot -render'dot (Dot a b) = - render'expression'dotLeftContext a <> "." <> render'expression'dictKey b - --- | Render a @let@-@in@ expression. -render'let :: Render Let -render'let (Let bs x) = - "let " <> r bs <> "in " <> render'expression x - where - r = Text.concat . fmap (\b -> render'letBinding b <> "; ") - --- | Render a binding within a 'Let', without the trailing semicolon. -render'letBinding :: Render LetBinding -render'letBinding = - \case - LetBinding'Eq a b -> - render'strStatic'unquotedIfPossible a <> " = " <> render'expression b - LetBinding'Inherit x -> - render'inherit x - -render'inherit :: Render Inherit -render'inherit = - \case - Inherit Nothing xs -> "inherit" <> r xs - Inherit (Just a) xs -> "inherit (" <> render'expression a <> ")" <> r xs - where - r = foldMap (\x -> " " <> render'strStatic'unquotedIfPossible x) - --- | Render a @with@ expression. -render'with :: Render With -render'with (With a b) = - keywordText keyword'with <> " " <> - render'expression a <> "; " <> - render'expression b - --- | Render an expression. -render'expression :: Render Expression -render'expression = - \case - Expr'Str x -> render'strDynamic'quoted x - Expr'Dict x -> render'dict x - Expr'List x -> render'list x - Expr'Var x -> render'strUnquoted x - Expr'Dot x -> render'dot x - Expr'Lambda x -> render'lambda x - Expr'Apply x -> render'apply x - Expr'Let x -> render'let x - Expr'With x -> render'with x - --- | Render an expression in a list context. -render'expression'listContext :: Render Expression -render'expression'listContext x = - case x of - Expr'Lambda _ -> render'expression'inParens x - Expr'Apply _ -> render'expression'inParens x - Expr'Let _ -> render'expression'inParens x - Expr'With _ -> render'expression'inParens x - _ -> render'expression x - --- | Render an expression in the context of the left-hand side of a 'Dot'. -render'expression'dotLeftContext :: Render Expression -render'expression'dotLeftContext = render'expression'listContext - --- | Render an expression in the context of the left-hand side of an 'Apply'. -render'expression'applyLeftContext :: Render Expression -render'expression'applyLeftContext x = - case x of - Expr'Lambda _ -> render'expression'inParens x - Expr'Let _ -> render'expression'inParens x - Expr'With _ -> render'expression'inParens x - _ -> render'expression x - --- | Render an expression in the context of the right-hand side of an 'Apply'. -render'expression'applyRightContext :: Render Expression -render'expression'applyRightContext x = - case x of - Expr'Apply _ -> render'expression'inParens x - Expr'Let _ -> render'expression'inParens x - Expr'With _ -> render'expression'inParens x - _ -> render'expression x - -render'expression'inParens :: Render Expression -render'expression'inParens x = - "(" <> render'expression x <> ")" - -render'expression'dictKey :: Render Expression -render'expression'dictKey = \case - Expr'Str x -> render'strDynamic'unquotedIfPossible x - x -> "${" <> render'expression x <> "}" diff --git a/src/Bricks/Term.hs b/src/Bricks/Term.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Term.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Bricks.Term where + +-- Bricks internal +import Bricks.Internal.Monad +import Bricks.Internal.Prelude +import Bricks.Internal.Seq (Seq) +import Bricks.Internal.Text (Text) + +-- Containers +import Data.Map (Map) +import Data.Set (Set) + +-- Base +import Data.Dynamic (Dynamic) +import Data.IORef + +data Bottom = Bottom Text + +displayBottom :: Bottom -> Text +displayBottom (Bottom message) = "Error: " <> message + +class (Monad m, MonadIO m, MonadError Bottom m) => MonadEval m + where + reduce'term :: Term -> m Term + reduce'dict'keys :: Term -> m (Map Text Term) + +type Function = forall m. MonadEval m => Term -> m Term + +data Term + = Term'Data Text Dynamic + -- ^ The name of the data type, and a value of that type. + | Term'Function Function + | Term'Lambda TermPattern Term + -- ^ The head and body of a lambda expression. + | Term'LetRec (Map Text Term) Term + | Term'List (Seq Term) + | Term'Dict (Seq (Term, Term)) + | Term'Dict'ReducedKeys (Map Text Term) + | Term'Var Text + | Term'Apply Term Term + | Term'Pointer TermPtr + +{- | Alias for 'Term'Apply'. The name is an allusion to the AST depictions in +/The Implementation of Functional Programming Languages/, where "/f/ applied to +/x/" is drawn as: + +> @ +> ╱ ╲ +> f x + +For a function of two parameters, see the corresponding '/@@\' operator. -} + +(/@\) :: Term -> Term -> Term +(/@\) = Term'Apply +infixl /@\ + +{- | Like '/@\', but for a function applied to two arguments. Depicted as an +abstract syntax tree, @f /\@\@\\ (x, y)@ looks like this: + +> @ +> ╱ ╲ +> @ y +> ╱ ╲ +> f x + +-} + +(/@@\) :: Term -> (Term, Term) -> Term +f /@@\ (x, y) = (f /@\ x) /@\ y +infixl /@@\ + +{- | Alias for 'Term'Lambda'. -} + +(|->) :: TermPattern -> Term -> Term +(|->) = Term'Lambda +infixl |-> + +data TermPattern + = TermPattern'Simple Text + | TermPattern'Dict (Set Text) + +type TermPtr = IORef Term + +create'pointer :: MonadIO m => Term -> m Term +create'pointer x = case x of + Term'Pointer _ -> pure x -- The term is already a pointer, don't make another + _ -> Term'Pointer <$> liftIO (newIORef x) + +dereference :: MonadIO m => Term -> m Term +dereference = \case + Term'Pointer p -> readTermPtr p >>= dereference + x -> pure x + +newTermPtr :: MonadIO m => Term -> m Term +newTermPtr x = case x of + Term'Pointer _ -> pure x -- The term is already a pointer, nothing to do + _ -> Term'Pointer <$> liftIO (newIORef x) + +readTermPtr :: MonadIO m => TermPtr -> m Term +readTermPtr = liftIO . readIORef + +writeTermPtr :: MonadIO m => TermPtr -> Term -> m () +writeTermPtr ptr val = do + x <- dereference val + liftIO $ writeIORef ptr x + +bottom :: MonadError Bottom m => Bottom -> m a +bottom = throwError diff --git a/src/Bricks/Type.hs b/src/Bricks/Type.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Type.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Bricks.Type where + +-- Bricks +import Bricks.Term + +-- Bricks internal +import Bricks.Internal.Monad +import Bricks.Internal.Prelude +import Bricks.Internal.Text (Text) + +-- Base +import Prelude (Integer) + +data Type a = Type { type'name :: Text } + +type'boolean :: Type Bool +type'boolean = Type "boolean" + +type'string :: Type Text +type'string = Type "string" + +type'integer :: Type Integer +type'integer = Type "integer" + +termTypeName :: MonadIO m => Term -> m Text +termTypeName = \case + Term'Data x _ -> pure x + Term'Function{} -> pure "built-in function" + Term'Lambda{} -> pure "lambda" + Term'LetRec{} -> pure "recursive let" + Term'List{} -> pure "list" + Term'Dict{} -> pure "dict" + Term'Dict'ReducedKeys{} -> pure "dict with reduced keys" + Term'Var{} -> pure "variable" + Term'Apply{} -> pure "function application" + Term'Pointer p -> readTermPtr p >>= termTypeName diff --git a/src/Bricks/UnquotedString.hs b/src/Bricks/UnquotedString.hs deleted file mode 100644 --- a/src/Bricks/UnquotedString.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -module Bricks.UnquotedString - ( - -- * Type - Str'Unquoted (..) - - -- * Constructor - , str'tryUnquoted - , str'unquoted'orThrow - - -- * Predicates - , str'canRenderUnquoted - , char'canRenderUnquoted - - ) where - --- Bricks -import Bricks.Keyword - --- Bricks internal -import Bricks.Internal.Prelude -import Bricks.Internal.Text (Text) -import qualified Bricks.Internal.Text as Text - --- Base -import qualified Data.Char as Char -import qualified Data.List as List -import Prelude (error) - -{- | A string that can be rendered unquoted. Unquoted strings are restricted to -a conservative set of characters; see 'str'canRenderUnquoted' for the full -rules. - -The constructor is tagged "unsafe" because it lets you construct and invalid -value. Prefer 'str'tryUnquoted' which does validate the text. -} -newtype Str'Unquoted = Str'Unquoted'Unsafe { str'unquotedToStatic :: Text } - -instance Show Str'Unquoted - where - showsPrec _ x = ("unquoted " <>) . shows (str'unquotedToStatic x) - -str'tryUnquoted :: Text -> Maybe Str'Unquoted -str'tryUnquoted x = - if str'canRenderUnquoted x then Just (Str'Unquoted'Unsafe x) else Nothing - --- | Throws an exception if the string cannot render unquoted. -str'unquoted'orThrow :: Text -> Str'Unquoted -str'unquoted'orThrow x = - if str'canRenderUnquoted x then Str'Unquoted'Unsafe x else - error $ "String " <> show x <> " cannot render unquoted" - -{- | Whether a string having this name can be rendered without quoting it. -We allow a string to render unquoted if all these conditions are met: - -- The string is nonempty -- All characters satify 'char'canRenderUnquoted' -- The string is not a keyword - ->>> str'canRenderUnquoted "-ab_c" -True - ->>> str'canRenderUnquoted "" -False - ->>> str'canRenderUnquoted "a\"b" -False - ->>> str'canRenderUnquoted "let" -False - --} -str'canRenderUnquoted :: Text -> Bool -str'canRenderUnquoted x = - Text.all char'canRenderUnquoted x - && not (Text.null x) - && List.all ((/= x) . keywordText) keywords - --- | Letters, @-@, and @_@. -char'canRenderUnquoted :: Char -> Bool -char'canRenderUnquoted c = - Char.isLetter c || c == '-' || c == '_' diff --git a/test/Bricks/Test/Hedgehog.hs b/test/Bricks/Test/Hedgehog.hs deleted file mode 100644 --- a/test/Bricks/Test/Hedgehog.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Bricks.Test.Hedgehog - ( runTests - ) where - --- Base -import Control.Monad (unless) -import Data.Foldable (for_) -import qualified System.Exit as Exit -import qualified System.IO as IO - --- Hedgehog -import qualified Hedgehog - -runTests :: Hedgehog.Group -> IO () -runTests tests = - do - for_ [IO.stdout, IO.stderr] $ \h -> do - IO.hSetEncoding h IO.utf8 - IO.hSetBuffering h IO.LineBuffering - success <- Hedgehog.checkParallel tests - unless success Exit.exitFailure diff --git a/test/Bricks/Test/QQ.hs b/test/Bricks/Test/QQ.hs deleted file mode 100644 --- a/test/Bricks/Test/QQ.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Bricks.Test.QQ - ( text - ) where - --- Base -import Control.Arrow ((>>>)) -import Data.Function (const) - --- Template Haskell -import Language.Haskell.TH -import Language.Haskell.TH.Quote - --- Text -import qualified Data.Text as Text - -text :: QuasiQuoter -text = - QuasiQuoter - { quoteExp = pure . LitE . StringL . stripMargin - , quotePat = err - , quoteType = err - , quoteDec = err - } - where - err = const . fail $ "illegal text QuasiQuote (allowed as expression only)" - -stripMargin :: String -> String -stripMargin = - Text.pack - >>> Text.splitOn "\n" - >>> fmap (\x -> - let (a, b) = Text.breakOn "|" x - in if Text.all (== ' ') a && not (Text.null b) - then Text.drop 1 b - else x) - >>> Text.intercalate "\n" - >>> Text.unpack diff --git a/test/evaluation.hs b/test/evaluation.hs new file mode 100644 --- /dev/null +++ b/test/evaluation.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} + +-- Bricks +import Bricks.Prelude +import Bricks.Type + +-- Bricks internal +import Bricks.Internal.Monad +import Bricks.Internal.Prelude + +-- Bricks test +import Bricks.Test.Hedgehog +import Bricks.Test.QQ + +-- Hedgehog +import Hedgehog (Property, property, withTests, (===)) +import qualified Hedgehog + +-- Base +import System.IO (IO) + +main :: IO () +main = runTests $$(Hedgehog.discover) + +prop_str :: Property +prop_str = withTests 1 $ property $ do + + do + x <- liftIO $ bricks'eval type'string [text|"abc"|] + x === "abc" + + do + x <- liftIO $ bricks'eval type'string [text|''a${"b"}c''|] + x === "abc" + +{- +prop_dict :: Property +prop_dict = withTests 1 $ property $ do + + x <- liftIO $ bricks'eval type'string [text|{ a = "1"; }.a|] + x === "1" + + x <- liftIO $ bricks'eval type'string [text|{ "a b" = "1"; }."a b"|] + x === "1" +-} + +prop_add :: Property +prop_add = withTests 1 $ property $ do + + do + x <- liftIO $ bricks'eval'stdlib type'integer + [text|┃{ add, integer, ... }: + ┃add (integer "1") (integer "2")|] + x === 3 + + do + x <- liftIO $ bricks'eval'stdlib type'integer + [text|┃lib: + ┃let + ┃ inherit (lib) add integer; + ┃in + ┃ add (integer "1") (integer "2")|] + x === 3 diff --git a/test/parsing.hs b/test/parsing.hs deleted file mode 100644 --- a/test/parsing.hs +++ /dev/null @@ -1,527 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - --- Bricks -import Bricks - --- Bricks internal -import Bricks.Internal.Prelude -import Bricks.Internal.Text (Text) -import qualified Bricks.Internal.Text as Text - --- Bricks test -import Bricks.Test.Hedgehog -import Bricks.Test.QQ - --- Parsec -import qualified Text.Parsec as P -import Text.Parsec.Text (Parser) - --- Hedgehog -import Hedgehog (Property, property, (===)) -import qualified Hedgehog - --- Base -import System.IO (IO) -import Text.Show (show) - -main :: IO () -main = runTests $$(Hedgehog.discover) - -{- | We'll use the @parseTest@ function a lot to test parsers. It's a bit like -'P.parseTest' from the Parsec library, but it works on parsers of type 'Text' -rather than @'Show' a => a@. It also prints the unparsed input so we can verify -that our parser consumes the right amount of input, and it prints a message if -the parser fails and consumes input. -} -parseTest :: Parser Text -> Text -> Text -parseTest p input = - Text.intercalate "\n" $ - catMaybes - - [ Just $ case P.parse p "" input of - Left err -> - "Parse error at " <> - Text.replace "\n" "\n - " (Text.pack (show err)) - Right x -> x - - , let - p' = do - _ <- p - r <- P.many1 P.anyChar - pure $ "Remaining input: " <> Text.pack (show r) - in - case P.parse p' "" input of - Left _ -> Nothing - Right x -> Just x - - , case P.parse (void p <|> pure ()) "" input of - Left _ -> Just "Parser failed and consumed input" - Right _ -> Nothing - - ] - -prop_parse_str_unquoted :: Property -prop_parse_str_unquoted = property $ do - - let test = parseTest $ fmap str'unquotedToStatic $ parse'strUnquoted - - test "-ab_c" === [text|-ab_c|] - - test "" === [text|Parse error at (line 1, column 1): - | - unexpected end of input|] - - test "a\"b" === [text|a - |Remaining input: "\"b"|] - - test "a b" === [text|a - |Remaining input: "b"|] - - -- The unquoted string parser doesn't backtrack. - -- Note how in this example it fails and consumes input. - test "rec { }" === [text|Parse error at (line 1, column 4): - | - unexpected " " - |Parser failed and consumed input|] - -prop_parse_expression_dictKey :: Property -prop_parse_expression_dictKey = property $ do - - let test = parseTest $ fmap render'expression $ parse'expression'dictKey - - test "a" === [text|"a"|] - - test "\"a\"" === [text|"a"|] - - test "a b" === [text|"a" - |Remaining input: "b"|] - - test "${a.b}" === [text|a.b|] - -prop_parse_strDynamic_normalQ :: Property -prop_parse_strDynamic_normalQ = property $ do - - let test = parseTest - $ fmap render'strDynamic'quoted - $ parse'strDynamic'normalQ - - test "\"a\"" === [text|"a"|] - - test "\"a\" x" === [text|"a" - |Remaining input: "x"|] - - test "\"a ${b} c\"" === [text|"a ${b} c"|] - - test "\"a${ b }c\"" === [text|"a${b}c"|] - - test "\"$\"" === [text|"$"|] - - test "\"a$\"" === [text|"a$"|] - - test "\"\\${\"" === [text|"\${"|] - - test "\"a\\${\"" === [text|"a\${"|] - -prop_parse_strDynamic_indentedQ :: Property -prop_parse_strDynamic_indentedQ = property $ do - - let test = parseTest - $ fmap render'strDynamic'quoted - $ P.spaces *> parse'strDynamic'indentedQ - - test "''hello''x" === [text|"hello" - |Remaining input: "x"|] - - test "''hello'' x" === [text|"hello" - |Remaining input: "x"|] - - test [text| '' - | one - | two - | ''x|] === [text|"one\ntwo" - |Remaining input: "x"|] - - test [text| '' - | one - | - | two - | ''x|] === [text|"one\n\ntwo" - |Remaining input: "x"|] - -prop_parse_inStr :: Property -prop_parse_inStr = property $ do - - let test = parseTest - $ fmap (Text.pack . show . fmap render'inStr'1 . inStr'toList) - $ P.spaces *> parse'inStr - - test [text| '' - | one - | two - | ''x|] === [text|[""," one"," two"," "] - |Remaining input: "x"|] - - test [text| '' - | one - | - | two - | ''x|] === [text|[""," one",""," two"," "] - |Remaining input: "x"|] - - test "'''' x" === [text|[""] - |Remaining input: "x"|] - - test "''abc''" === [text|["abc"]|] - - test "''\n''" === [text|["",""]|] - - test "'' \n''" === [text|[" ",""]|] - - test "'' abc\ndef''" === [text|[" abc","def"]|] - -prop_parse_inStr_line :: Property -prop_parse_inStr_line = property $ do - - let test = parseTest - $ fmap (Text.pack . show . render'inStr'1) - $ parse'inStr'1 - - test "abc" === [text|Parse error at (line 1, column 4): - | - unexpected end of input - | - expecting "$", "'", "\n", "''" or "${" - |Parser failed and consumed input|] - - test "\n" === [text|"" - |Remaining input: "\n"|] - - test " \n" === [text|" " - |Remaining input: "\n"|] - - test " abc\ndef" === [text|" abc" - |Remaining input: "\ndef"|] - - test " abc''x" === [text|" abc" - |Remaining input: "''x"|] - -prop_parse_dict_pattern_start :: Property -prop_parse_dict_pattern_start = property $ do - - let test = parseTest $ (P.try parse'dictPattern'start $> "yes") <|> pure "no" - - test "{a, b}:" === [text|yes - |Remaining input: " b}:"|] - - test "{a ? 4, b}:" === [text|yes - |Remaining input: " 4, b}:"|] - - test "{ }: x" === [text|yes - |Remaining input: " x"|] - - -- { } is not enough to determine whether we're parsing a dict param, because - -- if it isn't followed by a colon, then it's actually an empty dict literal. - test "{ } x" === [text|no - |Remaining input: "{ } x"|] - - test "{ ... }:" === [text|yes - |Remaining input: " }:"|] - -prop_parse_dict_pattern :: Property -prop_parse_dict_pattern = property $ do - - let test = parseTest $ fmap render'dictPattern $ parse'dictPattern - - test "{}" === [text|{ }|] - test "{...}" === [text|{ ... }|] - test "{a}" === [text|{ a }|] - test "{a , b}" === [text|{ a, b }|] - test "{a , b ? c, ...}" === [text|{ a, b ? c, ... }|] - -prop_parse_dot_rhs_chain :: Property -prop_parse_dot_rhs_chain = property $ do - - let test = parseTest - $ fmap (Text.intercalate "\n" . fmap render'expression) - $ parse'dot'rhs'chain - - -- The dots parser /does/ match the empty string. - test "" === [text||] - - -- The simplest nonempty dot list - test ".a" === [text|"a"|] - - -- The dots parser consumes any trailing whitespace beyond the dot list. - test ".a " === [text|"a"|] - - -- Dot attributes are usually unquoted strings, but they may also be quoted. - test ".\"a\"" === [text|"a"|] - test ". \"a\"" === [text|"a"|] - - -- Here we throw some extra whitespace into the middle, which makes no - -- difference, and some extra stuff onto the end, which does not get consumed. - test ".a . b c" === [text|"a" - |"b" - |Remaining input: "c"|] - - -- Another example of a quoted dot, this time following an unquoted dot - test ".a.\"b\"" === [text|"a" - |"b"|] - - -- If quotes or braces are involved, the stuff that follows a dot expression - -- can directly abut it with no whitespace in between. - test [text|.a."b"x|] === [text|"a" - |"b" - |Remaining input: "x"|] - - test [text|.a.b"x"|] === [text|"a" - |"b" - |Remaining input: "\"x\""|] - - test ".a.b(x)" === [text|"a" - |"b" - |Remaining input: "(x)"|] - - test ". a . b" === [text|"a" - |"b"|] - - test ". \"a\".b" === [text|"a" - |"b"|] - - test ". \"a\".${b}" === [text|"a" - |b|] - -prop_parse_expression :: Property -prop_parse_expression = property $ do - - let test = parseTest $ fmap render'expression $ parse'expression - - -- The empty string is /not/ a valid expression. - test "" === [text|Parse error at (line 1, column 1): - | - unexpected end of input - | - expecting expression|] - - -- A very simple expression: a one-letter variable - test "a" === [text|a|] - - -- Parsing an expression consumes any subsequent whitespace. - test "a " === [text|a|] - - -- When there are multiple expressions, that is parsed as a function call. - test "f x" === [text|f x|] - - -- Expressions can directly abut each other, so it's important that the - -- expression parser is also able to read an expression even when another - -- expression directly follows it. - test "f[x y]" === [text|f [ x y ]|] - - -- A simple example of parsing a dot expression - test "a.b" === [text|a.b|] - - -- Dot parsing also consumes trailing whitespace. - test "a.b " === [text|a.b|] - - -- It looks odd when a subsequent expression appears after a dot expression - -- with no whitespace, but it is permitted. - test "a.b\"c\"" === [text|a.b "c"|] - - -- A simple list example - test "[ a b ]" === [text|[ a b ]|] - - -- A list with trailing whitespace that get consumed - test "[ a b ] " === [text|[ a b ]|] - - -- A list that is in the left-hand side of a function call. This will fail at - -- runtime if the call is evaluated, because a list is not a function, but it - -- should /parse/ successfully. - test "[ a b ] x" === [text|[ a b ] x|] - - -- The same thing with other weird stuff on the left-hand side of a function - -- call. - test "{ a = b; } x" === [text|{ a = b; } x|] - - test "{ } x" === [text|{ } x|] - - -- Note that the case where an empty dict is on the left-hand side of a - -- function call looks very similar to the case where a function expression - -- using dict deconstruction with no bindings. The only difference is the - -- colon. - test "{ }: x" === [text|{ }: x|] - - -- A list with a function call inside - test "[ (f x) ]" === [text|[ (f x) ]|] - - test "[ a (f x) ]" === [text|[ a (f x) ]|] - - -- A minimal dict literal - test "{ x = y; }" === [text|{ x = y; }|] - - -- The left-hand side of a dict binding is allowed to be any expression. - test "{ \"a b\" = y; }" === [text|{ "a b" = y; }|] - test "{ ${x} = y; }" === [text|{ ${x} = y; }|] - - -- It may even be the empty string. - test "{ \"\" = y; }" === [text|{ "" = y; }|] - - -- None of the conventional whitespace within a dict literal is mandatory. - test "{x=y;}" === [text|{ x = y; }|] - - -- A simple dict literal with two bindings - test "{ x = y; a = b; }" === [text|{ x = y; a = b; }|] - - -- The same thing without any whitespace - test "{x=y;a=b;}" === [text|{ x = y; a = b; }|] - - -- Dicts with 'inherit' bindings - test "{ inherit a; }" === [text|{ inherit a; }|] - test "{ inherit a b; }" === [text|{ inherit a b; }|] - test "{ inherit (x) a b; }" === [text|{ inherit (x) a b; }|] - - -- An inherit binding can be empty, although it is weird. - test "{ inherit; }" === [text|{ inherit; }|] - - -- A simple function - test "x : y" === [text|x: y|] - - -- Whitespace before the colon is unconventional, but allowed. - test "x : y" === [text|x: y|] - - -- The space after the colon is not mandatory. (In Nix, this example would be - -- parsed as the string "x:y", but here we do not support URI literals.) - test "x:y" === [text|x: y|] - - -- A slightly bigger example where we're starting to nest more things - test "[ \"abc\" f { x = y; } ]" === [text|[ "abc" f { x = y; } ]|] - - test "[ \"abc\" (f { x = y; }) ]" === [text|[ "abc" (f { x = y; }) ]|] - - -- This is not valid a expression (though the first bit of it is). - test "a b: c" === [text|a b - |Remaining input: ": c"|] - - -- This is not a valid expression. - test "(a b: c)" === [text|Parse error at (line 1, column 5): - | - unexpected ":" - | - expecting expression list item or ")" - |Parser failed and consumed input|] - - -- Some functions that use dict deconstruction - test "{ a, b, c ? x, ... }: g b (f a c)" - === [text|{ a, b, c ? x, ... }: g b (f a c)|] - - test "{ x, ... }: f x" === [text|{ x, ... }: f x|] - test "{ x?\"abc\" }: x" === [text|{ x ? "abc" }: x|] - test "{ ... }: x" === [text|{ ... }: x|] - test "a@{ x, ... }: f x" === [text|a@{ x, ... }: f x|] - test "a@{ x?\"abc\" }: x" === [text|a@{ x ? "abc" }: x|] - test "a@{ ... }: x" === [text|a@{ ... }: x|] - - -- A let expression - test "let f = x: plus one x; in f seven" - === [text|let f = x: plus one x; in f seven|] - - -- A let binding list may be empty, although it is silly. - test "let in f x" === [text|let in f x|] - - test "with x; y" === [text|with x; y|] - - test "with{x=y;}; f x z" === [text|with { x = y; }; f x z|] - - -- Indented strings do not support any escape sequences. - test [text|'' - | There \ is \n no \$ escape. - |''|] === [text|"There \\ is \\n no \\$ escape."|] - - -- Therefore if you want to include something like '' in an indented string, - -- you have to put it inside an antiquote. - test [text|'' - | Isn't it - | ${"''"}interesting - |'' - |] === [text|"Isn't it\n''interesting"|] - - -- Comments - test [text|let -- hi - | x {- ! -} = "a"; -- yep - | in -- lol - | f x - |] === [text|let x = "a"; in f x|] - - -- Nested block comments - test [text|f{- a - | -- b - | {- c {- d - | -}-} e - | -}x|] === "f x" - -prop_parse_expression_list :: Property -prop_parse_expression_list = property $ do - - let test = parseTest - $ fmap (Text.intercalate "\n" . fmap render'expression) - $ parse'expressionList - - test "" === [text||] - - test "x y z" === [text|x - |y - |z|] - - - test "(a)b c(d)" === [text|a - |b - |c - |d|] - - test "a.\"b\"c" === [text|a.b - |c|] - - test "\"abc\" (f { x = y; })" === [text|"abc" - |f { x = y; }|] - - -- Parsing lists of variables that are similar to keywords - test "r re reck" === [text|r - |re - |reck|] - test "r re rec { } reck" === [text|r - |re - |rec { } - |reck|] - test "l le lets" === [text|l - |le - |lets|] - test "i ins" === [text|i - |ins|] - test "wi wit withs" === [text|wi - |wit - |withs|] - test "inheri inherits" === [text|inheri - |inherits|] - -prop_parse_expression_list_item :: Property -prop_parse_expression_list_item = property $ do - - let test = parseTest $ fmap render'expression $ parse'expressionList'1 - - test "abc def" === [text|abc - |Remaining input: "def"|] - test "a.b c" === [text|a.b - |Remaining input: "c"|] - test "a.\"b\"c" === [text|a.b - |Remaining input: "c"|] - test "(a.b)c" === [text|a.b - |Remaining input: "c"|] - test "a.b(c)" === [text|a.b - |Remaining input: "(c)"|] - test "[ a b ]c" === [text|[ a b ] - |Remaining input: "c"|] - test "a[ b c ]" === [text|a - |Remaining input: "[ b c ]"|] - test "\"a\"b" === [text|"a" - |Remaining input: "b"|] - -prop_parse_expression_list_item_no_dot :: Property -prop_parse_expression_list_item_no_dot = property $ do - - let test = parseTest $ fmap render'expression $ parse'expressionList'1'noDot - - test "a.b c" === [text|a - |Remaining input: ".b c"|] diff --git a/test/rendering.hs b/test/rendering.hs deleted file mode 100644 --- a/test/rendering.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} - --- Bricks -import Bricks -import Bricks.Expression.Construction - --- Bricks internal -import Bricks.Internal.Prelude - --- Bricks test -import Bricks.Test.Hedgehog -import Bricks.Test.QQ - --- Hedgehog -import Hedgehog (Property, property, (===)) -import qualified Hedgehog - --- Base -import System.IO (IO) - -main :: IO () -main = runTests $$(Hedgehog.discover) - -prop_render_expression :: Property -prop_render_expression = property $ do - - render'expression (dot (var "a") (str ["b"])) === [text|a.b|] - - render'expression (dot (var "a") (var "b")) === [text|a.${b}|] - - render'expression (dot (str ["a"]) - (str ["b", antiquote (var "c")])) === [text|"a"."b${c}"|] - - render'expression - (lambda - (param "a" <> pattern - [ param "f" - , param "b" & def (apply (var "g") (var "x")) - ] <> ellipsis) - (apply (var "f") (var "b"))) - === [text|a@{ f, b ? g x, ... }: f b|] - - render'expression - (let'in - [ binding "d" (dict - [ binding (str ["a"]) (str ["b", antiquote (var "c")]) - , inherit'from (var "x") ["y", "z"] - ])] - (dot (var "d") (str ["y"]))) - === [text|let d = { a = "b${c}"; inherit (x) y z; }; in d.y|] - -prop_render_identifier :: Property -prop_render_identifier = property $ do - - let test = render'strStatic'unquotedIfPossible - - test "abc" === [text|abc|] - test "a\"b" === [text|"a\"b"|] - test "-ab" === [text|-ab|] - test "" === [text|""|] - -prop_render_string_dynamic_quoted :: Property -prop_render_string_dynamic_quoted = property $ do - - let test = render'strDynamic'quoted . strDynamic'fromList - - test [] === [text|""|] - test [ Str'1'Literal "hello" ] === [text|"hello"|] - - test [ Str'1'Literal "escape ${ this and \" this" ] - === [text|"escape \${ this and \" this"|] - - test [ Str'1'Literal "Hello, my name is " - , Str'1'Antiquote (Expr'Var (Str'Unquoted'Unsafe "name")) - , Str'1'Literal "!" - ] - === [text|"Hello, my name is ${name}!"|] - -prop_render_indented_string_line :: Property -prop_render_indented_string_line = property $ do - - let test n xs = render'inStr'1 $ InStr'1 n (strDynamic'fromList xs) - - test 2 [ Str'1'Literal "abc" - , Str'1'Antiquote (Expr'Var $ Str'Unquoted'Unsafe "x") - ] - === [text| abc${x}|] - -prop_render_dict_pattern :: Property -prop_render_dict_pattern = property $ do - - let test a b = render'dictPattern $ DictPattern a b - - test [] False === [text|{ }|] - test [] True === [text|{ ... }|] - - let - item1 = DictPattern'1 (Str'Unquoted'Unsafe "x") Nothing - item2 = DictPattern'1 (Str'Unquoted'Unsafe "y") $ - Just $ Expr'Str (strDynamic'singleton (Str'1'Literal "abc")) - - test [ item1, item2 ] False === [text|{ x, y ? "abc" }|] - test [ item1, item2 ] True === [text|{ x, y ? "abc", ... }|] - -prop_render_list :: Property -prop_render_list = property $ do - - let test = render'list . List - - test [] === [text|[ ]|] - test [ Expr'Var (Str'Unquoted'Unsafe "a") ] === [text|[ a ]|] - test [ Expr'Var (Str'Unquoted'Unsafe "a") - , Expr'Var (Str'Unquoted'Unsafe "b") ] === [text|[ a b ]|] - - let call = Expr'Apply $ Apply (Expr'Var (Str'Unquoted'Unsafe "f")) - (Expr'Var (Str'Unquoted'Unsafe "x")) - - test [ call ] === [text|[ (f x) ]|] - test [ call, Expr'Var (Str'Unquoted'Unsafe "a") ] === [text|[ (f x) a ]|]