bricks-rendering (empty) → 0.0.0.4
raw patch · 5 files changed
+661/−0 lines, 5 filesdep +basedep +bricks-internaldep +bricks-internal-test
Dependencies added: base, bricks-internal, bricks-internal-test, bricks-rendering, bricks-syntax, containers, doctest, hedgehog, template-haskell, text
Files
- bricks-rendering.cabal +77/−0
- license.txt +13/−0
- src/Bricks/Rendering.hs +412/−0
- test/cases.hs +155/−0
- test/doctest.hs +4/−0
+ bricks-rendering.cabal view
@@ -0,0 +1,77 @@+-- This file has been generated from package.yaml by hpack version 0.20.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: c231732209663f0716d4e8119a1c989bd6016492468f4b8a534b6ded02e4ff1d++name: bricks-rendering+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++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+ , bricks-syntax+ , containers >=0.5.7 && <0.6+ , text >=1.2.2 && <1.3+ exposed-modules:+ Bricks.Rendering+ other-modules:+ Paths_bricks_rendering+ default-language: Haskell2010++test-suite cases+ type: exitcode-stdio-1.0+ main-is: cases.hs+ hs-source-dirs:+ test+ ghc-options: -Wall -threaded+ build-depends:+ base >=4.9 && <4.11+ , bricks-internal+ , bricks-internal-test+ , bricks-rendering+ , bricks-syntax+ , containers >=0.5.7 && <0.6+ , hedgehog >=0.5 && <0.6+ , template-haskell >=2.2 && <2.13+ , text >=1.2.2 && <1.3+ other-modules:+ Paths_bricks_rendering+ 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+ , bricks-syntax+ , containers >=0.5.7 && <0.6+ , doctest >=0.11 && <0.14+ , text >=1.2.2 && <1.3+ other-modules:+ Paths_bricks_rendering+ 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/Rendering.hs view
@@ -0,0 +1,412 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Bricks.Rendering+ (+ -- * @Render@+ Render+ , RenderContext (..)+ , renderContext'default+ , renderContext'terse++ -- * Expressions+ , render'expression+ , render'expression'listContext+ , render'expression'dotLeftContext+ , render'expression'applyLeftContext+ , render'expression'applyRightContext+ , render'expression'inParens+ , render'expression'dictKey++ -- * Variables+ , render'var++ -- * Strings+ , str'escape++ -- ** Static strings+ , render'strStatic'unquotedIfPossible+ , render'strStatic'quoted++ -- ** Dynamic strings+ , render'strDynamic'unquotedIfPossible+ , render'strDynamic'quoted+ , render'str'1++ -- ** Indented strings+ , render'str'indented+ , render'str'indented'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++ ) where++-- Bricks+import Bricks.Expression+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++-- base+import Prelude (Num (..), fromIntegral)++--------------------------------------------------------------------------------++-- $setup+--+-- >>> import Bricks.Expression.Construction++--------------------------------------------------------------------------------++type Render a = RenderContext -> a -> Text++data RenderContext =+ RenderContext+ { renderContext'indentStart :: Natural+ , renderContext'indentStep :: Natural+ , renderContext'lineBreaks :: Bool+ }++renderContext'default :: RenderContext+renderContext'default =+ RenderContext+ { renderContext'indentStart = 0+ , renderContext'indentStep = 2+ , renderContext'lineBreaks = True+ }++renderContext'terse :: RenderContext+renderContext'terse =+ renderContext'default+ { renderContext'lineBreaks = False+ }++indentMore :: RenderContext -> RenderContext+indentMore x =+ x{ renderContext'indentStart = renderContext'indentStart x ++ renderContext'indentStep x }++indentation :: Natural -> Text+indentation n = Text.replicate (fromIntegral n) " "+++--------------------------------------------------------------------------------++{- | 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'var :: Render Var+render'var _cx v = var'text v++{- | Render a static string, in unquoted form if possible. -}++render'strStatic'unquotedIfPossible :: Render Str'Static+render'strStatic'unquotedIfPossible _cx s =+ let+ x = str'static'text s+ in+ if text'canBeUnquoted x+ then x+ else render'strStatic'quoted _cx s++{- | Render a static string, in quoted form. -}++render'strStatic'quoted :: Render Str'Static+render'strStatic'quoted _cx x =+ "\"" <> (str'escape . str'static'text) x <> "\""++{- | Render a dynamic string, in unquoted form if possible. -}++render'strDynamic'unquotedIfPossible :: Render Str'Dynamic+render'strDynamic'unquotedIfPossible cx d =+ case str'dynamic'to'static d of+ Just s -> render'strStatic'unquotedIfPossible cx s+ Nothing -> render'strDynamic'quoted cx d++{- | Render a dynamic string, in quoted form. -}++render'strDynamic'quoted :: Render Str'Dynamic+render'strDynamic'quoted cx xs =+ "\"" <> foldMap (render'str'1 cx) (strDynamic'toSeq xs) <> "\""++render'str'1 :: Render Str'1+render'str'1 cx =+ \case+ Str'1'Literal x -> (str'escape . str'static'text) x+ Str'1'Antiquote x ->+ let cx' = cx{ renderContext'lineBreaks = False }+ in "${" <> render'expression cx' x <> "}"++render'str'indented :: Render InStr+render'str'indented cx (inStr'dedent . inStr'trim -> (InStr xs _)) =+ "''\n" <>+ Text.concatMap (render'str'indented'1 (indentMore cx)) xs <>+ indentation (renderContext'indentStart cx) <> "''"++render'str'indented'1 :: Render InStr'1+render'str'indented'1 cx x =+ indentation (inStr'1'level x + renderContext'indentStart cx) <>+ Text.concatMap (render'str'1 cx) (inStr'1'str x) <>+ "\n"++{- | 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 cx =+ \case+ Param'Name a -> render'var cx a+ Param'DictPattern b -> render'dictPattern cx b+ Param'Both a b -> render'var cx a <> "@" <>+ render'dictPattern cx b++{- | Render a dict pattern (@{ a, b ? c, ... }@). -}++render'dictPattern :: Render DictPattern+render'dictPattern cx (DictPattern bs e) =+ if Seq.null xs+ then "{ }"+ else "{ " <> Text.intercalate ", " xs <> " }"+ where+ xs :: Seq Text+ xs =+ Seq.map (render'dictPattern'1 cx) 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 cx =+ \case+ DictPattern'1 a Nothing -> render'var cx a+ DictPattern'1 a (Just b) -> render'var cx a <> " ? " <>+ render'expression cx b++{- | Render a lambda expression (@x: y@). -}++render'lambda :: Render Lambda+render'lambda cx x =+ render'param cx (lambda'head x) <> ":" <> sp <>+ render'expression cx' (lambda'body x)+ where+ sp = if lbr+ then "\n" <> indentation (renderContext'indentStart cx)+ else " "+ lbr = renderContext'lineBreaks cx+ cx' = indentMore cx++{- | Render a function application expression (@f x@). -}++render'apply :: Render Apply+render'apply cx x =+ render'expression'applyLeftContext cx (apply'func x) <> " " <>+ render'expression'applyRightContext cx (apply'arg x)++{- | Render a list literal (@[@ ... @]@). -}++render'list :: Render List+render'list cx x =+ if Seq.null (list'expressions x)+ then "[ ]"+ else "[" <> sp <> r (list'expressions x) <> "]"+ where+ r = Text.concat . fmap+ (\y ->+ (if lbr then indentation (renderContext'indentStart cx') else "") <>+ render'expression'listContext cx' y <> sp+ )+ sp = if lbr then "\n" else " "+ cx' = indentMore cx+ lbr = renderContext'lineBreaks cx++{- | Render a dict literal (@{@ ... @}@). -}++render'dict :: Render Dict+render'dict cx x =+ (if dict'rec x then keywordText keyword'rec <> " " else "") <>+ if Seq.null (dict'bindings x)+ then "{ }"+ else "{" <> sp <> r (dict'bindings x) <>+ (if lbr then indentation (renderContext'indentStart cx) else "") <> "}"+ where+ r = Text.concat . fmap+ (\b ->+ (if lbr then indentation (renderContext'indentStart cx') else "") <>+ render'dictBinding cx' b <> sp+ )+ sp = if lbr then "\n" else " "+ cx' = indentMore cx+ lbr = renderContext'lineBreaks cx++{- | Render a binding within a 'Dict', including the trailing semicolon. -}++render'dictBinding :: Render DictBinding+render'dictBinding cx =+ \case+ DictBinding'Eq a b ->+ render'expression'dictKey cx a <> " = " <>+ render'expression cx' b <> ";"+ DictBinding'Inherit'Dict a b ->+ "inherit " <> render'expression'inParens cx a <>+ Text.concatMap+ (\x ->+ " " <> render'strStatic'unquotedIfPossible cx x+ ) b <>+ ";"+ DictBinding'Inherit'Var a ->+ "inherit" <> Text.concatMap (\x -> " " <> render'var cx x) a <> ";"+ where+ cx' = indentMore cx++{- | Render a dot expression (@a.b@). -}++render'dot :: Render Dot+render'dot cx x =+ render'expression'dotLeftContext cx (dot'dict x) <> "." <>+ render'expression'dictKey cx (dot'key x)++{- | Render a @let@-@in@ expression. -}++render'let :: Render Let+render'let cx x =+ keywordText keyword'let <> sp <> r (let'bindings x) <>+ (if lbr then indentation (renderContext'indentStart cx) else "") <>+ keywordText keyword'in <> sp <>+ (if lbr then indentation (renderContext'indentStart cx') else "") <>+ render'expression cx' (let'value x)+ where+ r = Text.concat . fmap+ (\b ->+ (if lbr then indentation (renderContext'indentStart cx') else "") <>+ render'letBinding cx' b <> sp+ )+ cx' = indentMore cx+ sp = if lbr then "\n" else " "+ lbr = renderContext'lineBreaks cx++{- | Render a binding within a 'Let', including the trailing semicolon. -}++render'letBinding :: Render LetBinding+render'letBinding cx =+ \case+ LetBinding'Eq a b ->+ render'var cx a <> " = " <> render'expression cx' b <> ";"+ LetBinding'Inherit a b ->+ "inherit " <> render'expression'inParens cx a <>+ Text.concatMap (\x -> " " <> render'var cx x) b <> ";"+ where+ cx' = indentMore cx++{- | Render an expression. -}++-- | ==== Examples+--+-- >>> :{+-- >>> render'expression renderContext'terse+-- >>> (lambda+-- >>> (param "a" <> pattern+-- >>> [ dict'param "f"+-- >>> , dict'param "b" & def (apply (var "g") (var "x"))+-- >>> ] <> ellipsis)+-- >>> (apply (var "f") (var "b")))+-- >>> :}+-- "a@{ f, b ? g x, ... }: f b"++render'expression :: Render Expression+render'expression cx =+ \case+ Expr'Str x -> render'strDynamic'quoted cx x+ Expr'Str'Indented x -> render'str'indented cx x+ Expr'Dict x -> render'dict cx x+ Expr'List x -> render'list cx x+ Expr'Var x -> render'var cx x+ Expr'Dot x -> render'dot cx x+ Expr'Lambda x -> render'lambda cx x+ Expr'Apply x -> render'apply cx x+ Expr'Let x -> render'let cx x++{- | Render an expression in a list context. -}++render'expression'listContext :: Render Expression+render'expression'listContext cx x =+ case x of+ Expr'Lambda _ -> render'expression'inParens cx x+ Expr'Apply _ -> render'expression'inParens cx x+ Expr'Let _ -> render'expression'inParens cx x+ _ -> render'expression cx 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 cx x =+ case x of+ Expr'Lambda _ -> render'expression'inParens cx x+ Expr'Let _ -> render'expression'inParens cx x+ _ -> render'expression cx x++{- | Render an expression in the context of the right-hand side of an 'Apply'.+-}++render'expression'applyRightContext :: Render Expression+render'expression'applyRightContext cx x =+ case x of+ Expr'Apply _ -> render'expression'inParens cx x+ Expr'Let _ -> render'expression'inParens cx x+ _ -> render'expression cx x++render'expression'inParens :: Render Expression+render'expression'inParens cx x =+ "(" <> render'expression cx x <> ")"++render'expression'dictKey :: Render Expression+render'expression'dictKey cx = \case+ Expr'Str x -> render'strDynamic'unquotedIfPossible cx x+ x -> "${" <> render'expression cx x <> "}"
+ test/cases.hs view
@@ -0,0 +1,155 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++-- Bricks+import Bricks.Expression+import Bricks.Expression.Construction+import Bricks.Rendering++-- Bricks internal+import Bricks.Internal.Prelude+import qualified Bricks.Internal.Seq as Seq+import Bricks.Internal.Text (Text)++-- Bricks test+import Bricks.Test.Hedgehog+import Bricks.Test.QQ++-- Hedgehog+import Hedgehog (Property, property, withTests, (===))+import qualified Hedgehog++-- Base+import System.IO (IO)++main :: IO ()+main = runTests $$(Hedgehog.discover)++prop_render_expression :: Property+prop_render_expression = withTests 1 $ property $ do++ render'expression+ renderContext'default+ (dot (var "a") (str ["b"]))+ === [text|a.b|]++ render'expression+ renderContext'default+ (dot (var "a") (var "b"))+ === [text|a.${b}|]++ render'expression+ renderContext'default+ (dot (str ["a"]) (str ["b", antiquote (var "c")]))+ === [text|"a"."b${c}"|]++ render'expression+ renderContext'default+ (lambda+ (param "a" <> pattern+ [ dict'param "f"+ , dict'param "b" & def (apply (var "g") (var "x"))+ ] <> ellipsis)+ (apply (var "f") (var "b")))+ === [text|┃a@{ f, b ? g x, ... }:+ ┃f b|]++ render'expression+ renderContext'default+ (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"])))+ === [text|┃let+ ┃ d = {+ ┃ a = "b${c}";+ ┃ inherit (x) y z;+ ┃ };+ ┃in+ ┃ d.y|]++prop_render_identifier :: Property+prop_render_identifier = withTests 1 $ property $ do++ let+ test :: Text -> Text+ test x =+ render'strStatic'unquotedIfPossible renderContext'default $+ Str'Static x Nothing++ 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 = withTests 1 $ property $ do++ let+ test :: [Str'1] -> Text+ test xs =+ render'strDynamic'quoted renderContext'default $+ Str'Dynamic (Seq.fromList xs) Nothing++ test [] === [text|""|]+ test [ Str'1'Literal (Str'Static "hello" Nothing) ] === [text|"hello"|]++ test [ Str'1'Literal (Str'Static "escape ${ this and \" this" Nothing) ]+ === [text|"escape \${ this and \" this"|]++ test [ Str'1'Literal (Str'Static "Hello, my name is " Nothing)+ , Str'1'Antiquote (var "name")+ , Str'1'Literal (Str'Static "!" Nothing)+ ]+ === [text|"Hello, my name is ${name}!"|]++prop_render_dict_pattern :: Property+prop_render_dict_pattern = withTests 1 $ property $ do++ let+ test :: [DictPattern'1] -> Bool -> Text+ test a b =+ render'dictPattern renderContext'default $+ DictPattern (Seq.fromList a) b++ test [] False === [text|{ }|]+ test [] True === [text|{ ... }|]++ let+ item1 = dict'param "x"+ item2 = dict'param "y" & def (str ["abc"])++ test [ item1, item2 ] False === [text|{ x, y ? "abc" }|]+ test [ item1, item2 ] True === [text|{ x, y ? "abc", ... }|]++prop_render_list :: Property+prop_render_list = withTests 1 $ property $ do++ let+ test :: [Expression] -> Text+ test x =+ render'list renderContext'default $+ List (Seq.fromList x) Nothing++ test [] === [text|[ ]|]+ test [ var "a" ] === [text|┃[+ ┃ a+ ┃]|]+ test [ var "a", var "b" ] === [text|┃[+ ┃ a+ ┃ b+ ┃]|]++ let a = apply (var "f") (var "x")++ test [ a ] === [text|┃[+ ┃ (f x)+ ┃]|]+ test [ a, var "a" ] === [text|┃[+ ┃ (f x)+ ┃ a+ ┃]|]
+ test/doctest.hs view
@@ -0,0 +1,4 @@+import Test.DocTest (doctest)++main :: IO ()+main = doctest ["src", "-XOverloadedStrings"]