ede 0.2.9 → 0.3.0.0
raw patch · 14 files changed
+1348/−1022 lines, 14 filesdep +attoparsecdep +optparse-applicativedep +prettyprinterdep −ansi-wl-pprintdep −text-formatdep ~aesondep ~basedep ~bytestringsetup-changednew-component:exe:ede
Dependencies added: attoparsec, optparse-applicative, prettyprinter, prettyprinter-ansi-terminal
Dependencies removed: ansi-wl-pprint, text-format
Dependency ranges changed: aeson, base, bytestring, trifecta
Files
- README.md +2/−0
- Setup.hs +0/−2
- app/ede.hs +138/−0
- ede.cabal +106/−97
- src/Text/EDE.hs +174/−128
- src/Text/EDE/Filters.hs +114/−51
- src/Text/EDE/Internal/AST.hs +20/−19
- src/Text/EDE/Internal/Eval.hs +147/−144
- src/Text/EDE/Internal/Filters.hs +131/−136
- src/Text/EDE/Internal/Parser.hs +171/−144
- src/Text/EDE/Internal/Quoting.hs +128/−99
- src/Text/EDE/Internal/Syntax.hs +51/−47
- src/Text/EDE/Internal/Types.hs +137/−129
- test/Main.hs +29/−26
README.md view
@@ -1,5 +1,7 @@ # ED-E +[](https://travis-ci.org/brendanhay/ede)+ * [Introduction](#introduction) * [Syntax](#syntax) * [Contribute](#contribute)
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ app/ede.hs view
@@ -0,0 +1,138 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module Main (main) where++import Control.Applicative ((<*>))+import qualified Data.Aeson as Aeson+import qualified Data.Attoparsec.ByteString as Parsec+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Lazy as ByteString.Lazy+import Data.Functor ((<$>))+import Data.Semigroup ((<>))+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text.Encoding+import qualified Data.Text.Lazy.IO as Text.Lazy.IO+import qualified Options.Applicative as Options+import qualified Options.Applicative.Help.Pretty as Pretty+import qualified System.Exit as Exit+import qualified Text.EDE as EDE++data Options = Options+ { templateFile :: FilePath,+ jsonFile :: Maybe FilePath,+ jsonObject :: Maybe Aeson.Object+ }++optionsParser :: Options.Parser Options+optionsParser =+ Options+ <$> Options.strOption+ ( Options.long "template-file"+ <> Options.metavar "PATH"+ <> Options.help+ "Path of a file containing an EDE template"+ )+ <*> Options.optional+ ( Options.strOption+ ( Options.long "context-file"+ <> Options.metavar "PATH"+ <> Options.help+ "Path of a file containing a JSON object which is used \+ \as the template context"+ )+ )+ <*> Options.optional+ ( Options.option+ readObject+ ( Options.long "context-json"+ <> Options.metavar "OBJECT"+ <> Options.help+ "Template context as a JSON object"+ )+ )++parserInfo :: Options.ParserInfo Options+parserInfo =+ Options.info+ (Options.helper <*> optionsParser)+ (Options.header "EDE template processor" <> Options.progDescDoc (Just usage))+ where+ usage =+ Pretty.vcat+ [ Pretty.empty,+ "The --context-file and --context-json options are processed as follows:",+ Pretty.indent 2 "1.)"+ Pretty.<+> ( Pretty.align+ ( "Both are provided"+ Pretty.<$$> "Both objects are merged into one with the keys of \+ \--context-json taking precedence over those in the \+ \file provided by --context-file."+ )+ ),+ Pretty.indent 2 "2.)"+ Pretty.<+> ( Pretty.align+ ( "None of them are provided"+ Pretty.<$$> "The JSON object is read from STDIN."+ )+ ),+ Pretty.indent 2 "3.)"+ Pretty.<+> ( Pretty.align+ ( "One of them is provided"+ Pretty.<$$> "The JSON object is read from the supplied option."+ )+ )+ ]++main :: IO ()+main = do+ options <- Options.execParser parserInfo++ ctx <-+ case (jsonFile options, jsonObject options) of+ (Just path, Just obj1) -> do+ eobj2 <- Aeson.eitherDecode <$> ByteString.Lazy.readFile path++ case eobj2 of+ Left err -> fail err+ Right obj2 -> pure (obj1 <> obj2)+ --+ (Just path, Nothing) -> do+ eobj <- Aeson.eitherDecode <$> ByteString.Lazy.readFile path+ case eobj of+ Left err -> fail err+ Right obj -> pure obj+ --+ (Nothing, Just obj) ->+ pure obj+ --+ (Nothing, Nothing) ->+ ByteString.getContents+ >>= either fail pure . Parsec.parseOnly stdinParser++ EDE.parseFile (templateFile options) >>= \case+ EDE.Failure err -> print err >> Exit.exitFailure+ EDE.Success tpl ->+ case EDE.render tpl ctx of+ EDE.Failure err -> print err >> Exit.exitFailure+ EDE.Success output -> Text.Lazy.IO.putStr output++stdinParser :: Parsec.Parser Aeson.Object+stdinParser = Aeson.json >>= requireObject++readValue :: Options.ReadM Aeson.Value+readValue = Options.str >>= decodeJsonStr++decodeJsonStr :: Monad m => String -> m Aeson.Value+decodeJsonStr =+ either fail pure . Aeson.eitherDecode . ByteString.Lazy.fromStrict+ . Text.Encoding.encodeUtf8+ . Text.pack++readObject :: Options.ReadM Aeson.Object+readObject = readValue >>= requireObject++requireObject :: Monad m => Aeson.Value -> m Aeson.Object+requireObject = \case+ Aeson.Object obj -> pure obj+ _ -> fail "JSON value must be an object"
ede.cabal view
@@ -1,110 +1,119 @@-name: ede-version: 0.2.9-synopsis: Templating language with similar syntax and features to Liquid or Jinja2.-homepage: http://github.com/brendanhay/ede-license: OtherLicense-license-file: LICENSE-author: Brendan Hay-maintainer: Brendan Hay <brendan.g.hay@gmail.com>-copyright: Copyright (c) 2013-2015 Brendan Hay-stability: Experimental-category: Text, Template, Web-build-type: Simple-cabal-version: >= 1.10+name: ede+version: 0.3.0.0+synopsis:+ Templating language with similar syntax and features to Liquid or Jinja2. +homepage: http://github.com/brendanhay/ede+license: MPL-2.0+license-file: LICENSE+author: Brendan Hay+maintainer: Brendan Hay <brendan.g.hay@gmail.com>+copyright: Copyright (c) 2013-2020 Brendan Hay+stability: Experimental+category: Text, Template, Web+build-type: Simple+cabal-version: 2.0 description:- ED-E is a templating language written in Haskell with a specific set of features:- .- * Logicless within reason. A small set of consistent predicates- and expressions for formatting and presentational logic are provided.- .- * Secure. No arbitrary code evaluation, with input data required to be fully specified- at render time.- .- * Stateless. Parsing and rendering are separate steps so that loading, parsing,- include resolution, and embedding of the compiled template can optionally be- done ahead of time, amortising cost.- .- * Markup agnostic. ED-E is used to write out everything from configuration files for- system services, to HTML and formatted emails.- .- * Control over purity. Users can choose pure or IO-based resolution of- @include@ expressions.- .- * No surprises. All parsing, type assurances, and rendering steps report helpful- error messages with line/column metadata. Variable shadowing, unprintable expressions,- implicit type coercion, and unbound variable access are all treated as errors.--extra-source-files:- README.md+ ED-E is a templating language written in Haskell with a specific set of features:+ .+ * Logicless within reason. A small set of consistent predicates+ and expressions for formatting and presentational logic are provided.+ .+ * Secure. No arbitrary code evaluation, with input data required to be fully specified+ at render time.+ .+ * Stateless. Parsing and rendering are separate steps so that loading, parsing,+ include resolution, and embedding of the compiled template can optionally be+ done ahead of time, amortising cost.+ .+ * Markup agnostic. ED-E is used to write out everything from configuration files for+ system services, to HTML and formatted emails.+ .+ * Control over purity. Users can choose pure or IO-based resolution of+ @include@ expressions.+ .+ * No surprises. All parsing, type assurances, and rendering steps report helpful+ error messages with line/column metadata. Variable shadowing, unprintable expressions,+ implicit type coercion, and unbound variable access are all treated as errors. +extra-source-files: README.md data-files:- test/resources/*.ede- , test/resources/*.golden+ test/resources/*.ede+ test/resources/*.golden source-repository head-- type: git- location: git://github.com/brendanhay/ede.git+ type: git+ location: git://github.com/brendanhay/ede.git library- default-language: Haskell2010- hs-source-dirs: src-- exposed-modules:- Text.EDE- , Text.EDE.Filters+ default-language: Haskell2010+ hs-source-dirs: src+ exposed-modules:+ Text.EDE+ Text.EDE.Filters - other-modules:- Paths_ede- , Text.EDE.Internal.AST- , Text.EDE.Internal.Eval- , Text.EDE.Internal.Filters- , Text.EDE.Internal.Parser- , Text.EDE.Internal.Quoting- , Text.EDE.Internal.Syntax- , Text.EDE.Internal.Types+ other-modules:+ Text.EDE.Internal.AST+ Text.EDE.Internal.Eval+ Text.EDE.Internal.Filters+ Text.EDE.Internal.Parser+ Text.EDE.Internal.Quoting+ Text.EDE.Internal.Syntax+ Text.EDE.Internal.Types - ghc-options: -Wall+ ghc-options: -Wall+ build-depends:+ aeson >=0.7+ , base >=4.12 && <5+ , bifunctors >=4+ , bytestring >=0.9+ , comonad >=4.2+ , directory >=1.2+ , double-conversion >=2.0.2+ , filepath >=1.2+ , free >=4.8+ , lens >=4.0+ , mtl >=2.1.3.1+ , parsers >=0.12.1.1+ , prettyprinter >=1.6+ , prettyprinter-ansi-terminal >=1.1+ , scientific >=0.3.1+ , semigroups >=0.15+ , text >=1.2+ , text-manipulate >=0.1.2+ , trifecta >=2.1+ , unordered-containers >=0.2.3+ , vector >=0.7.1 - build-depends:- aeson >= 0.7- , ansi-wl-pprint >= 0.6.6- , base >= 4.6 && < 5- , bifunctors >= 4- , bytestring >= 0.9- , comonad >= 4.2- , directory >= 1.2- , double-conversion >= 2.0.2- , filepath >= 1.2- , free >= 4.8- , lens >= 4.0- , mtl >= 2.1.3.1- , parsers >= 0.12.1.1- , scientific >= 0.3.1- , semigroups >= 0.15- , text >= 1.2- , text-format >= 0.3- , text-manipulate >= 0.1.2- , trifecta >= 1.6- , unordered-containers >= 0.2.3- , vector >= 0.7.1+executable ede+ default-language: Haskell2010+ hs-source-dirs: app+ main-is: ede.hs+ ghc-options: -Wall+ build-depends:+ aeson >=0.8+ , attoparsec+ , base >=4.12 && <5+ , bytestring >=0.10.4+ , ede+ , optparse-applicative >=0.11+ , text >=1.2 test-suite golden- default-language: Haskell2010- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Main.hs-- ghc-options: -Wall -threaded-- build-depends:- aeson- , base >= 4.6 && < 5- , bifunctors- , bytestring- , directory- , ede- , text- , tasty- , tasty-golden+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: Paths_ede+ autogen-modules: Paths_ede+ ghc-options: -Wall -threaded+ build-depends:+ aeson+ , base >=4.12 && <5+ , bifunctors+ , bytestring+ , directory+ , ede+ , tasty+ , tasty-golden+ , text
src/Text/EDE.hs view
@@ -1,8 +1,9 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections #-} -- Module : Text.EDE--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -16,66 +17,65 @@ -- -- (ED-E is a character from Fallout New Vegas, pronounced 'Eddie'.) module Text.EDE- (- -- * How to use this library+ ( -- * How to use this library -- $usage -- * Parsing and Rendering -- $parsing_and_rendering- Template+ Template, -- ** Parsing- , parse- , parseIO- , parseFile- , parseFileWith- , parseWith+ parse,+ parseIO,+ parseFile,+ parseFileWith,+ parseWith, -- ** Includes -- $resolvers- , Resolver- , Id- , includeMap- , includeFile+ Resolver,+ Id,+ includeMap,+ includeFile, -- ** Rendering- , render- , renderWith+ render,+ renderWith, -- ** Either Variants- , eitherParse- , eitherParseFile- , eitherParseWith- , eitherRender- , eitherRenderWith+ eitherParse,+ eitherParseFile,+ eitherParseWith,+ eitherRender,+ eitherRenderWith, -- ** Results and Errors -- $results- , Delta (..)- , Result (..)- , eitherResult- , result- , success- , failure+ Delta (..),+ Result (..),+ eitherResult,+ result,+ success,+ failure,+ -- * Input -- $input- , fromValue- , fromPairs- , (.=)+ fromValue,+ fromPairs,+ (.=), -- * Version- , version+ version, -- * Syntax- , Delim- , Syntax- , delimPragma- , delimInline- , delimComment- , delimBlock-- , defaultSyntax- , alternateSyntax+ Delim,+ Syntax,+ delimPragma,+ delimInline,+ delimComment,+ delimBlock,+ defaultSyntax,+ alternateSyntax, -- ** Pragmas -- $pragmas@@ -109,34 +109,36 @@ -- ** Let Expressions -- $let- ) where+ )+where -import Control.Monad-import Data.Aeson ((.=))-import Data.Aeson.Types (Object)-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS-import Data.Foldable (foldrM)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as Map-import Data.List.NonEmpty (NonEmpty (..))-import Data.Monoid (mappend, mempty)+import Control.Monad+import Data.Aeson ((.=))+import Data.Aeson.Types (Object)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.Foldable (foldrM)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.List.NonEmpty (NonEmpty (..))+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import Data.Text.Lazy.Builder (toLazyText)-import Data.Version (Version)-import qualified Paths_ede as Paths-import System.Directory-import System.FilePath-import qualified Text.EDE.Internal.Eval as Eval-import qualified Text.EDE.Internal.Parser as Parser-import Text.EDE.Internal.Quoting (Term)-import Text.EDE.Internal.Syntax-import Text.EDE.Internal.Types-import Text.PrettyPrint.ANSI.Leijen (string)-import Text.Trifecta.Delta+#endif+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import Data.Text.Lazy.Builder (toLazyText)+import Data.Text.Prettyprint.Doc (Pretty (..))+import Data.Version (Version)+import qualified Paths_ede as Paths+import System.Directory+import System.FilePath+import qualified Text.EDE.Internal.Eval as Eval+import qualified Text.EDE.Internal.Parser as Parser+import Text.EDE.Internal.Quoting (Term)+import Text.EDE.Internal.Syntax+import Text.EDE.Internal.Types hiding ((</>))+import Text.Trifecta.Delta -- | ED-E Version. version :: Version@@ -149,17 +151,22 @@ -- -- See 'parseFile' or 'parseWith' for mechanisms to deal with @include@ -- dependencies.-parse :: ByteString -- ^ Strict 'ByteString' template definition.- -> Result Template+parse ::+ -- | Strict 'ByteString' template definition.+ ByteString ->+ Result Template parse = join . parseWith defaultSyntax (includeMap mempty) "Text.EDE.parse" -- | Parse 'Text' into a compiled 'Template'. -- -- This function handles all @include@ expressions as 'FilePath's and performs -- recursive loading/parsing.-parseIO :: FilePath -- ^ Parent directory for relatively pathed includes.- -> ByteString -- ^ Strict 'ByteString' template definition.- -> IO (Result Template)+parseIO ::+ -- | Parent directory for relatively pathed includes.+ FilePath ->+ -- | Strict 'ByteString' template definition.+ ByteString ->+ IO (Result Template) parseIO p = parseWith defaultSyntax (includeFile p) "Text.EDE.parse" -- | Load and parse a 'Template' from a file.@@ -167,16 +174,24 @@ -- This function handles all @include@ expressions as 'FilePath's and performs -- recursive loading/parsing, with pathing of @include@s relatively to the -- target (unless absolute paths are used).-parseFile :: FilePath -- ^ Path to the template to load and parse.- -> IO (Result Template)+parseFile ::+ -- | Path to the template to load and parse.+ FilePath ->+ IO (Result Template) parseFile = parseFileWith defaultSyntax -- | /See:/ 'parseFile'.-parseFileWith :: Syntax -- ^ Delimiters and parsing options.- -> FilePath -- ^ Path to the template to load and parse.- -> IO (Result Template)-parseFileWith s p = loadFile p >>= result failure- (parseWith s (includeFile (takeDirectory p)) (Text.pack p))+parseFileWith ::+ -- | Delimiters and parsing options.+ Syntax ->+ -- | Path to the template to load and parse.+ FilePath ->+ IO (Result Template)+parseFileWith s p =+ loadFile p+ >>= result+ failure+ (parseWith s (includeFile (takeDirectory p)) (Text.pack p)) -- | Parse a 'Template' from a Strict 'ByteString' using a custom function for -- resolving @include@ expressions.@@ -188,71 +203,92 @@ -- * 'includeFile' -- -- 'parseFile' for example, is defined as: 'parseWith' 'includeFile'.-parseWith :: Monad m- => Syntax -- ^ Delimiters and parsing options.- -> Resolver m -- ^ Function to resolve includes.- -> Text -- ^ Strict 'Text' name.- -> ByteString -- ^ Strict 'ByteString' template definition.- -> m (Result Template)+parseWith ::+ Monad m =>+ -- | Delimiters and parsing options.+ Syntax ->+ -- | Function to resolve includes.+ Resolver m ->+ -- | Strict 'Text' name.+ Text ->+ -- | Strict 'ByteString' template definition.+ ByteString ->+ m (Result Template) parseWith o f n = result failure resolve . Parser.runParser o n where resolve (u, is) = do- r <- foldrM include (Success (Map.singleton n u)) (Map.toList is)- result failure- (success . Template n u)- r+ r <- foldrM include (Success (Map.singleton n u)) (Map.toList is)+ result+ failure+ (success . Template n u)+ r -- Presuming self is always in self's includes, see singleton above. -- FIXME: utilise the list of deltas for failures- include (_, _) (Failure e) = failure e- include (k, d:|_) (Success ss) = f o k d >>=- result failure (success . mappend ss . _tmplIncl)+ include (_, _) (Failure e) = failure e+ include (k, d :| _) (Success ss) =+ f o k d+ >>= result failure (success . mappend ss . _tmplIncl) -- | 'HashMap' resolver for @include@ expressions. -- -- The 'identifier' component of the @include@ expression is treated as a lookup -- key into the supplied 'HashMap'. -- If the 'identifier' doesn't exist in the 'HashMap', an 'Error' is returned.-includeMap :: Monad m- => HashMap Id Template -- ^ A 'HashMap' of named 'Template's.- -> Resolver m -- ^ Resolver for 'parseWith'.+includeMap ::+ Monad m =>+ -- | A 'HashMap' of named 'Template's.+ HashMap Id Template ->+ -- | Resolver for 'parseWith'.+ Resolver m includeMap ts _ k _- | Just v <- Map.lookup k ts = success v- | otherwise = failure ("unable to resolve " <> string (Text.unpack k))- -- FIXME: utilise deltas in error messages+ | Just v <- Map.lookup k ts = success v+ | otherwise = failure ("unable to resolve " <> pretty (Text.unpack k)) +-- FIXME: utilise deltas in error messages+ -- | 'FilePath' resolver for @include@ expressions. -- -- The 'identifier' component of the @include@ expression is treated as a relative -- 'FilePath' and the template is loaded and parsed using 'parseFile'. -- If the 'identifier' doesn't exist as a valid 'FilePath', an 'Error' is returned.-includeFile :: FilePath -- ^ Parent directory for relatively pathed includes.- -> Resolver IO+includeFile ::+ -- | Parent directory for relatively pathed includes.+ FilePath ->+ Resolver IO includeFile p o k _ = loadFile f >>= result failure (parseWith o inc k)- where- inc = includeFile (takeDirectory f)+ where+ inc = includeFile (takeDirectory f) - f | Text.null k = Text.unpack k- | otherwise = p </> Text.unpack k+ f+ | Text.null k = Text.unpack k+ | otherwise = p </> Text.unpack k loadFile :: FilePath -> IO (Result ByteString) loadFile p = do- e <- doesFileExist p- if not e- then failure ("file " <> string p <> " doesn't exist.")- else BS.readFile p >>= success+ e <- doesFileExist p+ if not e+ then failure ("file " <> pretty p <> " doesn't exist.")+ else BS.readFile p >>= success -- | Render an 'Object' using the supplied 'Template'.-render :: Template -- ^ Parsed 'Template' to render.- -> Object -- ^ Bindings to make available in the environment.- -> Result LText.Text+render ::+ -- | Parsed 'Template' to render.+ Template ->+ -- | Bindings to make available in the environment.+ Object ->+ Result LText.Text render = renderWith mempty -- | Render an 'Object' using the supplied 'Template'.-renderWith :: HashMap Id Term -- ^ Filters to make available in the environment.- -> Template -- ^ Parsed 'Template' to render.- -> Object -- ^ Bindings to make available in the environment.- -> Result LText.Text+renderWith ::+ -- | Filters to make available in the environment.+ HashMap Id Term ->+ -- | Parsed 'Template' to render.+ Template ->+ -- | Bindings to make available in the environment.+ Object ->+ Result LText.Text renderWith fs (Template _ u ts) = fmap toLazyText . Eval.render ts fs u -- | /See:/ 'parse'@@ -264,25 +300,28 @@ eitherParseFile = fmap eitherResult . parseFile -- | /See:/ 'parseWith'-eitherParseWith :: (Functor m, Monad m)- => Syntax- -> Resolver m- -> Text- -> ByteString- -> m (Either String Template)+eitherParseWith ::+ (Functor m, Monad m) =>+ Syntax ->+ Resolver m ->+ Text ->+ ByteString ->+ m (Either String Template) eitherParseWith o f n = fmap eitherResult . parseWith o f n -- | /See:/ 'render'-eitherRender :: Template- -> Object- -> Either String LText.Text+eitherRender ::+ Template ->+ Object ->+ Either String LText.Text eitherRender t = eitherResult . render t -- | /See:/ 'renderWith'-eitherRenderWith :: HashMap Id Term- -> Template- -> Object- -> Either String LText.Text+eitherRenderWith ::+ HashMap Id Term ->+ Template ->+ Object ->+ Either String LText.Text eitherRenderWith fs t = eitherResult . renderWith fs t -- $usage@@ -378,6 +417,7 @@ -- #syntax# --+ -- $pragmas -- -- Syntax can be modified either via the arguments to 'parseWith' or alternatively@@ -428,12 +468,19 @@ -- -- /Note:/ --+ -- * Identifiers are named similarly to Haskell's rules.+ --+ -- * Booleans are lowered cased.+ --+ -- * The string quoting and escaping follows Haskell's rules.+ --+ -- * The Numeric format shares the same characteristics as the <http://json.org/ JSON specification.> -- $variables@@ -636,7 +683,6 @@ -- > multiline -- > comment -- > #}--- -- $let --
src/Text/EDE/Filters.hs view
@@ -1,5 +1,5 @@ -- Module : Text.EDE.Filters--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -10,8 +10,7 @@ -- | The means to construct your own filters. module Text.EDE.Filters- (- -- * Prelude+ ( -- * Prelude -- $prelude -- ** Boolean@@ -39,27 +38,28 @@ -- $polymorphic -- * Constructing filters- Term (..)+ Term (..), -- ** Classes- , Quote (..)- , Unquote (..)+ Quote (..),+ Unquote (..), -- ** Restricted quoters- , (@:)- , qapply- , qpoly2- , qnum1- , qnum2- , qcol1+ (@:),+ qapply,+ qpoly2,+ qnum1,+ qnum2,+ qcol1, -- ** Errors- , typeErr- , argumentErr- ) where+ typeErr,+ argumentErr,+ )+where -import Text.EDE.Internal.Quoting import Text.EDE.Internal.Filters+import Text.EDE.Internal.Quoting -- $prelude --@@ -71,86 +71,149 @@ -- $boolean ----- * @!@ @:: Bool -> Bool@ (/See:/ 'not')+-- [@! :: Bool -> Bool@]+-- /See:/ 'not' ----- * '&&' @:: Bool -> Bool -> Bool@+-- [@'&&' :: Bool -> Bool -> Bool@] ----- * '||' @:: Bool -> Bool -> Bool@+-- [@'||' :: Bool -> Bool -> Bool@] -- $equality ----- * '==' @:: a -> a -> Bool@+-- [@'==' :: a -> a -> Bool@] ----- * @!=@ @:: a -> a -> Bool@ (/See/: '/=')+-- [@!= :: a -> a -> Bool@]+-- /See/: '/=' -- $relational ----- * '>' @:: a -> a -> Bool@+-- [@'>' :: a -> a -> Bool@] ----- * '>=' @:: a -> a -> Bool@+-- [@'>=' :: a -> a -> Bool@] ----- * '<=' @:: a -> a -> Bool@+-- [@'<=' :: a -> a -> Bool@] ----- * '<=' @:: a -> a -> Bool@+-- [@'<' :: a -> a -> Bool@] -- $numeric ----- * '+' @:: Scientific -> Scientific -> Scientific@+-- [@'+' :: Scientific -> Scientific -> Scientific@] ----- * '-' @:: Scientific -> Scientific -> Scientific@+-- [@'-' :: Scientific -> Scientific -> Scientific@] ----- * '*' @:: Scientific -> Scientific -> Scientific@+-- [@'*' :: Scientific -> Scientific -> Scientific@] ----- * 'abs' @:: Scientific -> Scientific@+-- [@'abs' :: Scientific -> Scientific@] ----- * 'signum' @:: Scientific -> Scientific@+-- [@'negate' :: Scientific -> Scientific@] ----- * 'negate' @:: Scientific -> Scientific@+-- [@'signum' :: Scientific -> Scientific@] -- $fractional ----- * 'truncate' @:: Scientific -> Scientific@+-- [@'ceiling' :: Scientific -> Scientific@] ----- * 'round' @:: Scientific -> Scientific@+-- [@'floor' :: Scientific -> Scientific@] ----- * 'ceiling' @:: Scientific -> Scientific@+-- [@'round' :: Scientific -> Scientific@] ----- * 'floor' @:: Scientific -> Scientific@+-- [@'truncate' :: Scientific -> Scientific@] -- $textual ----- * 'Data.Text.Manipulate.takeWord' @:: Text -> Text@+-- [@dropLower :: Text -> Text@]+-- Drop preceding lowercase characters. ----- * 'Data.Text.Manipulate.dropWord' @:: Text -> Text@+-- [@'dropUpper' :: Text -> Text@]+-- Drop preceding uppercase characters. ----- * 'Data.Text.Manipulate.lowerHead' @:: Text -> Text@+-- [@'Data.Text.Manipulate.indentLines' :: Text -> Text@] ----- * 'Data.Text.Manipulate.upperHead' @:: Text -> Text@+-- [@'Data.Text.Manipulate.prependLines' :: Text -> Text@] ----- * 'Data.Text.Manipulate.toTitle' @:: Text -> Text@+-- [@'Data.Text.justifyLeft' :: Text -> Text@]+-- Using whitespace as fill character. ----- * 'Data.Text.Manipulate.toCamel' @:: Text -> Text@+-- [@'Data.Text.justifyRight' :: Text -> Text@]+-- Using whitespace as fill character. ----- * 'Data.Text.Manipulate.toPascal' @:: Text -> Text@+-- [@'Data.Text.center' :: Text -> Text@]+-- Using whitespace as fill character. ----- * 'Data.Text.Manipulate.toSnake' @:: Text -> Text@+-- [@'Data.Text.replace' :: Text -> Text@] ----- * 'Data.Text.Manipulate.toSpinal' @:: Text -> Text@+-- [@remove@ @:: Text -> Text@]+-- Shortcut for: @replace(pattern, "")@ ----- * 'Data.Text.Manipulate.toTrain' @:: Text -> Text@+-- [@'Data.Text.Manipulate.splitWords' :: Text -> Text@] ----- * 'Data.Text.toLower' @:: Text -> Text@+-- [@'Data.Text.strip' :: Text -> Text@] ----- * 'Data.Text.toUpper' @:: Text -> Text@+-- [@'Data.Text.stripPrefix' :: Text -> Text@] ----- * 'Data.Text.Manipulate.toOrdinal' @:: Scientific -> Text@+-- [@'Data.Text.stripSuffix' :: Text -> Text@]+--+-- [@'Data.Text.stripStart' :: Text -> Text@]+--+-- [@'Data.Text.stripEnd' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.takeWord' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.dropWord' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.lowerHead' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.upperHead' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toCamel' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toEllipsis' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toEllipsisWith' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toPascal' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toSnake' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toSpinal' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toTitle' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toTrain' :: Text -> Text@]+--+-- [@'Data.Text.toLower' :: Text -> Text@]+--+-- [@'Data.Text.toUpper' :: Text -> Text@]+--+-- [@'Data.Text.Manipulate.toOrdinal' :: Scientific -> Text@] -- $collection ----- * @length@ @:: Collection -> Scientific@ (/See/: Text.'Data.Text.length', Vector.'Data.Vector.length', HashMap.'Data.HashMap.Strict.size')+-- [@length :: Collection -> Scientific@]+-- /See/: Text.'Data.Text.length', Vector.'Data.Vector.length', HashMap.'Data.HashMap.Strict.size' ----- * @empty@ @:: Collection -> Bool@ (/See/: Text:'Data.Text.null', Vector.'Data.Vector.null', HashMap.'Data.HashMap.Strict.null')+-- [@empty :: Collection -> Bool@]+-- /See/: Text.'Data.Text.null', Vector.'Data.Vector.null', HashMap.'Data.HashMap.Strict.null'+--+-- [@reverse :: Collection -> Scientific@]+-- /See/: Text.'Data.Text.reverse', Vector.'Data.Vector.reverse'+--+-- [@head :: Collection -> Scientific@]+-- /See/: Text.'Data.Text.head', Vector.'Data.Vector.head'+--+-- [@last :: Collection -> Scientific@]+-- /See/: Text.'Data.Text.last', Vector.'Data.Vector.last'+--+-- [@tail :: Collection -> Scientific@]+-- /See/: Text.'Data.Text.tail', Vector.'Data.Vector.tail'+--+-- [@init@ @:: Collection -> Scientific@]+-- /See/: Text.'Data.Text.init', Vector.'Data.Vector.init'+--+-- [@'Data.HashMap.Strict.keys' :: Collection -> Scientific@]+--+-- [@'Data.HashMap.Strict.elems' :: Collection -> Scientific@] -- $polymorphic ----- * 'show' @:: a -> Text@+-- [@'show' :: a -> Text@]
src/Text/EDE/Internal/AST.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections #-} -- Module : Text.EDE.Internal.AST--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -18,9 +18,8 @@ import Control.Comonad.Cofree import Data.Aeson.Types import Data.Foldable-import Data.List.NonEmpty (NonEmpty(..))+import Data.List.NonEmpty (NonEmpty (..)) import Data.Maybe-import Data.Monoid (mempty) import Text.EDE.Internal.Types newtype Mu f = Mu (f (Mu f))@@ -34,9 +33,9 @@ var = Var . (:| []) eapp :: a -> [Exp a] -> Exp a-eapp x [] = cofree x blank-eapp _ [e] = e-eapp _ (e:es) = foldl' (\x y -> extract x :< EApp x y) e es+eapp x [] = cofree x blank+eapp _ [e] = e+eapp _ (e : es) = foldl' (\x y -> extract x :< EApp x y) e es efun :: Id -> Exp a -> Exp a efun i e = let x = extract e in x :< EApp (x :< EFun i) e@@ -47,17 +46,19 @@ elet :: Maybe (Id, Exp a) -> Exp a -> Exp a elet m e = maybe e (\(i, b) -> extract b :< ELet i b e) m -ecase :: Exp a- -> [Alt (Exp a)]- -> Maybe (Exp a)- -> Exp a-ecase p ws f = extract p :< ECase p (ws ++ maybe [] ((:[]) . wild) f)+ecase ::+ Exp a ->+ [Alt (Exp a)] ->+ Maybe (Exp a) ->+ Exp a+ecase p ws f = extract p :< ECase p (ws ++ maybe [] ((: []) . wild) f) -eif :: (Exp a, Exp a)- -> [(Exp a, Exp a)]- -> Maybe (Exp a)- -> Exp a-eif t ts f = foldr' c (fromMaybe (extract (fst t) `cofree` blank) f) (t:ts)+eif ::+ (Exp a, Exp a) ->+ [(Exp a, Exp a)] ->+ Maybe (Exp a) ->+ Exp a+eif t ts f = foldr' c (fromMaybe (extract (fst t) `cofree` blank) f) (t : ts) where c (p, w) e = extract p :< ECase p [true w, false e] @@ -65,9 +66,9 @@ eempty v e = maybe e (eif (efun "!" (efun "empty" v), e) [] . Just) true, false, wild :: Exp a -> Alt (Exp a)-true = (PLit (Bool True),)+true = (PLit (Bool True),) false = (PLit (Bool False),)-wild = (PWild,)+wild = (PWild,) blank :: Mu ExpF blank = Mu (ELit (String mempty))
src/Text/EDE/Internal/Eval.hs view
@@ -1,9 +1,10 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TupleSections #-} -- Module : Text.EDE.Internal.Eval--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -14,98 +15,93 @@ module Text.EDE.Internal.Eval where -import Control.Applicative-import Control.Comonad.Cofree-import Control.Monad-import Control.Monad.Reader-import Data.Aeson hiding (Result (..))-import Data.Foldable (foldlM)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as Map-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Monoid (mempty)-import Data.Scientific (isFloating)-import Data.Semigroup-import qualified Data.Text as Text-import qualified Data.Text.Buildable as Build-import Data.Text.Lazy.Builder (Builder)-import Data.Text.Lazy.Builder.Scientific-import Data.Text.Manipulate (toOrdinal)-import Text.EDE.Internal.Filters (stdlib)-import Text.EDE.Internal.Quoting-import Text.EDE.Internal.Types-import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..), (<+>))-import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Text.Trifecta.Delta+import Control.Comonad.Cofree+import Control.Monad+import Control.Monad.Reader+import Data.Aeson hiding (Result (..))+import Data.Foldable (foldlM)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Scientific (isFloating)+import qualified Data.Text as Text+import Data.Text.Lazy.Builder (Builder)+import qualified Data.Text.Lazy.Builder as Text.Builder+import Data.Text.Lazy.Builder.Scientific+import Data.Text.Manipulate (toOrdinal)+import Data.Text.Prettyprint.Doc ((<+>))+import qualified Data.Text.Prettyprint.Doc as PP+import Text.EDE.Internal.Filters (stdlib)+import Text.EDE.Internal.Quoting+import Text.EDE.Internal.Types+import Text.Trifecta.Delta data Env = Env- { _templates :: HashMap Id (Exp Delta)- , _quoted :: HashMap Id Term- , _values :: HashMap Id Value- }+ { _templates :: HashMap Id (Exp Delta),+ _quoted :: HashMap Id Term,+ _values :: HashMap Id Value+ } type Context = ReaderT Env Result -render :: HashMap Id (Exp Delta)- -> HashMap Id Term- -> Exp Delta- -> HashMap Id Value- -> Result Builder+render ::+ HashMap Id (Exp Delta) ->+ HashMap Id Term ->+ Exp Delta ->+ HashMap Id Value ->+ Result Builder render ts fs e o = runReaderT (eval e >>= nf) (Env ts (stdlib <> fs) o) where nf (TVal v) = build (delta e) v- nf _ = lift $ Failure- "unable to evaluate partially applied template to normal form."+ nf _ =+ lift $+ Failure+ "unable to evaluate partially applied template to normal form." eval :: Exp Delta -> Context Term eval (_ :< ELit l) = return (qprim l) eval (d :< EVar v) = quote (Text.pack (show v)) 0 <$> variable d v eval (d :< EFun i) = do- q <- Map.lookup i <$> asks _quoted- maybe (throwError d $ "filter" <+> PP.bold (pp i) <+> "doesn't exist.")- return- q-+ q <- Map.lookup i <$> asks _quoted+ maybe+ (throwError d $ "filter" <+> bold (pp i) <+> "doesn't exist.")+ return+ q eval (_ :< EApp (_ :< EFun "defined") e) = predicate e- eval (d :< EApp a b) = do- x <- eval a- y <- eval b- binding d x y-+ x <- eval a+ y <- eval b+ binding d x y eval (_ :< ELet k rhs bdy) = do- q <- eval rhs- v <- lift (unquote k 0 q)- bind (Map.insert k v) (eval bdy)+ q <- eval rhs+ v <- lift (unquote k 0 q)+ bind (Map.insert k v) (eval bdy) -- FIXME: We have to recompute c everytime due to the predicate .. eval (d :< ECase p ws) = go ws where- go [] = return (qprim (String mempty))- go ((a, e):as) =- case a of- PWild -> eval e- PVar v -> eval (d :< EVar v) >>= cond e as- PLit l -> eval (d :< ELit l) >>= cond e as-- cond e as y@(TVal Bool{}) = do- x <- predicate p- if x `eq` y- then eval e- else go as-- cond e as y@TVal{} = do- x <- eval p- if x `eq` y- then eval e- else go as+ go [] = return (qprim (String mempty))+ go ((a, e) : as) =+ case a of+ PWild -> eval e+ PVar v -> eval (d :< EVar v) >>= cond e as+ PLit l -> eval (d :< ELit l) >>= cond e as - cond _ as _ = go as+ cond e as y@(TVal Bool {}) = do+ x <- predicate p+ if x `eq` y+ then eval e+ else go as+ cond e as y@TVal {} = do+ x <- eval p+ if x `eq` y+ then eval e+ else go as+ cond _ as _ = go as eq (TVal a) (TVal b) = a == b- eq _ _ = False-+ eq _ _ = False eval (_ :< ELoop i v bdy) = eval v >>= lift . unquote i 0 >>= loop where d = delta bdy@@ -114,106 +110,113 @@ loop (Col l xs) = snd <$> foldlM iter (1, qprim (String mempty)) xs where iter (n, p) x = do- shadowed n- q <- bind (Map.insert i (context n x)) (eval bdy)- r <- binding d p q- return (n + 1, r)+ shadowed n+ q <- bind (Map.insert i (context n x)) (eval bdy)+ r <- binding d p q+ return (n + 1, r) shadowed n = do- m <- asks _values- maybe (return ())- (shadowedErr n)- (Map.lookup i m)+ m <- asks _values+ maybe+ (return ())+ (shadowedErr n)+ (Map.lookup i m) - shadowedErr n x = throwError d $- "variable"- <+> PP.bold (pp i)- <+> "shadows"- <+> pp x- <+> "in"- <+> pp (toOrdinal n)- <+> "loop iteration."+ shadowedErr n x =+ throwError d $+ "variable"+ <+> bold (pp i)+ <+> "shadows"+ <+> pp x+ <+> "in"+ <+> pp (toOrdinal n)+ <+> "loop iteration." - context n (k, x) = object $- [ "value" .= x- , "length" .= l- , "index" .= n- , "index0" .= (n - 1)- , "remainder" .= (l - n)- , "remainder0" .= (l - n - 1)- , "first" .= (n == 1)- , "last" .= (n == l)- , "odd" .= (n `mod` 2 == 1)- , "even" .= (n `mod` 2 == 0)- ] ++ key k+ context n (k, x) =+ object $+ [ "value" .= x,+ "length" .= l,+ "index" .= n,+ "index0" .= (n - 1),+ "remainder" .= (l - n),+ "remainder0" .= (l - n - 1),+ "first" .= (n == 1),+ "last" .= (n == l),+ "odd" .= (n `mod` 2 == 1),+ "even" .= (n `mod` 2 == 0)+ ]+ ++ key k key (Just k) = ["key" .= k]- key Nothing = []-+ key Nothing = [] eval (d :< EIncl i) = do- ts <- asks _templates- case Map.lookup i ts of- Just e -> eval e- Nothing -> throwError d $- "template"- <+> PP.bold (pp i)- <+> "is not in scope:"- <+> PP.brackets (pp (Text.intercalate "," $ Map.keys ts))+ ts <- asks _templates+ case Map.lookup i ts of+ Just e -> eval e+ Nothing ->+ throwError d $+ "template"+ <+> bold (pp i)+ <+> "is not in scope:"+ <+> PP.brackets (pp (Text.intercalate "," $ Map.keys ts)) bind :: (Object -> Object) -> Context a -> Context a-bind f = withReaderT (\x -> x { _values = f (_values x) })+bind f = withReaderT (\x -> x {_values = f (_values x)}) variable :: Delta -> Var -> Context Value variable d (Var is) = asks _values >>= go (NonEmpty.toList is) [] . Object where- go [] _ v = return v- go (k:ks) r v = do- m <- nest v- maybe (throwError d $ "variable" <+> pretty cur <+> "doesn't exist.")- (go ks (k:r))- (Map.lookup k m)+ go [] _ v = return v+ go (k : ks) r v = do+ m <- nest v+ maybe+ (throwError d $ "variable" <+> apretty cur <+> "doesn't exist.")+ (go ks (k : r))+ (Map.lookup k m) where- cur = Var (k:|r)+ cur = Var (k :| r) nest :: Value -> Context Object nest (Object o) = return o- nest x = throwError d $ "variable"- <+> pretty cur- <+> "::"- <+> pp x- <+> "doesn't supported nested accessors."+ nest x =+ throwError d $+ "variable"+ <+> apretty cur+ <+> "::"+ <+> pp x+ <+> "doesn't supported nested accessors." -- | A variable can be tested for truthiness, but a non-whnf expr cannot. predicate :: Exp Delta -> Context Term predicate x = do- r <- runReaderT (eval x) <$> ask- lift $ case r of- Success q- | TVal Bool{} <- q -> Success q- Success q- | TVal Null <- q -> Success (qprim False)- Success _ -> Success (qprim True)- Failure _- | _ :< EVar{} <- x -> Success (qprim False)- Failure e -> Failure e+ r <- runReaderT (eval x) <$> ask+ lift $ case r of+ Success q+ | TVal Bool {} <- q -> Success q+ Success q+ | TVal Null <- q -> Success (qprim False)+ Success _ -> Success (qprim True)+ Failure _+ | _ :< EVar {} <- x -> Success (qprim False)+ Failure e -> Failure e binding :: Delta -> Term -> Term -> Context Term binding d x y =- case (x, y) of- (TVal l, TVal r) -> quote "<>" 0 <$> liftM2 (<>) (build d l) (build d r)- _ -> lift (qapply d x y)+ case (x, y) of+ (TVal l, TVal r) -> quote "<>" 0 <$> liftM2 (<>) (build d l) (build d r)+ _ -> lift (qapply d x y) build :: Delta -> Value -> Context Builder-build _ Null = return mempty-build _ (String t) = return (Build.build t)-build _ (Bool True) = return "true"+build _ Null = return mempty+build _ (String t) = return (Text.Builder.fromText t)+build _ (Bool True) = return "true" build _ (Bool False) = return "false" build _ (Number n)- | isFloating n = return (formatScientificBuilder Fixed Nothing n)- | otherwise = return (formatScientificBuilder Fixed (Just 0) n)+ | isFloating n = return (formatScientificBuilder Fixed Nothing n)+ | otherwise = return (formatScientificBuilder Fixed (Just 0) n) build d x =- throwError d ("unable to render literal" <+> pp x)+ throwError d ("unable to render literal" <+> pp x) -- FIXME: Add delta information to the thrown error document.-throwError :: Delta -> Doc -> Context a-throwError d doc = lift . Failure $ pretty d <+> PP.red "error:" <+> doc+throwError :: Delta -> AnsiDoc -> Context a+throwError d doc = lift . Failure $ prettyDelta d <+> red "error:" <+> doc
src/Text/EDE/Internal/Filters.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- Module : Text.EDE.Internal.Filters--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -18,120 +17,112 @@ module Text.EDE.Internal.Filters where -import Control.Applicative-import Data.Aeson (Array, Object, Value (..),- encode)-import qualified Data.Char as Char-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as Map-import Data.Maybe-import Data.Monoid (mempty)-import Data.Scientific (Scientific)-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Lazy as LText-import qualified Data.Text.Lazy.Encoding as LText-import Data.Text.Manipulate-import qualified Data.Text.Unsafe as Text-import qualified Data.Vector as Vector-import Text.EDE.Internal.Quoting-import Text.EDE.Internal.Types-import Text.PrettyPrint.ANSI.Leijen (Pretty (..), (<+>))+import Data.Aeson+ ( Array,+ Object,+ Value (..),+ encode,+ )+import qualified Data.Char as Char+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.Maybe+import Data.Scientific (Scientific)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Lazy as LText+import qualified Data.Text.Lazy.Encoding as LText+import Data.Text.Manipulate+import Data.Text.Prettyprint.Doc ((<+>))+import qualified Data.Text.Unsafe as Text+import qualified Data.Vector as Vector+import Text.EDE.Internal.Quoting+import Text.EDE.Internal.Types default (Integer) stdlib :: HashMap Text Term-stdlib = Map.fromList+stdlib =+ Map.fromList -- boolean- [ "!" @: not- , "&&" @: (&&)- , "||" @: (||)-- -- equality- , "==" `qpoly2` (==)- , "!=" `qpoly2` (/=)-- -- relational- , ">" `qnum2` (>)- , ">=" `qnum2` (>=)- , "<=" `qnum2` (<=)- , "<" `qnum2` (<)-- -- numeric- , "+" `qnum2` (+)- , "-" `qnum2` (-)- , "*" `qnum2` (*)- , "abs" `qnum1` abs- , "signum" `qnum1` signum- , "negate" `qnum1` negate-- -- fractional- , "truncate" `qnum1` (fromIntegral . truncate)- , "round" `qnum1` (fromIntegral . round)- , "ceiling" `qnum1` (fromIntegral . ceiling)- , "floor" `qnum1` (fromIntegral . floor)-- -- text- , "lowerHead" @: lowerHead- , "upperHead" @: upperHead- , "toTitle" @: toTitle- , "toCamel" @: toCamel- , "toPascal" @: toPascal- , "toSnake" @: toSnake- , "toSpinal" @: toSpinal- , "toTrain" @: toTrain- , "toUpper" @: Text.toUpper- , "toLower" @: Text.toLower- , "toOrdinal" @: (toOrdinal :: Integer -> Text)-- , "dropLower" @: Text.dropWhile (not . Char.isUpper)- , "dropUpper" @: Text.dropWhile (not . Char.isLower)- , "takeWord" @: takeWord- , "dropWord" @: dropWord- , "splitWords" @: splitWords- , "strip" @: Text.strip- , "stripPrefix" @: (\x p -> fromMaybe x (p `Text.stripPrefix` x))- , "stripSuffix" @: (\x s -> fromMaybe x (s `Text.stripSuffix` x))- , "stripStart" @: Text.stripStart- , "stripEnd" @: Text.stripEnd- , "replace" @: flip Text.replace- , "remove" @: (\x r -> Text.replace r "" x)-- , "toEllipsis" @: flip toEllipsis- , "toEllipsisWith" @: (\x n e -> toEllipsisWith n e x)-- , "indentLines" @: flip indentLines- , "prependLines" @: flip prependLines- , "justifyLeft" @: (\x n -> Text.justifyLeft n ' ' x)- , "justifyRight" @: (\x n -> Text.justifyRight n ' ' x)- , "center" @: (\x n -> Text.center n ' ' x)-- -- sequences- , qcol1 "length" Text.length Map.size Vector.length- , qcol1 "empty" Text.null Map.null Vector.null- , qcol1 "reverse" Text.reverse id Vector.reverse-- -- lists- , qlist1 "head" headT headV- , qlist1 "last" lastT lastV- , qlist1 "tail" lastT tailV- , qlist1 "init" initT initV-- -- object- , "keys" @: (Map.keys :: Object -> [Text])- , "elems" @: (Map.elems :: Object -> [Value])-- -- , "map" @: undefined- -- , "filter" @: undefined- -- , "zip" @: undefined- -- , "join" @: undefined-- -- polymorphic- , "show" @: (LText.decodeUtf8 . encode :: Value -> LText.Text)+ [ "!" @: not,+ "&&" @: (&&),+ "||" @: (||),+ -- equality+ "==" `qpoly2` (==),+ "!=" `qpoly2` (/=),+ -- relational+ ">" `qnum2` (>),+ ">=" `qnum2` (>=),+ "<=" `qnum2` (<=),+ "<" `qnum2` (<),+ -- numeric+ "+" `qnum2` (+),+ "-" `qnum2` (-),+ "*" `qnum2` (*),+ "abs" `qnum1` abs,+ "signum" `qnum1` signum,+ "negate" `qnum1` negate,+ -- fractional+ "truncate" `qnum1` (fromIntegral . truncate),+ "round" `qnum1` (fromIntegral . round),+ "ceiling" `qnum1` (fromIntegral . ceiling),+ "floor" `qnum1` (fromIntegral . floor),+ -- text+ "lowerHead" @: lowerHead,+ "upperHead" @: upperHead,+ "toTitle" @: toTitle,+ "toCamel" @: toCamel,+ "toPascal" @: toPascal,+ "toSnake" @: toSnake,+ "toSpinal" @: toSpinal,+ "toTrain" @: toTrain,+ "toUpper" @: Text.toUpper,+ "toLower" @: Text.toLower,+ "toOrdinal" @: (toOrdinal :: Integer -> Text),+ "dropLower" @: Text.dropWhile (not . Char.isUpper),+ "dropUpper" @: Text.dropWhile (not . Char.isLower),+ "takeWord" @: takeWord,+ "dropWord" @: dropWord,+ "splitWords" @: splitWords,+ "strip" @: Text.strip,+ "stripPrefix" @: (\x p -> fromMaybe x (p `Text.stripPrefix` x)),+ "stripSuffix" @: (\x s -> fromMaybe x (s `Text.stripSuffix` x)),+ "stripStart" @: Text.stripStart,+ "stripEnd" @: Text.stripEnd,+ "replace" @: flip Text.replace,+ "remove" @: (\x r -> Text.replace r "" x),+ "toEllipsis" @: flip toEllipsis,+ "toEllipsisWith" @: (\x n e -> toEllipsisWith n e x),+ "indentLines" @: flip indentLines,+ "prependLines" @: flip prependLines,+ "justifyLeft" @: (\x n -> Text.justifyLeft n ' ' x),+ "justifyRight" @: (\x n -> Text.justifyRight n ' ' x),+ "center" @: (\x n -> Text.center n ' ' x),+ -- sequences+ qcol1 "length" Text.length Map.size Vector.length,+ qcol1 "empty" Text.null Map.null Vector.null,+ qcol1 "reverse" Text.reverse id Vector.reverse,+ -- lists+ qlist1 "head" headT headV,+ qlist1 "last" lastT lastV,+ qlist1 "tail" tailT tailV,+ qlist1 "init" initT initV,+ "at" @: (\x i -> x Vector.! i :: Value),+ -- object+ "keys" @: (Map.keys :: Object -> [Text]),+ "elems" @: (Map.elems :: Object -> [Value]),+ -- , "map" @: undefined+ -- , "filter" @: undefined+ -- , "zip" @: undefined+ -- , "join" @: undefined - -- FIXME: existence checks currently hardcoded into the evaluator:- -- "default"- -- "defined"+ -- polymorphic+ "show" @: (LText.decodeUtf8 . encode :: Value -> LText.Text),+ "singleton" @: (pure :: Value -> Vector.Vector Value)+ -- FIXME: existence checks currently hardcoded into the evaluator:+ -- "default"+ -- "defined" ] (@:) :: Quote a => Id -> a -> (Id, Term)@@ -151,31 +142,35 @@ -- | Quote a comprehensive set of unary functions to create a binding -- that supports list collection types.-qlist1 :: (Quote a, Quote b)- => Id- -> (Text -> a)- -> (Array -> b)- -> (Id, Term)+qlist1 ::+ (Quote a, Quote b) =>+ Id ->+ (Text -> a) ->+ (Array -> b) ->+ (Id, Term) qlist1 k f g = (k,) . TLam $ \case- TVal (String t) -> pure . quote k 0 $ f t- TVal (Array v) -> pure . quote k 0 $ g v- x -> Failure $- "when expecting a String or Array, encountered" <+> pretty x+ TVal (String t) -> pure . quote k 0 $ f t+ TVal (Array v) -> pure . quote k 0 $ g v+ x ->+ Failure $+ "when expecting a String or Array, encountered" <+> apretty x -- | Quote a comprehensive set of unary functions to create a binding -- that supports all collection types.-qcol1 :: (Quote a, Quote b, Quote c)- => Id- -> (Text -> a)- -> (Object -> b)- -> (Array -> c)- -> (Id, Term)+qcol1 ::+ (Quote a, Quote b, Quote c) =>+ Id ->+ (Text -> a) ->+ (Object -> b) ->+ (Array -> c) ->+ (Id, Term) qcol1 k f g h = (k,) . TLam $ \case- TVal (String t) -> pure . quote k 0 $ f t- TVal (Object o) -> pure . quote k 0 $ g o- TVal (Array v) -> pure . quote k 0 $ h v- x -> Failure $- "when expecting a String, Object, or Array, encountered" <+> pretty x+ TVal (String t) -> pure . quote k 0 $ f t+ TVal (Object o) -> pure . quote k 0 $ g o+ TVal (Array v) -> pure . quote k 0 $ h v+ x ->+ Failure $+ "when expecting a String, Object, or Array, encountered" <+> apretty x headT, lastT, tailT, initT :: Text -> Value headT = text (Text.singleton . Text.unsafeHead)@@ -197,5 +192,5 @@ safe :: b -> (a -> Bool) -> (a -> b) -> a -> b safe v f g x- | f x = v- | otherwise = g x+ | f x = v+ | otherwise = g x
src/Text/EDE/Internal/Parser.hs view
@@ -1,16 +1,17 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} -- Module : Text.EDE.Internal.Parser--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -21,68 +22,72 @@ module Text.EDE.Internal.Parser where -import Control.Applicative-import Control.Comonad (extract)-import Control.Comonad.Cofree-import Control.Lens hiding ((:<), both, noneOf, op)-import Control.Monad.State.Strict-import Data.Aeson.Types (Array, Object, Value (..))-import Data.Bifunctor-import Data.ByteString (ByteString)-import Data.Char (isSpace)-import Data.HashMap.Strict (HashMap)-import qualified Data.HashMap.Strict as Map-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Monoid (mempty)-import Data.Scientific-import Data.Semigroup-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Data.Vector as Vector-import Text.EDE.Internal.AST-import Text.EDE.Internal.Syntax-import Text.EDE.Internal.Types-import Text.Parser.Expression-import Text.Parser.LookAhead-import Text.Parser.Token.Style (buildSomeSpaceParser)-import Text.Trifecta hiding (Parser, Result (..), spaces)-import qualified Text.Trifecta as Tri-import Text.Trifecta.Delta+import Control.Applicative+import Control.Comonad (extract)+import Control.Comonad.Cofree+import Control.Lens hiding (both, noneOf, op, (:<))+import Control.Monad.State.Strict+import Data.Aeson.Types (Array, Object, Value (..))+import Data.Bifunctor+import Data.ByteString (ByteString)+import Data.Char (isSpace)+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as Map+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Scientific+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Vector as Vector+import Text.EDE.Internal.AST+import Text.EDE.Internal.Syntax+import Text.EDE.Internal.Types+import Text.Parser.Expression+import Text.Parser.LookAhead+import Text.Parser.Token.Style (buildSomeSpaceParser)+import Text.Trifecta hiding (Parser, Result (..), spaces)+import qualified Text.Trifecta as Tri+import Text.Trifecta.Delta data Env = Env- { _settings :: !Syntax- , _includes :: HashMap Text (NonEmpty Delta)- }+ { _settings :: !Syntax,+ _includes :: HashMap Text (NonEmpty Delta)+ } makeLenses ''Env instance HasSyntax Env where- syntax = settings+ syntax = settings type Parser m =- ( Monad m- , MonadState Env m- , TokenParsing m- , DeltaParsing m- , LookAheadParsing m- , Errable m- )+ ( Monad m,+#if MIN_VERSION_base(4,13,0)+ MonadFail m,+#endif+ MonadState Env m,+ TokenParsing m,+ DeltaParsing m,+ LookAheadParsing m,+ Errable m+ ) -newtype EDE a = EDE { runEDE :: Tri.Parser a }- deriving- ( Functor- , Applicative- , Alternative- , Monad- , MonadPlus- , Parsing- , CharParsing- , DeltaParsing- , LookAheadParsing- , Errable- )+newtype EDE a = EDE {runEDE :: Tri.Parser a}+ deriving+ ( Functor,+ Applicative,+ Alternative,+ Monad,+#if MIN_VERSION_base(4,13,0)+ MonadFail,+#endif+ MonadPlus,+ Parsing,+ CharParsing,+ DeltaParsing,+ LookAheadParsing,+ Errable+ ) instance TokenParsing EDE where nesting (EDE m) = EDE (nesting m)@@ -98,12 +103,13 @@ {-# INLINE highlight #-} instance Errable (StateT Env EDE) where- raiseErr = lift . raiseErr+ raiseErr = lift . raiseErr -runParser :: Syntax- -> Text- -> ByteString- -> Result (Exp Delta, HashMap Text (NonEmpty Delta))+runParser ::+ Syntax ->+ Text ->+ ByteString ->+ Result (Exp Delta, HashMap Text (NonEmpty Delta)) runParser o n = res . parseByteString (runEDE run) pos where run = runStateT (pragma *> document <* eof) (Env o mempty)@@ -114,17 +120,18 @@ pragma :: Parser m => m () pragma = void . many $ do- !xs <- pragmal *> symbol "EDE_SYNTAX" *> sepBy field spaces <* trimr pragmar- mapM_ (uncurry assign) xs+ !xs <- pragmal *> symbol "EDE_SYNTAX" *> sepBy field spaces <* trimr pragmar+ mapM_ (uncurry assign) xs where field = (,) <$> setter <* symbol "=" <*> parens delim delim = (,) <$> stringLiteral <* symbol "," <*> stringLiteral - setter = pragmak "pragma" *> pure delimPragma- <|> pragmak "inline" *> pure delimInline- <|> pragmak "comment" *> pure delimComment- <|> pragmak "block" *> pure delimBlock+ setter =+ pragmak "pragma" *> pure delimPragma+ <|> pragmak "inline" *> pure delimInline+ <|> pragmak "comment" *> pure delimComment+ <|> pragmak "block" *> pure delimBlock document :: Parser m => m (Exp Delta) document = eapp <$> position <*> many (statement <|> inline <|> fragment)@@ -142,14 +149,15 @@ end1 = multiLine (pure ()) (manyTill1 anyChar (lookAhead blockr)) statement :: Parser m => m (Exp Delta)-statement = choice- [ ifelif- , cases- , loop- , include- , binding- , raw- , comment+statement =+ choice+ [ ifelif,+ cases,+ loop,+ include,+ binding,+ raw,+ comment ] block :: Parser m => String -> m a -> m a@@ -162,58 +170,68 @@ singleLine s = between (try (blockl *> s)) blockr ifelif :: Parser m => m (Exp Delta)-ifelif = eif+ifelif =+ eif <$> branch "if" <*> many (branch "elif") <*> else'- <* exit "endif"+ <* exit "endif" where branch k = (,) <$> block k term <*> document cases :: Parser m => m (Exp Delta)-cases = ecase+cases =+ ecase <$> block "case" term <*> many- ((,) <$> block "when" pattern- <*> document)+ ( (,) <$> block "when" pattern+ <*> document+ ) <*> else'- <* exit "endcase"+ <* exit "endcase" loop :: Parser m => m (Exp Delta) loop = do- (i, v) <- block "for"- ((,) <$> identifier- <*> (keyword "in" *> collection))- d <- document- eempty v (extract v :< ELoop i v d)- <$> else'- <* exit "endfor"+ (i, v) <-+ block+ "for"+ ( (,) <$> identifier+ <*> (keyword "in" *> collection)+ )+ d <- document+ eempty v (extract v :< ELoop i v d)+ <$> else'+ <* exit "endfor" include :: Parser m => m (Exp Delta) include = block "include" $ do- d <- position- k <- stringLiteral- includes %= Map.insertWith (<>) k (d:|[])- elet <$> scope <*> pure (d :< EIncl k)+ d <- position+ k <- stringLiteral+ includes %= Map.insertWith (<>) k (d :| [])+ elet <$> scope <*> pure (d :< EIncl k) where- scope = optional $+ scope =+ optional $ (,) <$> (keyword "with" *> identifier)- <*> (symbol "=" *> term)+ <*> (symbol "=" *> term) binding :: Parser m => m (Exp Delta)-binding = elet . Just- <$> block "let"- ((,) <$> identifier- <*> (symbol "=" *> term))+binding =+ elet . Just+ <$> block+ "let"+ ( (,) <$> identifier+ <*> (symbol "=" *> term)+ ) <*> document- <* exit "endlet"+ <* exit "endlet" raw :: Parser m => m (Exp Delta) raw = ann (ELit <$> body) where- body = start *> pack (manyTill anyChar (lookAhead end)) <* end+ body = start *> pack (manyTill anyChar (lookAhead end)) <* end start = block "raw" (pure ())- end = exit "endraw"+ end = exit "endraw" -- FIXME: this is due to the whitespace sensitive nature of the parser making -- it difficult to do what most applicative parsers do by skipping comments@@ -221,8 +239,9 @@ comment :: Parser m => m (Exp Delta) comment = ann (ELit <$> pure (String mempty) <* (try (triml (trimr go)) <|> go)) where- go = (commentStyle <$> commentl <*> commentr) >>=- buildSomeSpaceParser (fail "whitespace significant")+ go =+ (commentStyle <$> commentl <*> commentr)+ >>= buildSomeSpaceParser (fail "whitespace significant") else' :: Parser m => m (Maybe (Exp Delta)) else' = optional (block "else" (pure ()) *> document)@@ -240,24 +259,29 @@ term0 = buildExpressionParser table expr where table =- [ [prefix "!"]- , [infix' "*", infix' "/"]- , [infix' "-", infix' "+"]- , [infix' "==", infix' "!=", infix' ">", infix' ">=", infix' "<", infix' "<="]- , [infix' "&&"]- , [infix' "||"]- ]+ [ [prefix "!"],+ [infix' "*", infix' "/"],+ [infix' "-", infix' "+"],+ [infix' "==", infix' "!=", infix' ">", infix' ">=", infix' "<", infix' "<="],+ [infix' "&&"],+ [infix' "||"]+ ] prefix n = Prefix (efun <$ operator n <*> pure n) - infix' n = Infix (do- d <- operator n- return $ \l r ->- d :< EApp (efun n l) r) AssocLeft+ infix' n =+ Infix+ ( do+ d <- operator n+ return $ \l r ->+ d :< EApp (efun n l) r+ )+ AssocLeft - expr = parens term- <|> ann (EVar <$> variable)- <|> ann (ELit <$> literal)+ expr =+ parens term+ <|> ann (EVar <$> variable)+ <|> ann (ELit <$> literal) filter' :: Parser m => m (Id, [Exp Delta]) filter' = (,) <$> identifier <*> (parens (commaSep1 term) <|> pure [])@@ -265,16 +289,18 @@ collection :: Parser m => m (Exp Delta) collection = ann (EVar <$> variable <|> ELit <$> col) where- col = Object <$> object- <|> Array <$> array- <|> String <$> stringLiteral+ col =+ Object <$> object+ <|> Array <$> array+ <|> String <$> stringLiteral literal :: Parser m => m Value-literal = Bool <$> bool- <|> Number <$> number- <|> String <$> stringLiteral- <|> Object <$> object- <|> Array <$> array+literal =+ Bool <$> bool+ <|> Number <$> number+ <|> String <$> stringLiteral+ <|> Object <$> object+ <|> Array <$> array number :: Parser m => m Scientific number = either fromIntegral fromFloatDigits <$> integerOrDouble@@ -285,7 +311,8 @@ object :: Parser m => m Object object = Map.fromList <$> braces (commaSep pair) where- pair = (,)+ pair =+ (,) <$> (stringLiteral <* spaces) <*> (char ':' *> spaces *> literal) @@ -313,13 +340,13 @@ manyEndBy1 :: Alternative m => m a -> m a -> m [a] manyEndBy1 p end = go where- go = (:[]) <$> end <|> (:) <$> p <*> go+ go = (: []) <$> end <|> (:) <$> p <*> go chainl1' :: Alternative m => m a -> m b -> m (a -> b -> a) -> m a chainl1' l r op = scan where scan = flip id <$> l <*> rst- rst = (\f y g x -> g (f x y)) <$> op <*> r <*> rst <|> pure id+ rst = (\f y g x -> g (f x y)) <$> op <*> r <*> rst <|> pure id ann :: (DeltaParsing m, Functor f) => m (f (Mu f)) -> m (Cofree f Delta) ann p = cofree <$> position <*> (Mu <$> p)@@ -329,10 +356,10 @@ triml :: Parser m => m a -> m a triml p = do- c <- column <$> position- if c == 0- then spaces *> p- else fail "left whitespace removal failed"+ c <- column <$> position+ if c == 0+ then spaces *> p+ else fail "left whitespace removal failed" trimr :: Parser m => m a -> m a trimr p = p <* spaces <* newline@@ -341,21 +368,21 @@ pragmak = reserve pragmaStyle pragmal, pragmar :: Parser m => m String-pragmal = left delimPragma >>= symbol+pragmal = left delimPragma >>= symbol pragmar = right delimPragma >>= string commentl, commentr :: MonadState Env m => m String-commentl = left delimComment+commentl = left delimComment commentr = right delimComment inlinel, inliner :: Parser m => m String-inlinel = left delimInline >>= symbol+inlinel = left delimInline >>= symbol inliner = right delimInline >>= string blockl, blockr :: Parser m => m String-blockl = left delimBlock >>= symbol+blockl = left delimBlock >>= symbol blockr = right delimBlock >>= string left, right :: MonadState s m => Getter s Delim -> m String-left d = gets (fst . view d)+left d = gets (fst . view d) right d = gets (snd . view d)
src/Text/EDE/Internal/Quoting.hs view
@@ -1,15 +1,15 @@-{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}-+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} -- Module : Text.EDE.Internal.Quoting--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -20,165 +20,194 @@ module Text.EDE.Internal.Quoting where -import Control.Applicative-import Control.Monad-import Data.Aeson hiding (Result (..))-import qualified Data.Aeson as A-import Data.Bifunctor-import qualified Data.ByteString.Char8 as BS-import qualified Data.HashMap.Strict as Map-import Data.List (sortBy)-import Data.Ord (comparing)-import Data.Scientific+import Control.Applicative+import Control.Monad+import Data.Aeson hiding (Result (..))+import qualified Data.Aeson as A+import Data.Bifunctor+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap.Strict as Map+import Data.List (sortBy)+import Data.Ord (comparing)+import Data.Scientific+#if !MIN_VERSION_base(4,11,0) import Data.Semigroup-import Data.Text (Text)-import qualified Data.Text as Text-import qualified Data.Text.Encoding as Text-import qualified Data.Text.Lazy as LText-import Data.Text.Lazy.Builder-import Data.Text.Manipulate (toOrdinal)-import qualified Data.Vector as Vector-import Text.EDE.Internal.Types-import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..), (<+>), (</>))-import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Text.Trifecta.Delta-import Text.Trifecta.Rendering+#endif+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy as LText+import Data.Text.Lazy.Builder+import Data.Text.Manipulate (toOrdinal)+import Data.Text.Prettyprint.Doc (Pretty (..), (<+>))+import qualified Data.Text.Prettyprint.Doc as PP+import qualified Data.Vector as Vector+import Text.EDE.Internal.Types+import Text.Trifecta.Delta+import Text.Trifecta.Rendering -default (Doc, Double, Integer)+default (AnsiDoc, Double, Integer) -- | A HOAS representation of (possibly partially applied) values -- in the environment. data Term- = TVal !Value- | TLam (Term -> Result Term)+ = TVal !Value+ | TLam (Term -> Result Term) -instance Pretty Term where- pretty = \case- TLam _ -> "Function"- TVal v -> PP.bold (pp v)+instance AnsiPretty Term where+ apretty = \case+ TLam _ -> "Function"+ TVal v -> bold (pp v) -- | Fully apply two 'Term's. qapply :: Delta -> Term -> Term -> Result Term qapply d a b = case (a, b) of- (TLam f, x) ->- case f x of- Failure e -> Failure (pretty d <+> PP.red "error:" <+> e)- Success y -> return y- (TVal x, _) -> Failure $- "unable to apply literal"- <+> pretty a- <+> "->"- <+> pretty b- </> pp x+ (TLam f, x) ->+ case f x of+ Failure e -> Failure (prettyDelta d <+> red "error:" <+> e)+ Success y -> return y+ (TVal x, _) ->+ Failure $+ "unable to apply literal"+ <+> apretty a+ <+> "->"+ <+> apretty b+ </> pp x -- | Quote a primitive 'Value' from the top-level. qprim :: (ToJSON a, Quote a) => a -> Term qprim = quote "Value" 0 class Unquote a where- unquote :: Id -> Int -> Term -> Result a-- default unquote :: FromJSON a => Id -> Int -> Term -> Result a- unquote k n = \case- f@TLam{} -> typeErr k n (pretty f) "Value"- TVal v ->- case fromJSON v of- A.Success x -> pure x- A.Error e -> argumentErr k n e+ unquote :: Id -> Int -> Term -> Result a+ default unquote :: FromJSON a => Id -> Int -> Term -> Result a+ unquote k n = \case+ f@TLam {} -> typeErr k n (apretty f) "Value"+ TVal v ->+ case fromJSON v of+ A.Success x -> pure x+ A.Error e -> argumentErr k n e instance Unquote Value+ instance Unquote Text+ instance Unquote [Text]+ instance Unquote LText.Text+ instance Unquote Bool+ instance Unquote Double+ instance Unquote Scientific+ instance Unquote Object+ instance Unquote Array instance Unquote Int where- unquote k n = unquote k n >=>- maybe (typeErr k n "Double" "Int") pure- . toBoundedInteger+ unquote k n =+ unquote k n+ >=> maybe (typeErr k n "Double" "Int") pure+ . toBoundedInteger instance Unquote Integer where- unquote k n = unquote k n >=>- either (const (typeErr k n "Double" "Integral")) pure- . floatingOrInteger+ unquote k n =+ unquote k n+ >=> either (const (typeErr k n "Double" "Integral")) pure+ . floatingOrInteger instance Unquote Collection where- unquote k n q =- text <$> unquote k n q- <|> hashMap <$> unquote k n q- <|> vector <$> unquote k n q- where- text t = Col (Text.length t)- . map (\c -> (Nothing, String (Text.singleton c)))- $ Text.unpack t+ unquote k n q =+ text <$> unquote k n q+ <|> hashMap <$> unquote k n q+ <|> vector <$> unquote k n q+ where+ text t =+ Col (Text.length t)+ . map (\c -> (Nothing, String (Text.singleton c)))+ $ Text.unpack t - hashMap m = Col (Map.size m)- . map (first Just)- . sortBy (comparing fst)- $ Map.toList m+ hashMap m =+ Col (Map.size m)+ . map (first Just)+ . sortBy (comparing fst)+ $ Map.toList m - vector v = Col (Vector.length v) (Vector.map (Nothing,) v)+ vector v = Col (Vector.length v) (Vector.map (Nothing,) v) class Quote a where- quote :: Id -> Int -> a -> Term-- default quote :: ToJSON a => Id -> Int -> a -> Term- quote _ _ = TVal . toJSON+ quote :: Id -> Int -> a -> Term+ default quote :: ToJSON a => Id -> Int -> a -> Term+ quote _ _ = TVal . toJSON instance (Unquote a, Quote b) => Quote (a -> b) where- quote k n f = TLam $ \x -> quote k n' . f <$> unquote k n' x- where- n' = succ n+ quote k n f = TLam $ \x -> quote k n' . f <$> unquote k n' x+ where+ n' = succ n instance Quote Term where- quote _ _ = id+ quote _ _ = id instance Quote Value+ instance Quote [Value]+ instance Quote Text+ instance Quote [Text]+ instance Quote LText.Text+ instance Quote Bool+ instance Quote Int+ instance Quote Integer+ instance Quote Double+ instance Quote Scientific+ instance Quote Object+ instance Quote Array instance Quote Builder where- quote k n = quote k n . toLazyText+ quote k n = quote k n . toLazyText -typeErr :: Id -> Int -> Doc -> Doc -> Result a+typeErr :: Id -> Int -> AnsiDoc -> AnsiDoc -> Result a typeErr k n x y = Failure $ "type" <+> pp k <+> pretty n <+> x <+> "::" <+> y argumentErr :: Pretty a => Id -> Int -> a -> Result b argumentErr k n e = Failure $ if self then app else arg where- app = "unable to apply"- <+> PP.bold (pp k)+ app =+ "unable to apply"+ <+> bold (pp k) <+> "to left hand side:"- </> PP.indent 4 (pretty e </> pretty mark)+ </> PP.indent 4 (pretty e </> prettyRendering mark) - arg = "invalid"- <+> PP.bold (pp $ toOrdinal (n - 1))+ arg =+ "invalid"+ <+> bold (pp $ toOrdinal (n - 1)) <+> "argument to"- <+> PP.bold (pp k)- <> ":"- </> PP.indent 4 (pretty e </> pretty mark)+ <+> bold (pp k)+ <> ":"+ </> PP.indent 4 (pretty e </> prettyRendering mark) - mark = renderingCaret (Columns col col) $+ mark =+ renderingCaret (Columns col col) $ "... | " <> Text.encodeUtf8 k <> line - col | self = 1- | otherwise = fromIntegral (Text.length k + 4 + (n * 2))+ col+ | self = 1+ | otherwise = fromIntegral (Text.length k + 4 + (n * 2)) - line | self = "\n"- | otherwise =- "(" <> BS.intercalate ", " (replicate (n - 1) "...") <> "\n"+ line+ | self = "\n"+ | otherwise =+ "(" <> BS.intercalate ", " (replicate (n - 1) "...") <> "\n" self = n <= 1
src/Text/EDE/Internal/Syntax.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- Module : Text.EDE.Internal.Syntax--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -12,12 +12,12 @@ module Text.EDE.Internal.Syntax where -import Control.Lens-import Data.HashSet (HashSet)-import qualified Data.HashSet as Set-import Text.EDE.Internal.Types-import Text.Parser.Token.Style-import Text.Trifecta+import Control.Lens+import Data.HashSet (HashSet)+import qualified Data.HashSet as Set+import Text.EDE.Internal.Types+import Text.Parser.Token.Style+import Text.Trifecta -- | The default ED-E syntax. --@@ -30,13 +30,13 @@ -- * Comments: @{# ... #}@ -- -- * Blocks: @{% ... %}@--- defaultSyntax :: Syntax-defaultSyntax = Syntax- { _delimPragma = ("{!", "!}")- , _delimInline = ("{{", "}}")- , _delimComment = ("{#", "#}")- , _delimBlock = ("{%", "%}")+defaultSyntax =+ Syntax+ { _delimPragma = ("{!", "!}"),+ _delimInline = ("{{", "}}"),+ _delimComment = ("{#", "#}"),+ _delimBlock = ("{%", "%}") } -- | An alternate syntax (based on Play/Scala templates) designed to@@ -50,13 +50,13 @@ -- * Comments: @\@* ... *\@@ -- -- * Blocks: @\@( ... )\@@--- alternateSyntax :: Syntax-alternateSyntax = Syntax- { _delimPragma = ("@!", "!@")- , _delimInline = ("<@", "@>")- , _delimComment = ("@*", "*@")- , _delimBlock = ("@(", ")@")+alternateSyntax =+ Syntax+ { _delimPragma = ("@!", "!@"),+ _delimInline = ("<@", "@>"),+ _delimComment = ("@*", "*@"),+ _delimBlock = ("@(", ")@") } commentStyle :: String -> String -> CommentStyle@@ -69,41 +69,45 @@ variableStyle = keywordStyle & styleName .~ "variable" keywordStyle :: TokenParsing m => IdentifierStyle m-keywordStyle = haskellIdents+keywordStyle =+ haskellIdents & styleReserved .~ keywordSet- & styleName .~ "keyword"+ & styleName .~ "keyword" keywordSet :: HashSet String-keywordSet = Set.fromList- [ "if"- , "elif"- , "else"- , "case"- , "when"- , "for"- , "include"- , "let"- , "endif"- , "endcase"- , "endfor"- , "endlet"- , "in"- , "with"- , "_"- , "."- , "true"- , "false"+keywordSet =+ Set.fromList+ [ "if",+ "elif",+ "else",+ "case",+ "when",+ "for",+ "include",+ "let",+ "endif",+ "endcase",+ "endfor",+ "endlet",+ "in",+ "with",+ "_",+ ".",+ "true",+ "false" ] pragmaStyle :: TokenParsing m => IdentifierStyle m-pragmaStyle = haskellIdents+pragmaStyle =+ haskellIdents & styleReserved .~ pragmaSet- & styleName .~ "pragma field"+ & styleName .~ "pragma field" pragmaSet :: HashSet String-pragmaSet = Set.fromList- [ "pragma"- , "inline"- , "comment"- , "block"+pragmaSet =+ Set.fromList+ [ "pragma",+ "inline",+ "comment",+ "block" ]
src/Text/EDE/Internal/Types.hs view
@@ -1,21 +1,17 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}--#if __GLASGOW_HASKELL__ < 710-{-# LANGUAGE OverlappingInstances #-}-#endif+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-} -- Module : Text.EDE.Internal.Types--- Copyright : (c) 2013-2015 Brendan Hay <brendan.g.hay@gmail.com>+-- Copyright : (c) 2013-2020 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of -- the Mozilla Public License, v. 2.0. -- A copy of the MPL can be found in the LICENSE file or@@ -26,82 +22,92 @@ module Text.EDE.Internal.Types where -import Control.Applicative-import Control.Comonad-import Control.Comonad.Cofree-import Control.Lens-import Data.Aeson.Types hiding (Result (..))-import Data.Foldable-import Data.HashMap.Strict (HashMap)-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NonEmpty-import Data.Monoid (mempty)-import Data.Semigroup-import Data.Text (Text)-import qualified Data.Text as Text-import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty (..))-import qualified Text.PrettyPrint.ANSI.Leijen as PP-import Text.Trifecta.Delta-#if MIN_VERSION_base(4,9,0)-import qualified Data.List as List-import qualified Data.Functor.Classes as FunctorClasses-#endif+import Control.Applicative+import Control.Comonad+import Control.Comonad.Cofree+import Control.Lens+import Data.Aeson.Types hiding (Result (..))+import qualified Data.Functor.Classes as FunctorClasses+import Data.HashMap.Strict (HashMap)+import qualified Data.List as List+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Prettyprint.Doc (Doc, Pretty (..))+import qualified Data.Text.Prettyprint.Doc as PP+import qualified Data.Text.Prettyprint.Doc.Render.Terminal as PP+import Text.Trifecta.Delta +type AnsiDoc = Doc PP.AnsiStyle++class AnsiPretty a where+ apretty :: a -> AnsiDoc+ -- | Convenience wrapper for Pretty instances.-newtype PP a = PP { unPP :: a }+newtype PP a = PP {unPP :: a} -pp :: Pretty (PP a) => a -> Doc-pp = pretty . PP+pp :: AnsiPretty (PP a) => a -> AnsiDoc+pp = apretty . PP -instance Pretty (PP Text) where- pretty = PP.string . Text.unpack . unPP+(</>) :: Doc ann -> Doc ann -> Doc ann+x </> y = x <> PP.softline <> y -instance Pretty (PP Value) where- pretty (PP v) =- case v of- Null -> "Null"- Bool _ -> "Bool"- Number _ -> "Scientific"- Object _ -> "Object"- Array _ -> "Array"- String _ -> "String"+bold :: AnsiDoc -> AnsiDoc+bold = PP.annotate PP.bold +red :: AnsiDoc -> AnsiDoc+red = PP.annotate (PP.color PP.Red)++instance AnsiPretty (PP Text) where+ apretty = pretty . Text.unpack . unPP++instance AnsiPretty (PP Value) where+ apretty (PP v) =+ case v of+ Null -> "Null"+ Bool _ -> "Bool"+ Number _ -> "Scientific"+ Object _ -> "Object"+ Array _ -> "Array"+ String _ -> "String"+ -- | The result of running parsing or rendering steps. data Result a- = Success a- | Failure Doc- deriving (Show, Functor, Foldable, Traversable)+ = Success a+ | Failure AnsiDoc+ deriving (Show, Functor, Foldable, Traversable) makePrisms ''Result instance Monad Result where- return = Success- {-# INLINE return #-}- Success x >>= k = k x- Failure e >>= _ = Failure e- {-# INLINE (>>=) #-}+ return = Success+ {-# INLINE return #-}+ Success x >>= k = k x+ Failure e >>= _ = Failure e+ {-# INLINE (>>=) #-} instance Applicative Result where- pure = return- {-# INLINE pure #-}- Success f <*> Success x = Success (f x)- Success _ <*> Failure e = Failure e- Failure e <*> Success _ = Failure e- Failure e <*> Failure e' = Failure (PP.vsep [e, e'])- {-# INLINE (<*>) #-}+ pure = return+ {-# INLINE pure #-}+ Success f <*> Success x = Success (f x)+ Success _ <*> Failure e = Failure e+ Failure e <*> Success _ = Failure e+ Failure e <*> Failure e' = Failure (PP.vsep [e, e'])+ {-# INLINE (<*>) #-} instance Alternative Result where- Success x <|> Success _ = Success x- Success x <|> Failure _ = Success x- Failure _ <|> Success x = Success x- Failure e <|> Failure e' = Failure (PP.vsep [e, e'])- {-# INLINE (<|>) #-}- empty = Failure mempty- {-# INLINE empty #-}+ Success x <|> Success _ = Success x+ Success x <|> Failure _ = Success x+ Failure _ <|> Success x = Success x+ Failure e <|> Failure e' = Failure (PP.vsep [e, e'])+ {-# INLINE (<|>) #-}+ empty = Failure mempty+ {-# INLINE empty #-} -instance Show a => Pretty (Result a) where- pretty (Success x) = pretty (show x)- pretty (Failure e) = pretty e+instance Show a => AnsiPretty (Result a) where+ apretty (Success x) = pretty (show x)+ apretty (Failure e) = e -- | Convert a 'Result' to an 'Either' with the 'Left' case holding a -- formatted error message, and 'Right' being the successful result over@@ -110,10 +116,14 @@ eitherResult = result (Left . show) Right -- | Perform a case analysis on a 'Result'.-result :: (Doc -> b) -- ^ Function to apply to the 'Failure' case.- -> (a -> b) -- ^ Function to apply to the 'Success' case.- -> Result a -- ^ The 'Result' to map over.- -> b+result ::+ -- | Function to apply to the 'Failure' case.+ (AnsiDoc -> b) ->+ -- | Function to apply to the 'Success' case.+ (a -> b) ->+ -- | The 'Result' to map over.+ Result a ->+ b result _ g (Success x) = g x result f _ (Failure e) = f e @@ -122,99 +132,97 @@ success = return . Success -- | Convenience for returning an error 'Result'.-failure :: Monad m => Doc -> m (Result a)+failure :: Monad m => AnsiDoc -> m (Result a) failure = return . Failure type Delim = (String, String) data Syntax = Syntax- { _delimPragma :: !Delim- , _delimInline :: !Delim- , _delimComment :: !Delim- , _delimBlock :: !Delim- }+ { _delimPragma :: !Delim,+ _delimInline :: !Delim,+ _delimComment :: !Delim,+ _delimBlock :: !Delim+ } makeClassy ''Syntax -- | A function to resolve the target of an @include@ expression. type Resolver m = Syntax -> Id -> Delta -> m (Result Template) -instance-#if __GLASGOW_HASKELL__ >= 710- {-# OVERLAPPING #-}-#endif- Applicative m => Semigroup (Resolver m) where- (f <> g) o k d = liftA2 (<|>) (f o k d) (g o k d) -- Haha!- {-# INLINE (<>) #-}+-- instance Applicative m => Semigroup (Resolver m) where+-- (f <> g) o k d = liftA2 (<|>) (f o k d) (g o k d) -- Haha!+-- {-# INLINE (<>) #-} -- | A parsed and compiled template. data Template = Template- { _tmplName :: !Text- , _tmplExp :: !(Exp Delta)- , _tmplIncl :: HashMap Id (Exp Delta)- } deriving (Eq)+ { _tmplName :: !Text,+ _tmplExp :: !(Exp Delta),+ _tmplIncl :: HashMap Id (Exp Delta)+ }+ deriving (Eq) type Id = Text newtype Var = Var (NonEmpty Id)- deriving (Eq)+ deriving (Eq) -instance Pretty Var where- pretty (Var is) = PP.hcat- . PP.punctuate "."- . map (PP.bold . pp)- . reverse- $ NonEmpty.toList is+instance AnsiPretty Var where+ apretty (Var is) =+ PP.hcat+ . PP.punctuate "."+ . map (PP.annotate PP.bold . pp)+ . reverse+ $ NonEmpty.toList is instance Show Var where- show = show . pretty+ show = show . apretty data Collection where- Col :: Foldable f => Int -> f (Maybe Text, Value) -> Collection+ Col :: Foldable f => Int -> f (Maybe Text, Value) -> Collection data Pat- = PWild- | PVar !Var- | PLit !Value- deriving (Eq, Show)+ = PWild+ | PVar !Var+ | PLit !Value+ deriving (Eq, Show) type Alt a = (Pat, a) data ExpF a- = ELit !Value- | EVar !Var- | EFun !Id- | EApp !a !a- | ELet !Id !a !a- | ECase !a [Alt a]- | ELoop !Id !a !a- | EIncl !Text- deriving (Eq, Show, Functor)-#if MIN_VERSION_base(4,9,0)+ = ELit !Value+ | EVar !Var+ | EFun !Id+ | EApp !a !a+ | ELet !Id !a !a+ | ECase !a [Alt a]+ | ELoop !Id !a !a+ | EIncl !Text+ deriving (Eq, Show, Functor)+ instance FunctorClasses.Eq1 ExpF where- liftEq _ (ELit a) (ELit b) = a == b- liftEq _ (EVar a) (EVar b) = a == b- liftEq _ (EFun a) (EFun b) = a == b- liftEq c (EApp a1 a2) (EApp b1 b2) = a1 `c` b1 && a2 `c` b2- liftEq c (ELet a0 a1 a2) (ELet b0 b1 b2) = a0 == b0 && a1 `c` b1 && a2 `c` b2- liftEq c (ECase a as) (ECase b bs) = a `c` b && (List.all (uncurry altEq) $ zip as bs)- where altEq (pA, a') (pB, b') = pA == pB && a' `c` b'- liftEq c (ELoop a0 a1 a2) (ELoop b0 b1 b2) = a0 == b0 && a1 `c` b1 && a2 `c` b2- liftEq _ (EIncl a) (EIncl b) = a == b- liftEq _ _ _ = False-#endif+ liftEq _ (ELit a) (ELit b) = a == b+ liftEq _ (EVar a) (EVar b) = a == b+ liftEq _ (EFun a) (EFun b) = a == b+ liftEq c (EApp a1 a2) (EApp b1 b2) = a1 `c` b1 && a2 `c` b2+ liftEq c (ELet a0 a1 a2) (ELet b0 b1 b2) = a0 == b0 && a1 `c` b1 && a2 `c` b2+ liftEq c (ECase a as) (ECase b bs) = a `c` b && (List.all (uncurry altEq) $ zip as bs)+ where+ altEq (pA, a') (pB, b') = pA == pB && a' `c` b'+ liftEq c (ELoop a0 a1 a2) (ELoop b0 b1 b2) = a0 == b0 && a1 `c` b1 && a2 `c` b2+ liftEq _ (EIncl a) (EIncl b) = a == b+ liftEq _ _ _ = False type Exp = Cofree ExpF instance HasDelta (Exp Delta) where- delta = extract+ delta = extract -- | Unwrap a 'Value' to an 'Object' safely. -- -- See 'Aeson''s documentation for more details. fromValue :: Value -> Maybe Object fromValue (Object o) = Just o-fromValue _ = Nothing+fromValue _ = Nothing -- | Create an 'Object' from a list of name/value 'Pair's. --
test/Main.hs view
@@ -12,21 +12,20 @@ module Main (main) where -import Control.Applicative-import qualified Data.Aeson as Aeson-import Data.Bifunctor-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import Data.List (isSuffixOf)-import Data.Maybe-import qualified Data.Text as Text+import qualified Data.Aeson as Aeson+import Data.Bifunctor+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import Data.List (isSuffixOf)+import Data.Maybe+import qualified Data.Text as Text import qualified Data.Text.Lazy.Encoding as LText-import Paths_ede-import System.Directory-import System.IO.Unsafe-import Test.Tasty-import Test.Tasty.Golden-import Text.EDE+import Paths_ede+import System.Directory+import System.IO.Unsafe+import Test.Tasty+import Test.Tasty.Golden+import Text.EDE main :: IO () main = defaultMain . testGroup "ED-E" $ unsafePerformIO tests@@ -41,28 +40,32 @@ tests = files >>= mapM test where files :: IO [FilePath]- files = map (resources ++) . filter (isSuffixOf ".ede")+ files =+ map (resources ++) . filter (isSuffixOf ".ede") <$> getDirectoryContents resources test :: FilePath -> IO TestTree test f = do- (bs, n) <- (,)- <$> BS.readFile f- <*> pure (takeWhile (/= '.') f)+ (bs, n) <-+ (,)+ <$> BS.readFile f+ <*> pure (takeWhile (/= '.') f) - let (js, src) = split bs- name = Text.pack (n ++ ".ede")+ let (js, src) = split bs+ name = Text.pack (n ++ ".ede") - return . goldenVsStringDiff n diff (n ++ ".golden") $ do- r <- parseWith defaultSyntax include name src- result (error . show)- (return . LText.encodeUtf8)- (r >>= (`render` js))+ return . goldenVsStringDiff n diff (n ++ ".golden") $ do+ r <- parseWith defaultSyntax include name src+ result+ (error . show)+ (return . LText.encodeUtf8)+ (r >>= (`render` js)) diff r n = ["diff", "-u", r, n] split = bimap input (BS.drop 4) . BS.breakSubstring "---" - input = fromMaybe (error "Failed parsing JSON")+ input =+ fromMaybe (error "Failed parsing JSON") . Aeson.decode' . LBS.fromStrict