diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bricks.cabal b/bricks.cabal new file mode 100644 --- /dev/null +++ b/bricks.cabal @@ -0,0 +1,105 @@ +-- This file has been generated from package.yaml by hpack version 0.18.1. +-- +-- see: https://github.com/sol/hpack + +name: bricks +version: 0.0.0.1 +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. +homepage: https://github.com/chris-martin/bricks#readme +bug-reports: https://github.com/chris-martin/bricks/issues +license: Apache-2.0 +license-file: license.txt +build-type: Simple +cabal-version: >= 1.10 + +source-repository head + type: git + location: https://github.com/chris-martin/bricks + +library + hs-source-dirs: + 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 + 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 + other-modules: + Paths_bricks + default-language: Haskell2010 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: doctest.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 + , 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 + other-modules: + Bricks.Test.Hedgehog + Bricks.Test.QQ + default-language: Haskell2010 + +test-suite rendering + type: exitcode-stdio-1.0 + main-is: rendering.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 + other-modules: + Bricks.Test.Hedgehog + Bricks.Test.QQ + default-language: Haskell2010 diff --git a/license.txt b/license.txt new file mode 100644 --- /dev/null +++ b/license.txt @@ -0,0 +1,13 @@ +Copyright 2017 Chris Martin + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. diff --git a/src/Bricks.hs b/src/Bricks.hs new file mode 100644 --- /dev/null +++ b/src/Bricks.hs @@ -0,0 +1,203 @@ +{- | __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) + +The following modules are re-exported from this module in their entireties: + +- "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 + +Other modules: + +- "Bricks.Expression.Construction" - Functions for constructing 'Expression's + in a way that matches their 'Show' implementations. + +-} +module Bricks + + ( + ------------------------------------------------- + -- * Expressions + Expression (..) + -- ** Rendering expressions + , render'expression + , render'expression'listContext + , render'expression'dotLeftContext + , render'expression'applyLeftContext + , render'expression'applyRightContext + , render'expression'inParens + , render'expression'dictKey + -- ** Parsing expressions + , parse'expression + , parse'expression'paren + , parse'expression'dictKey + -- ** Parsing lists of expressions + , parse'expressionList + , parse'expressionList'1 + , parse'expressionList'1'noDot + ------------------------------------------------- + -- * Strings + , str'escape + , parse'str'within'normalQ + , parse'str'escape'normalQ + -- ** Static strings + , Str'Static + , render'strStatic'unquotedIfPossible + , render'strStatic'quoted + , parse'strStatic + , parse'strStatic'quoted + , parse'strStatic'unquoted + -- ** Dynamic strings + , Str'Dynamic (..) + , Str'1 (..) + , strDynamic'toList + , strDynamic'fromList + , strDynamic'singleton + , render'strDynamic'unquotedIfPossible + , render'strDynamic'quoted + , parse'strDynamic'quoted + , parse'strDynamic'normalQ + , parse'strDynamic'indentedQ + -- ** Unquoted strings + , Str'Unquoted (..) + , str'tryUnquoted + , str'unquoted'orThrow + , str'canRenderUnquoted + , char'canRenderUnquoted + , render'strUnquoted + , parse'strUnquoted + -- ** String conversions + , str'dynamicToStatic + , str'staticToDynamic + , str'unquotedToDynamic + -- ** Indented strings + , InStr (..) + , inStr'toList + , inStr'join + , inStr'level + , inStr'dedent + , inStr'trim + , render'inStr'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 (..) + , render'list + , parse'list + ------------------------------------------------- + -- * Dicts + , Dict (..) + , keyword'rec + , render'dict + , parse'dict + , parse'dict'rec + , parse'dict'noRec + -- ** Dict bindings + , DictBinding (..) + , render'dictBinding + , parse'dictBinding + , parse'dictBinding'inherit + , parse'dictBinding'eq + -- ** Dict lookup (dot) + , Dot (..) + , expression'applyDots + , render'dot + , parse'dot'rhs'chain + ------------------------------------------------- + -- * Functions + -- ** Lambdas + , Lambda (..) + , render'lambda + , parse'lambda + -- ** Function parameters + , Param (..) + , render'param + , parse'param + , parse'param'var + , parse'param'noVar + -- ** Dict patterns + , DictPattern (..) + , DictPattern'1 (..) + , render'dictPattern + , render'dictPattern'1 + , parse'dictPattern + , parse'dictPattern'start + -- ** Function application + , Apply (..) + , expression'applyArgs + , render'apply + ------------------------------------------------- + -- * @let@ + , Let (..) + , keyword'let + , keyword'in + , render'let + , parse'let + -- ** @let@ bindings + , LetBinding (..) + , 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 + , Render + , parse'antiquote + ------------------------------------------------- + ) where + +import Bricks.Expression +import Bricks.IndentedString +import Bricks.Keyword +import Bricks.Parsing +import Bricks.Rendering +import Bricks.UnquotedString diff --git a/src/Bricks/Expression.hs b/src/Bricks/Expression.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Expression.hs @@ -0,0 +1,583 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Bricks/Expression/Construction.hs @@ -0,0 +1,233 @@ +{-# 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/IndentedString.hs b/src/Bricks/IndentedString.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/IndentedString.hs @@ -0,0 +1,120 @@ +{-# 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/Prelude.hs b/src/Bricks/Internal/Prelude.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Internal/Prelude.hs @@ -0,0 +1,43 @@ +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 new file mode 100644 --- /dev/null +++ b/src/Bricks/Internal/Seq.hs @@ -0,0 +1,47 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Bricks/Internal/Text.hs @@ -0,0 +1,35 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Bricks/Keyword.hs @@ -0,0 +1,67 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/src/Bricks/Parsing.hs @@ -0,0 +1,679 @@ +{-# 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/Rendering.hs b/src/Bricks/Rendering.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/Rendering.hs @@ -0,0 +1,281 @@ +{-# 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/UnquotedString.hs b/src/Bricks/UnquotedString.hs new file mode 100644 --- /dev/null +++ b/src/Bricks/UnquotedString.hs @@ -0,0 +1,83 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Bricks/Test/Hedgehog.hs @@ -0,0 +1,23 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/Bricks/Test/QQ.hs @@ -0,0 +1,39 @@ +{-# 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/doctest.hs b/test/doctest.hs new file mode 100644 --- /dev/null +++ b/test/doctest.hs @@ -0,0 +1,4 @@ +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src", "-XOverloadedStrings"] diff --git a/test/parsing.hs b/test/parsing.hs new file mode 100644 --- /dev/null +++ b/test/parsing.hs @@ -0,0 +1,527 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/test/rendering.hs @@ -0,0 +1,123 @@ +{-# 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 ]|]