bricks-syntax (empty) → 0.0.0.4
raw patch · 10 files changed
+1965/−0 lines, 10 filesdep +basedep +bricks-internaldep +bricks-syntax
Dependencies added: base, bricks-internal, bricks-syntax, containers, doctest, either-list-functions, exceptions, hint, text
Files
- bricks-syntax.cabal +83/−0
- license.txt +13/−0
- src/Bricks/Expression.hs +1110/−0
- src/Bricks/Expression/Construction.hs +292/−0
- src/Bricks/Keyword.hs +63/−0
- src/Bricks/Source.hs +91/−0
- src/Bricks/UnquotedString.hs +124/−0
- test-data/expression-show-examples.txt +16/−0
- test/doctest.hs +4/−0
- test/show.hs +169/−0
+ bricks-syntax.cabal view
@@ -0,0 +1,83 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: a1c185ba72cbce07618777aaf1605509c0d96ad1fe32a61c148d111e0e5e46bd++name: bricks-syntax+version: 0.0.0.4+synopsis: ...++description: ...+category: Language+homepage: https://github.com/chris-martin/bricks#readme+bug-reports: https://github.com/chris-martin/bricks/issues+author: Chris Martin <ch.martin@gmail.com>+maintainer: Chris Martin <ch.martin@gmail.com>+license: Apache-2.0+license-file: license.txt+build-type: Simple+cabal-version: >= 1.10++data-files:+ test-data/expression-show-examples.txt++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.11+ , bricks-internal+ , containers >=0.5.7 && <0.6+ , either-list-functions ==0.0.0.2+ , text >=1.2.2 && <1.3+ exposed-modules:+ Bricks.Expression+ Bricks.Expression.Construction+ Bricks.Keyword+ Bricks.Source+ Bricks.UnquotedString+ other-modules:+ Paths_bricks_syntax+ 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.11+ , bricks-internal+ , containers >=0.5.7 && <0.6+ , doctest >=0.11 && <0.14+ , either-list-functions ==0.0.0.2+ , text >=1.2.2 && <1.3+ other-modules:+ Paths_bricks_syntax+ default-language: Haskell2010++test-suite show+ type: exitcode-stdio-1.0+ main-is: show.hs+ hs-source-dirs:+ test+ ghc-options: -Wall+ build-depends:+ base >=4.9 && <4.11+ , bricks-internal+ , bricks-syntax+ , containers >=0.5.7 && <0.6+ , either-list-functions ==0.0.0.2+ , exceptions+ , hint+ , text >=1.2.2 && <1.3+ other-modules:+ Paths_bricks_syntax+ default-language: Haskell2010
+ license.txt view
@@ -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.
+ src/Bricks/Expression.hs view
@@ -0,0 +1,1110 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Bricks.Expression+ (+ -- * Expressions+ Expression (..)+ , expression'source+ , expression'discardSource++ -- * Variables+ -- $variables+ , Var (..)+ , var'text+ , var'to'str'static+ , var'to'str'dynamic+ , var'discardSource++ -- * Static strings+ , Str'Static (..)+ , str'static'append+ , str'static'discardSource+ , str'static'to'dynamic++ -- * Dynamic strings+ , Str'Dynamic (..)+ , Str'1 (..)+ , str'1'discardSource+ , str'dynamic'append+ , str'dynamic'normalize+ , str'dynamic'discardSource+ , str'dynamic'to'static++ -- * Indented string+ , InStr (..)+ , inStr'to'strDynamic+ , inStr'level+ , inStr'dedent+ , inStr'trim+ , inStr'toList+ , inStr'discardSource++ -- * Single line of an indented string+ , InStr'1 (..)+ , inStr'1'toStrParts+ , inStr'1'discardSource++ -- * Lists+ , List (..)+ , list'discardSource++ -- * Dicts+ , Dict (..)+ , dict'discardSource+ , DictBinding (..)+ , dictBinding'discardSource++ -- * Dict lookup+ , Dot (..)+ , expression'applyDots+ , dot'discardSource++ -- * Lambdas+ , Lambda (..)+ , lambda'discardSource++ -- * Function parameters+ , Param (..)+ , param'discardSource+ , DictPattern (..)+ , dictPattern'discardSource+ , DictPattern'1 (..)+ , dictPattern'1'discardSource++ -- * Function application+ , Apply (..)+ , expression'applyArgs+ , apply'discardSource++ -- * @let@+ , Let (..)+ , let'discardSource+ , LetBinding (..)+ , letBinding'discardSource++ ) where++-- Bricks+import Bricks.Source+import Bricks.UnquotedString++-- Bricks internal+import Bricks.Internal.List as List+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 Prelude (Num (..), fromIntegral)++data Expression+ = Expr'Var Var+ -- ^ A variable, such as @x@+ | Expr'Str Str'Dynamic+ -- ^ A string, quoted in the traditional form using a single+ -- double-quote (@"@ ... @"@)+ | Expr'Str'Indented InStr+ -- ^ A string in \"indented string\" form, using two single-quotes+ -- (@''@ ... @''@)+ | Expr'List List+ -- ^ A list is an ordered collection of expressions.+ | Expr'Dict Dict+ -- ^ A dict is an unordered enumerated mapping from strings.+ | Expr'Dot Dot+ -- ^ A dot expression (named after the @.@ character it contains) looks up+ -- the value at a particular key in a dict.+ | Expr'Lambda Lambda+ -- ^ A lambda expression @x: y@ where @x@ is the parameter.+ | Expr'Apply Apply+ -- ^ The application of a function to a single argument.+ | Expr'Let Let+ -- ^ A /let/-/in/ expression consists of a list of variable bindings+ -- followed by an expression.++expression'source :: Expression -> Maybe SourceRange+expression'source =+ \case+ Expr'Var x -> var'source x+ Expr'Str x -> strDynamic'source x+ Expr'Str'Indented x -> inStr'source x+ Expr'List x -> list'source x+ Expr'Dict x -> dict'source x+ Expr'Dot x -> dot'source x+ Expr'Lambda x -> lambda'source x+ Expr'Apply x -> apply'source x+ Expr'Let x -> let'source x++expression'discardSource :: Expression -> Expression+expression'discardSource =+ \case+ Expr'Var x -> Expr'Var $ var'discardSource x+ Expr'Str x -> Expr'Str $ str'dynamic'discardSource x+ Expr'Str'Indented x -> Expr'Str'Indented $ inStr'discardSource x+ Expr'List x -> Expr'List $ list'discardSource x+ Expr'Dict x -> Expr'Dict $ dict'discardSource x+ Expr'Dot x -> Expr'Dot $ dot'discardSource x+ Expr'Lambda x -> Expr'Lambda $ lambda'discardSource x+ Expr'Apply x -> Expr'Apply $ apply'discardSource x+ Expr'Let x -> Expr'Let $ let'discardSource x+++--------------------------------------------------------------------------------+-- Variables+--------------------------------------------------------------------------------++{- | A /variable/ @x@, as in the lambda calculus sense, is in one of two+positions:++ 1. A binding, which may take a number of forms:+ - @x:@ ... ('Param'Name')+ - @let x =@ ... @; in@ ... ('LetBinding'Eq')+ - @let inherit (@ ... @) x; in@ ... ('LetBinding'Inhherit')+ 2. A contextual reference to a lambda head or /let/ binding in which @x@ is+ bound:+ - The expression @x@ by itself+ - An @inherit@ binding in a dict expression ('DictBinding'Inherit'Var')++==== Syntax++Variables are always written without quotes.++Unquoted strings are used for variables ('Expr'Var') and places that bind+variables ('Lambda' and 'Let').++-}++data Var =+ Var+ { var'str :: UnquotedString+ , var'source :: Maybe SourceRange+ }++var'text :: Var -> Text+var'text (Var x _) = unquotedString'text x++var'to'str'static :: Var -> Str'Static+var'to'str'static x =+ Str'Static (var'text x) (var'source x)++var'to'str'dynamic :: Var -> Str'Dynamic+var'to'str'dynamic =+ str'static'to'dynamic . var'to'str'static++var'discardSource :: Var -> Var+var'discardSource x =+ Var+ { var'str = var'str x+ , var'source = Nothing+ }+++--------------------------------------------------------------------------------+-- Static strings+--------------------------------------------------------------------------------++{- | A fixed string value. We use the description "static" to mean the string+may not contain antiquotation, in contrast with 'Str'Dynamic' which can. -}++data Str'Static =+ Str'Static+ { str'static'text :: Text+ , str'static'source :: Maybe SourceRange+ }++str'static'append :: Str'Static -> Str'Static -> Str'Static+str'static'append (Str'Static t1 s1) (Str'Static t2 s2) =+ Str'Static (Text.append t1 t2) (sourceRangeMaybe'join s1 s2)++instance Semigroup Str'Static where (<>) = str'static'append++str'static'discardSource :: Str'Static -> Str'Static+str'static'discardSource x =+ Str'Static+ { str'static'text = str'static'text x+ , str'static'source = Nothing+ }+++--------------------------------------------------------------------------------+-- Dynamic strings+--------------------------------------------------------------------------------++{- | A /dynamic string/ is 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.++This is the type of string expressions ('Expr'Str').++==== String syntax++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. -}++data Str'Dynamic =+ Str'Dynamic+ { strDynamic'toSeq :: Seq Str'1+ , strDynamic'source :: Maybe SourceRange+ }++str'dynamic'discardSource :: Str'Dynamic -> Str'Dynamic+str'dynamic'discardSource x =+ Str'Dynamic+ { strDynamic'source = Nothing+ , strDynamic'toSeq = fmap str'1'discardSource (strDynamic'toSeq x)+ }++str'dynamic'append :: Str'Dynamic -> Str'Dynamic -> Str'Dynamic+str'dynamic'append (Str'Dynamic x1 y1) (Str'Dynamic x2 y2) =+ Str'Dynamic (Seq.append x1 x2) (sourceRangeMaybe'join y1 y2)++instance Semigroup Str'Dynamic where (<>) = str'dynamic'append++{- | One part of a 'Str'Dynamic'. -}++data Str'1+ = Str'1'Literal Str'Static+ | Str'1'Antiquote Expression++str'1'discardSource :: Str'1 -> Str'1+str'1'discardSource =+ \case+ Str'1'Literal x -> Str'1'Literal (str'static'discardSource x)+ Str'1'Antiquote x -> Str'1'Antiquote (expression'discardSource x)++{- | Simplify a dynamic string by combining consecutive pieces of static text.+-}++-- | ==== Examples+--+-- >>> :{+-- >>> str :: Text -> Str'1+-- >>> str x = Str'1'Literal $ Str'Static x Nothing+-- >>>+-- >>> var :: Text -> Str'1+-- >>> var x = Str'1'Antiquote . Expr'Var $+-- >>> Var (unquotedString'orThrow x) Nothing+-- >>> :}+--+-- >>> :{+-- >>> str'dynamic'normalize $ Str'Dynamic (Seq.fromList+-- >>> [str "a", str "b", var "x", var "y", str "c", str "d"]) Nothing+-- >>> :}+-- str ["ab", antiquote (var "x"), antiquote (var "y"), "cd"]++str'dynamic'normalize :: Str'Dynamic -> Str'Dynamic+str'dynamic'normalize s =+ s{ strDynamic'toSeq = f (strDynamic'toSeq s) }+ where+ f = Seq.fromList+ . List.concat+ . List.map (\case+ Right xs -> [Str'1'Literal (List.foldr1 str'static'append xs)]+ Left xs -> xs+ )+ . List.groupEither+ . List.map (\case+ Str'1'Literal x -> Right x+ x -> Left x+ )+ . Seq.toList+++--------------------------------------------------------------------------------+-- Indented strings+--------------------------------------------------------------------------------+++{- | 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. -}++data InStr =+ InStr+ { inStr'toSeq :: Seq InStr'1+ , inStr'source :: Maybe SourceRange+ }++inStr'toList :: InStr -> [InStr'1]+inStr'toList =+ Seq.toList . inStr'toSeq++inStr'discardSource :: InStr -> InStr+inStr'discardSource x =+ InStr+ { inStr'toSeq = fmap inStr'1'discardSource (inStr'toSeq x)+ , inStr'source = Nothing+ }++{- | 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'indentSource :: Maybe SourceRange+ -- ^ The source position of the leading space characters+ , inStr'1'str :: Seq Str'1+ -- ^ The meat of the line, after any leading spaces and before the line+ -- break.+ , inStr'1'lineBreak :: Maybe Str'Static+ -- ^ The line break at the end, if any; all lines but the last one+ -- should have a line break+ }++inStr'1'discardSource :: InStr'1 -> InStr'1+inStr'1'discardSource x =+ InStr'1+ { inStr'1'level = inStr'1'level x+ , inStr'1'indentSource = Nothing+ , inStr'1'str = fmap str'1'discardSource (inStr'1'str x)+ , inStr'1'lineBreak = fmap str'static'discardSource (inStr'1'lineBreak x)+ }++inStr'1'toStrParts :: InStr'1 -> Seq Str'1+inStr'1'toStrParts x =+ indent <> inStr'1'str x <> end++ where+ indent :: Seq Str'1+ indent =+ case inStr'1'level x of+ 0 -> Seq.empty+ level ->+ Seq.singleton . Str'1'Literal $+ Str'Static+ (Text.replicate (fromIntegral level) " ")+ (inStr'1'indentSource x)++ end :: Seq Str'1+ end =+ maybe Seq.empty (Seq.singleton . Str'1'Literal) $+ inStr'1'lineBreak x++{- | Determine how many characters of whitespace to strip from an indented+string. -}++inStr'level :: InStr -> Natural+inStr'level =+ maybe 0 id+ . List.minimum+ . catMaybes+ . List.map (\x ->+ if Seq.null (inStr'1'str x)+ then Nothing+ else Just (inStr'1'level x)+ )+ . inStr'toList++{- | 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 x =+ let+ b = inStr'level x+ in+ x { inStr'toSeq = inStr'toSeq x <&>+ (\l ->+ l { inStr'1'level = let a = inStr'1'level l+ in if a >= b then a - b else 0+ })+ }++inStr'to'strDynamic :: InStr -> Str'Dynamic+inStr'to'strDynamic =+ inStr'trim >>>+ inStr'dedent >>>+ (\inStr ->+ Str'Dynamic+ (Seq.concatMap inStr'1'toStrParts (inStr'toSeq inStr))+ (inStr'source inStr)+ ) >>>+ str'dynamic'normalize++{- | Remove any empty lines from the beginning or end of an indented string,+and remove the newline from the final nonempty line. -}++inStr'trim :: InStr -> InStr+inStr'trim x =+ x { inStr'toSeq = inStr'toSeq x+ & Seq.trimWhile (Seq.null . inStr'1'str)+ & Seq.adjustLast (\y -> y { inStr'1'lineBreak = Nothing })+ }+++--------------------------------------------------------------------------------+-- Conversions between types of strings+--------------------------------------------------------------------------------++-- | ==== Examples+--+-- >>> str'dynamic'to'static $ Str'Dynamic (Seq.fromList []) Nothing+-- Just ""+--+-- >>> a = Str'1'Literal (Str'Static "hi" Nothing)+--+-- >>> b = Str'1'Antiquote $ Expr'Var $ Var (unquotedString'orThrow "x") Nothing+--+-- >>> str'dynamic'to'static $ Str'Dynamic (Seq.fromList [ a ]) Nothing+-- Just "hi"+--+-- >>> str'dynamic'to'static $ Str'Dynamic (Seq.fromList [ a, b ]) Nothing+-- Nothing++str'dynamic'to'static :: Str'Dynamic -> Maybe Str'Static+str'dynamic'to'static x =+ case Seq.toList (strDynamic'toSeq x) of+ [] -> Just (Str'Static "" (strDynamic'source x))+ [Str'1'Literal a] -> Just (a{ str'static'source = strDynamic'source x })+ _ -> Nothing++str'static'to'dynamic :: Str'Static -> Str'Dynamic+str'static'to'dynamic x =+ Str'Dynamic (Seq.singleton (Str'1'Literal x)) (str'static'source x)+++--------------------------------------------------------------------------------+-- Lambda+--------------------------------------------------------------------------------++{- | A function expressed as a lambda abstraction.++==== Syntax++A lambda expression ('Expr'Lambda') has the form @x: y@ where @x@ is the+function parameter to bind in the function body @y@.++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 ]++-}++data Lambda =+ Lambda+ { lambda'head :: Param+ -- ^ Declaration of the function's parameter+ , lambda'body :: Expression+ -- ^ Body of the function; what it evaluates to+ , lambda'source :: Maybe SourceRange+ }++lambda'discardSource :: Lambda -> Lambda+lambda'discardSource x =+ Lambda+ { lambda'head = param'discardSource (lambda'head x)+ , lambda'body = expression'discardSource (lambda'body x)+ , lambda'source = Nothing+ }+++--------------------------------------------------------------------------------+-- Apply+--------------------------------------------------------------------------------++{- | The application of a function to a single argument.++==== Syntax++An function application expression ('Expr'Apply') looks like this:++> f x++If a function has multiple (curried) parameters, you can chain them together+like so:++> f x y z++-}++data Apply =+ Apply+ { apply'func :: Expression+ -- ^ The function being called+ , apply'arg :: Expression+ -- ^ The argument to the function+ , apply'source :: Maybe SourceRange+ }++expression'applyArgs+ :: Expression -- ^ Function+ -> [Expression] -- ^ Args+ -> Expression -- ^ Function application+expression'applyArgs =+ foldl f+ where+ f acc b =+ Expr'Apply (Apply acc b src)+ where+ src =+ sourceRangeMaybe'join+ (expression'source acc)+ (expression'source b)++apply'discardSource :: Apply -> Apply+apply'discardSource x =+ Apply+ { apply'func = expression'discardSource (apply'func x)+ , apply'arg = expression'discardSource (apply'arg x)+ , apply'source = Nothing+ }+++--------------------------------------------------------------------------------+-- Param+--------------------------------------------------------------------------------++{- | 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 Var+ -- ^ A simple single-parameter function+ | Param'DictPattern DictPattern+ -- ^ Dict destructuring, which gives you something resembling multiple+ -- named parameters with default values+ | Param'Both Var DictPattern+ -- ^ Both a param name /and/ a dict pattern, separated by the @\@@+ -- keyword++param'discardSource :: Param -> Param+param'discardSource =+ \case+ Param'Name x ->+ Param'Name (var'discardSource x)+ Param'DictPattern x ->+ Param'DictPattern (dictPattern'discardSource x)+ Param'Both x y ->+ Param'Both (var'discardSource x) (dictPattern'discardSource y)+++--------------------------------------------------------------------------------+-- Dict pattern+--------------------------------------------------------------------------------++{- | 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+ }++dictPattern'discardSource :: DictPattern -> DictPattern+dictPattern'discardSource x =+ DictPattern+ { dictPattern'items = fmap dictPattern'1'discardSource (dictPattern'items x)+ , dictPattern'ellipsis = dictPattern'ellipsis x+ }++{- | One item within a 'DictPattern'. -}+data DictPattern'1 =+ DictPattern'1+ { dictPattern'1'name :: Var+ -- ^ 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+ }++dictPattern'1'discardSource :: DictPattern'1 -> DictPattern'1+dictPattern'1'discardSource x =+ DictPattern'1+ { dictPattern'1'name = var'discardSource (dictPattern'1'name x)+ , dictPattern'1'default =+ fmap expression'discardSource (dictPattern'1'default x)+ }+++--------------------------------------------------------------------------------+-- List+--------------------------------------------------------------------------------++{- | A list is an ordered collection.++==== Syntax++A list expression ('Expr'List') starts with @[@, ends with @]@, and contains any+number of expressions in between.++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)+> ]++-}++data List =+ List+ { list'expressions :: Seq Expression+ , list'source :: Maybe SourceRange+ }++list'discardSource :: List -> List+list'discardSource x =+ List+ { list'expressions = fmap expression'discardSource (list'expressions x)+ , list'source = Nothing+ }+++--------------------------------------------------------------------------------+-- Dict+--------------------------------------------------------------------------------++{- | A dict is an unordered enumerated mapping from strings.++==== Syntax++A dict expression ('Expr'Dict') starts with @{@ or @rec {@, ends with @}@, and+contains any number of 'DictBinding's in between.++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; }++-}++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 @}@)+ , dict'source :: Maybe SourceRange+ }++dict'discardSource :: Dict -> Dict+dict'discardSource x =+ Dict+ { dict'rec = dict'rec x+ , dict'bindings = fmap dictBinding'discardSource (dict'bindings x)+ , dict'source = Nothing+ }++{- | A binding within a 'Dict'. -}++data DictBinding+ = DictBinding'Eq Expression Expression+ -- ^ A binding of the form @x = y;@+ | DictBinding'Inherit'Dict Expression (Seq Str'Static)+ | DictBinding'Inherit'Var (Seq Var)++dictBinding'discardSource :: DictBinding -> DictBinding+dictBinding'discardSource =+ \case+ DictBinding'Eq a b ->+ DictBinding'Eq+ (expression'discardSource a)+ (expression'discardSource b)+ DictBinding'Inherit'Dict a xs ->+ DictBinding'Inherit'Dict+ (expression'discardSource a)+ (fmap str'static'discardSource xs)+ DictBinding'Inherit'Var xs ->+ DictBinding'Inherit'Var+ (fmap var'discardSource xs)+++--------------------------------------------------------------------------------+-- Dot+--------------------------------------------------------------------------------++{- | The /dot/ function looks up a value (or a list of values) from a dict.++==== Syntax++A dot expression is named after the @.@ character it contains. @a.b@ looks up+value at key @b@ in the dict @a@.++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 }++-}++data Dot =+ Dot+ { dot'dict :: Expression+ , dot'key :: Expression+ , dot'source :: Maybe SourceRange+ }++expression'applyDots+ :: Expression -- ^ Dict+ -> [Expression] -- ^ Lookups+ -> Expression -- ^ Dot expression+expression'applyDots =+ foldl f+ where+ f acc b =+ Expr'Dot (Dot acc b src)+ where+ src =+ sourceRangeMaybe'join+ (expression'source acc)+ (expression'source b)++dot'discardSource :: Dot -> Dot+dot'discardSource x =+ Dot+ { dot'dict = expression'discardSource (dot'dict x)+ , dot'key = expression'discardSource (dot'key x)+ , dot'source = Nothing+ }+++--------------------------------------------------------------------------------+-- Let+--------------------------------------------------------------------------------++{- | ==== Syntax++A /let/-/in/ expression ('Expr'Let') looks like this:++> 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. -}++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)+ , let'source :: Maybe SourceRange+ }++let'discardSource :: Let -> Let+let'discardSource x =+ Let+ { let'bindings = fmap letBinding'discardSource (let'bindings x)+ , let'value = expression'discardSource (let'value x)+ , let'source = Nothing+ }++{- | A semicolon-terminated binding within the binding list of a 'Let'+expression. -}++data LetBinding+ = LetBinding'Eq Var Expression+ -- ^ A binding with an equals sign, of the form @x = y;@+ | LetBinding'Inherit Expression (Seq Var)+ -- ^ A binding using the @inherit@ keyword, of the form @inherit (x) a b;@++letBinding'discardSource :: LetBinding -> LetBinding+letBinding'discardSource =+ \case+ LetBinding'Eq a b ->+ LetBinding'Eq+ (var'discardSource a)+ (expression'discardSource b)+ LetBinding'Inherit a b ->+ LetBinding'Inherit+ (expression'discardSource a)+ (fmap var'discardSource 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 show = Text.unpack . show'expression++instance Show Var where show = Text.unpack . show'var+instance Show Str'Static where show = Text.unpack . show'str'static+instance Show Str'Dynamic where show = Text.unpack . show'str'dynamic+instance Show Str'1 where show = Text.unpack . show'str'1+instance Show InStr where show = Text.unpack . show'str'indented+instance Show InStr'1 where show = Text.unpack . show'str'indented'1+instance Show List where show = Text.unpack . show'list+instance Show Dict where show = Text.unpack . show'dict+instance Show DictBinding where show = Text.unpack . show'dictBinding+instance Show Dot where show = Text.unpack . show'dot+instance Show Lambda where show = Text.unpack . show'lambda+instance Show Param where show = Text.unpack . show'param+instance Show DictPattern where show = Text.unpack . show'dictPattern+instance Show DictPattern'1 where show = Text.unpack . show'dictPattern'1+instance Show Apply where show = Text.unpack . show'apply+instance Show Let where show = Text.unpack . show'let+instance Show LetBinding where show = Text.unpack . show'letBinding++show'expression :: Expression -> Text+show'expression =+ \case+ Expr'Var x -> show'var x+ Expr'Str x -> show'str'dynamic x+ Expr'Str'Indented x -> show'str'indented x+ Expr'List x -> show'list x+ Expr'Dict x -> show'dict x+ Expr'Dot x -> show'dot x+ Expr'Lambda x -> show'lambda x+ Expr'Apply x -> show'apply x+ Expr'Let x -> show'let x++source'comment :: Maybe SourceRange -> Maybe Text+source'comment =+ fmap $ \x -> "{- " <> show'sourceRange x <> " -}"++show'var :: Var -> Text+show'var (Var x s) =+ maybe "" (<> " ") (source'comment s) <>+ "var " <> (Text.show @Text . unquotedString'text) x++show'str'static :: Str'Static -> Text+show'str'static (Str'Static x s) =+ maybe "" (<> " ") (source'comment s) <>+ Text.show @Text x++show'str'dynamic :: Str'Dynamic -> Text+show'str'dynamic (Str'Dynamic xs s) =+ maybe "" (<> " ") (source'comment s) <>+ "str [" <> Text.intercalateMap ", " show'str'1 xs <> "]"++show'str'1 :: Str'1 -> Text+show'str'1 =+ \case+ Str'1'Literal (Str'Static x s) ->+ maybe "" (<> " ") (source'comment s) <> Text.show @Text x+ Str'1'Antiquote x ->+ "antiquote (" <> show'expression x <> ")"++show'str'indented :: InStr -> Text+show'str'indented x =+ maybe "" (<> " ") (source'comment (inStr'source x)) <>+ "str'indented [" <>+ Text.intercalateMap ", " show'str'indented'1 (inStr'toSeq x) <>+ "]"++show'str'indented'1 :: InStr'1 -> Text+show'str'indented'1 x =+ "indent " <>+ maybe "" (<> " ") (source'comment (inStr'1'indentSource x)) <>+ Text.show @Natural (inStr'1'level x) <>+ " [" <>+ Text.intercalateMap ", " (Text.show @Str'1) (Seq.toList (inStr'1'str x)) <>+ "] " <>+ case inStr'1'lineBreak x of+ Nothing -> "Nothing"+ Just a -> "(Just " <> Text.show @Str'Static a <> ")"++show'list :: List -> Text+show'list (List xs s) =+ maybe "" (<> " ") (source'comment s) <>+ "list [" <> Text.intercalateMap ", " show'expression xs <> "]"++show'dict :: Dict -> Text+show'dict (Dict r bs s) =+ maybe "" (<> " ") (source'comment s) <>+ (if r then "rec'dict [" else "dict [") <>+ Text.intercalateMap ", " show'dictBinding bs <> "]"++show'dictBinding :: DictBinding -> Text+show'dictBinding =+ \case+ DictBinding'Eq a b ->+ "dict'eq (" <> show'expression a <> ") (" <> show'expression b <> ")"+ DictBinding'Inherit'Var xs ->+ "dict'inherit [" <>+ Text.intercalateMap ", " (Text.show @Text . var'text) xs <> "]"+ DictBinding'Inherit'Dict from xs ->+ "dict'inherit'from (" <> show'expression from <> ") [" <>+ Text.intercalateMap ", " show'str'static xs <> "]"++show'dot :: Dot -> Text+show'dot (Dot a b s) =+ maybe "" (<> " ") (source'comment s) <>+ "dot (" <> show'expression a <> ") (" <> show'expression b <> ")"++show'lambda :: Lambda -> Text+show'lambda (Lambda a b s) =+ maybe "" (<> " ") (source'comment s) <>+ "lambda (" <> show'param a <> ") (" <> show'expression b <> ")"++show'param :: Param -> Text+show'param =+ \case+ Param'Name a -> "param " <> Text.show @Text (var'text a)+ Param'DictPattern b -> show'dictPattern b+ Param'Both a b -> "param " <> Text.show @Text (var'text a) <>+ " <> " <> show'dictPattern b++show'dictPattern :: DictPattern -> Text+show'dictPattern (DictPattern xs e) =+ "pattern [" <> Text.intercalateMap ", " show'dictPattern'1 xs <> "]" <>+ (if e then " <> ellipsis" else "")++show'dictPattern'1 :: DictPattern'1 -> Text+show'dictPattern'1 (DictPattern'1 a mb) =+ "dict'param " <> Text.show @Text (var'text a) <>+ maybe "" (\b -> " & def (" <> show'expression b <> ")") mb++show'apply :: Apply -> Text+show'apply (Apply a b s) =+ maybe "" (<> " ") (source'comment s) <>+ "apply (" <> show'expression a <> ") (" <> show'expression b <> ")"++show'let :: Let -> Text+show'let (Let xs y s) =+ maybe "" (<> " ") (source'comment s) <>+ "let'in [" <> Text.intercalateMap ", " show'letBinding xs <> "] (" <>+ show'expression y <> ")"++show'letBinding :: LetBinding -> Text+show'letBinding =+ \case+ LetBinding'Eq a b ->+ "let'eq " <> Text.show @Text (var'text a) <>+ " (" <> show'expression b <> ")"+ LetBinding'Inherit from xs ->+ "let'inherit'from (" <> show'expression from <> ") [" <>+ Text.intercalateMap ", " (Text.show @Text . var'text) xs <> "]"
+ src/Bricks/Expression/Construction.hs view
@@ -0,0 +1,292 @@+{-# 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:++ - 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+ (++ -- * Lambdas+ lambda++ -- * Function application+ , apply++ -- * Variables+ , var++ -- * Dot+ , dot++ -- * List+ , list++ -- * Let+ , let'in+ , let'eq+ , let'inherit'from++ -- * Dict+ , dict+ , rec'dict+ , dict'eq+ , dict'inherit'from+ , dict'inherit++ -- * Dynamic strings+ , str+ , antiquote+ , Str'1'IsString (..)++ -- * Indented strings+ , str'indented+ , indent++ -- * Param builder+ , Param'Builder (..)+ , param+ , pattern+ , dict'param+ , def+ , ellipsis++ -- * Re-exports+ , Expression+ , (<>)+ , (&)+ , Maybe (Just, Nothing)++ ) 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 Nothing+++--------------------------------------------------------------------------------+-- Function application+--------------------------------------------------------------------------------++apply :: Expression -> Expression -> Expression+apply a b =+ Expr'Apply $ Apply a b Nothing+++--------------------------------------------------------------------------------+-- Variables+--------------------------------------------------------------------------------++var :: Text -> Expression+var x =+ Expr'Var $ Var (unquotedString'orThrow x) Nothing+++--------------------------------------------------------------------------------+-- Dots+--------------------------------------------------------------------------------++dot :: Expression -> Expression -> Expression+dot a b =+ Expr'Dot $ Dot a b Nothing+++--------------------------------------------------------------------------------+-- List+--------------------------------------------------------------------------------++list :: [Expression] -> Expression+list x =+ Expr'List $ List (Seq.fromList x) Nothing+++--------------------------------------------------------------------------------+-- Let+--------------------------------------------------------------------------------++let'in :: [LetBinding] -> Expression -> Expression+let'in a b =+ Expr'Let $ Let (Seq.fromList a) b Nothing++let'eq :: Text -> Expression -> LetBinding+let'eq a b =+ LetBinding'Eq (Var (unquotedString'orThrow a) Nothing) b++let'inherit'from :: Expression -> [Text] -> LetBinding+let'inherit'from a b =+ LetBinding'Inherit+ a+ (Seq.fromList $ fmap (\x -> Var (unquotedString'orThrow x) Nothing) b)+++--------------------------------------------------------------------------------+-- Dicts+--------------------------------------------------------------------------------++dict :: [DictBinding] -> Expression+dict x =+ Expr'Dict $ Dict False (Seq.fromList x) Nothing++rec'dict :: [DictBinding] -> Expression+rec'dict x =+ Expr'Dict $ Dict False (Seq.fromList x) Nothing++dict'eq :: Expression -> Expression -> DictBinding+dict'eq =+ DictBinding'Eq++dict'inherit'from :: Expression -> [Text] -> DictBinding+dict'inherit'from a b =+ DictBinding'Inherit'Dict+ a+ (Seq.fromList (fmap (\x -> Str'Static x Nothing) b))++dict'inherit :: [Text] -> DictBinding+dict'inherit a =+ DictBinding'Inherit'Var+ (Seq.fromList $ fmap (\x -> Var (unquotedString'orThrow x) Nothing) a)+++--------------------------------------------------------------------------------+-- Dynamic strings+--------------------------------------------------------------------------------++str :: [Str'1'IsString] -> Expression+str xs =+ Expr'Str $ Str'Dynamic (Seq.fromList (fmap unStr'1'IsString xs)) Nothing++antiquote :: Expression -> Str'1'IsString+antiquote =+ Str'1'IsString . 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'IsString = Str'1'IsString { unStr'1'IsString :: Str'1 }++instance IsString Str'1'IsString+ where+ fromString x =+ Str'1'IsString . Str'1'Literal $ Str'Static (Text.pack x) Nothing+++--------------------------------------------------------------------------------+-- Indented strings+--------------------------------------------------------------------------------++str'indented :: [InStr'1] -> Expression+str'indented xs =+ Expr'Str'Indented $ InStr (Seq.fromList xs) Nothing++indent :: Natural -> [Str'1'IsString] -> Maybe Text -> InStr'1+indent n xs lbr =+ InStr'1+ n+ Nothing+ (Seq.fromList (fmap unStr'1'IsString xs))+ (fmap (\x -> Str'Static x Nothing) lbr)+++--------------------------------------------------------------------------------+-- Param builder+--------------------------------------------------------------------------------++newtype Param'Builder = Param'Builder (NonEmpty Param)+ deriving Semigroup++paramBuilder :: Param -> Param'Builder+paramBuilder x =+ Param'Builder (x :| [])++param :: Text -> Param'Builder+param x =+ paramBuilder . Param'Name $ Var (unquotedString'orThrow x) Nothing++buildParam :: Param'Builder -> Param+buildParam (Param'Builder xs) =+ foldr1 mergeParams xs++pattern :: [DictPattern'1] -> Param'Builder+pattern xs =+ paramBuilder $ Param'DictPattern $ DictPattern (Seq.fromList xs) False++dict'param :: Text -> DictPattern'1+dict'param x =+ Bricks.Expression.DictPattern'1+ (Var (unquotedString'orThrow x) Nothing)+ Nothing++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)
+ src/Bricks/Keyword.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Bricks.Keyword+ (+ -- * Type+ Keyword++ -- * List of keywords+ , keywords++ -- * The keywords+ , keyword'rec+ , keyword'let+ , keyword'in+ , 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'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'inherit :: Keyword+keyword'inherit = Keyword "inherit"++keyword'inlineComment :: Keyword+keyword'inlineComment = Keyword "--"
+ src/Bricks/Source.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{- |++Source information is some form of description of where a Bricks expression or+term /came from/. This information is used to tag 'Expression's and 'Term's so+that our error messages can tell the user what parts of the Bricks source code+are relevant to the problem.++Overview of the types involved:++ - 'SourcePosition' - a line and column number+ - 'SourceRange' - a pair of 'SourcePosition's indicating the start and end of+ some expression+ - 'SourceName' - a description of where the top-level expression was parsed+ from, such as a file path or a part of a REPL session.+ - '()' can be used as the source information type in cases where we do not+ actually care to retain any source information.++-}+module Bricks.Source where++-- Bricks internal+import Bricks.Internal.Prelude+import Bricks.Internal.Text (Text)+import qualified Bricks.Internal.Text as Text+++--------------------------------------------------------------------------------+-- SourcePosition+--------------------------------------------------------------------------------++{- | An endpoint of a 'SourceRange'. -}++data SourcePosition =+ SourcePosition+ { sourcePosition'line :: Natural+ , sourcePosition'column :: Natural+ }+ deriving (Eq, Ord)++instance Show SourcePosition where show = Text.unpack . show'sourcePosition++show'sourcePosition :: SourcePosition -> Text+show'sourcePosition (SourcePosition a b) =+ Text.show @Natural a <> ":" <> Text.show @Natural b++++--------------------------------------------------------------------------------+-- SourceRange+--------------------------------------------------------------------------------++{- | Start and end points for a span of text. When we parse text into an+'Expression', we annotate it with source ranges so error messages that refer to+specific expressions can tell the user where in their Bricks code those+expressions are defined. -}++data SourceRange =+ SourceRange+ { sourceRange'start :: SourcePosition+ , sourceRange'end :: SourcePosition+ }++instance Show SourceRange where show = Text.unpack . show'sourceRange++show'sourceRange :: SourceRange -> Text+show'sourceRange (SourceRange a b) =+ show'sourcePosition a <> "-" <> show'sourcePosition b++sourceRange'join :: SourceRange -> SourceRange -> SourceRange+sourceRange'join (SourceRange a1 a2) (SourceRange b1 b2) =+ SourceRange (min a1 b1) (max a2 b2)++instance Semigroup SourceRange+ where+ (<>) = sourceRange'join++sourceRangeMaybe'join+ :: Maybe SourceRange -> Maybe SourceRange -> Maybe SourceRange+sourceRangeMaybe'join (Just x) (Just y) = Just (sourceRange'join x y)+sourceRangeMaybe'join _ _ = Nothing+++--------------------------------------------------------------------------------+-- SourceName+--------------------------------------------------------------------------------++newtype SourceName a = SourceName a
+ src/Bricks/UnquotedString.hs view
@@ -0,0 +1,124 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Bricks.UnquotedString+ (+ -- * Type+ UnquotedString++ -- * Construction+ , unquotedString'try+ , unquotedString'orThrow++ -- * Deconstruction+ , unquotedString'text++ -- * Predicates+ , text'canBeUnquoted+ , char'canBeUnquoted++ ) 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 'text'canBeUnquoted' for the full rules.++This type does not represent a particular part of Bricks syntax, but it is a+wrapper for 'Text' that enforces the limitations of strings at various places in+the Bricks syntax.++==== Construction++ - 'unquotedString'try'+ - 'unquotedString'orThrow'++==== Deconstruction++ - 'unquotedString'text'++==== See also++ - 'text'canBeUnquoted'+ - 'char'canBeUnquoted'++-}++newtype UnquotedString = UnquotedString { unquotedString'text :: Text }++instance Show UnquotedString where show = show @Text . unquotedString'text++{- | ==== Properties++ - A text value may be used to construct an 'UnquotedString' iff it satisfies+ 'text'canBeUnquoted'.++ @'text'canBeUnquoted' x = 'isJust' ('unquotedString'try' x)@ -}++unquotedString'try :: Text -> Maybe UnquotedString+unquotedString'try x =+ if text'canBeUnquoted x then Just (UnquotedString x) else Nothing++-- | Throws an exception if the string cannot render unquoted.+unquotedString'orThrow :: Text -> UnquotedString+unquotedString'orThrow x =+ if text'canBeUnquoted x then UnquotedString x else+ error $ "String " <> show x <> " cannot render unquoted"++{- | Whether a string having this name can be rendered without quoting it.++==== Requirements for unquoted strings++We allow a string to render unquoted if all these conditions are met:++- The string is nonempty+- All characters satify 'char'canBeUnquoted'+- The string is not a keyword++==== Properties++ - A text value may be used to construct an 'UnquotedString' iff it satisfies+ 'text'canBeUnquoted'.++ @'text'canBeUnquoted' x = 'isJust' ('unquotedString'try' x)@ -}++-- | ==== Examples+--+-- >>> text'canBeUnquoted "-ab_c"+-- True+--+-- >>> text'canBeUnquoted ""+-- False+--+-- >>> text'canBeUnquoted "a\"b"+-- False+--+-- >>> text'canBeUnquoted "let"+-- False++text'canBeUnquoted :: Text -> Bool+text'canBeUnquoted x =+ Text.all char'canBeUnquoted x+ && not (Text.null x)+ && List.all ((/= x) . keywordText) keywords++{- | Whether the character is allowed to be included in an 'UnquotedString'.+Such characters are letters, @+@, @-@, @*@, @/@, and @_@.++This is used in the implementation of 'text'canBeUnquoted'. -}++char'canBeUnquoted :: Char -> Bool+char'canBeUnquoted c =+ Char.isLetter c || List.elem c ("+-*/_" :: [Char])
+ test-data/expression-show-examples.txt view
@@ -0,0 +1,16 @@+--+-- This file contains example outputs from the Show instance for Expressions+-- that have no source information.+--++dot (var "a") (str ["b"])++dot (var "a") (var "b")++dot (str ["a"]) (str ["b", antiquote (var "c")])++lambda (param "a" <> pattern [dict'param "f", dict'param "b" & def (apply (var "g") (var "x"))] <> ellipsis) (apply (var "f") (var "b"))++let'in [let'eq "d" (dict [dict'eq (str ["a"]) (str ["b", antiquote (var "c")]), dict'inherit'from (var "x") ["y", "z"]])] (dot (var "d") (str ["y"]))++str'indented [indent 0 ["abc"] (Just "\n"), indent 2 ["def"] Nothing]
+ test/doctest.hs view
@@ -0,0 +1,4 @@+import Test.DocTest (doctest)++main :: IO ()+main = doctest ["src", "-XOverloadedStrings"]
+ test/show.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{-++This test suite verifies that the 'Show' instance for 'Expression' outputs code+which can be used to reconstruct the 'Expression' using the functions in+"Bricks.Expression.Construction".++For each of the example Haskell expressions in the @show-example.txt@ file, we+do the following:++ 1. Use GHC to evaluate the Haskell expression to get a Bricks 'Expression'.+ 2. Call 'show' on the 'Expression', and verify that the result is equal to the+ original input.++-}++import Paths_bricks_syntax (getDataFileName)++-- Bricks+import Bricks.Expression++-- Bricks internal+import qualified Bricks.Internal.List as List+import Bricks.Internal.Prelude+import Bricks.Internal.Text (Text)+import qualified Bricks.Internal.Text as Text++-- text+import qualified Data.Text as Text (lines)+import qualified Data.Text.IO as Text (hPutStr, readFile)++-- exceptions+import Control.Monad.Catch (try)++-- hint+import qualified Language.Haskell.Interpreter as H++-- base+import Control.Monad (unless)+import Prelude (Int, Num (..))+import qualified System.Exit as Exit+import System.IO (IO)+import qualified System.IO as IO++put :: Text -> IO ()+put = Text.hPutStr IO.stderr++main :: IO ()+main =+ do+ examples <- getExamples++ H.runInterpreter (interpreter'main examples) >>= \case++ Left err -> do+ put $ showInterpreterError err+ put "\n"+ Exit.exitFailure++ Right failures -> do+ traverse_ printFailure failures+ traverse_ put+ [ "Out of "+ , Text.show @Int $ List.length examples+ , " total tests run, there were "+ , Text.show @Int $ List.length examples - List.length failures+ , " success"+ , if List.length failures == 1 then "" else "es"+ , " and "+ , Text.show @Int $ List.length failures+ , " failure"+ , if List.length failures == 1 then "" else "s"+ , ".\n"+ ]++ unless (List.null failures) Exit.exitFailure++getExamples :: IO [Example]+getExamples =+ do+ path <- getDataFileName "test-data/expression-show-examples.txt"+ text <- Text.readFile path+ pure (parseExamples text)++data Example =+ Example+ { example'lineNumber :: Natural+ , example'text :: Text+ }++parseExamples :: Text -> [Example]+parseExamples =+ List.map (\xs -> Example+ { example'lineNumber = fst (List.head xs)+ , example'text = Text.intercalateMap "\n" snd xs+ }) .+ catMaybes .+ List.map (either (const Nothing) Just) .+ List.groupEither .+ List.map+ (\(a, b) ->+ if Text.null b || "--" `Text.isPrefixOf` b+ then Left ()+ else Right (a, b)+ ) .+ List.zip [1..] .+ Text.lines++data Failure =+ Failure+ { failure'example :: Example+ , failure'outcome :: Text+ }++printFailure :: Failure -> IO ()+printFailure Failure{ failure'example = Example { example'lineNumber }+ , failure'outcome } =+ traverse_ put+ [ "For the example starting on line "+ , Text.show @Natural example'lineNumber+ , ", we got the following incorrect result: \n"+ , failure'outcome+ , "\n"+ , Text.replicate 40 "-"+ , "\n"+ ]++interpreter'main :: [Example] -> H.Interpreter [Failure]+interpreter'main examples =+ do+ H.set [ H.languageExtensions H.:= [ H.OverloadedStrings ] ]+ H.setImports+ [ "Bricks.Expression"+ , "Bricks.Expression.Construction"+ ]++ catMaybes <$> traverse testExample examples++testExample :: Example -> H.Interpreter (Maybe Failure)+testExample x =+ do+ e <- try $ H.interpret (Text.unpack $ example'text x) (H.as :: Expression)+ pure $ case e of+ Left err -> Just $ Failure+ { failure'example = x+ , failure'outcome = showInterpreterError err+ }+ Right expr ->+ let+ s = Text.show expr+ in+ if s == example'text x+ then Nothing+ else Just $ Failure+ { failure'example = x+ , failure'outcome = s+ }++showInterpreterError :: H.InterpreterError -> Text+showInterpreterError =+ \case+ H.WontCompile es ->+ Text.intercalateMap "\n" (\(H.GhcError e) -> Text.pack e) es+ e -> Text.show e