diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,373 @@ +Mozilla Public License Version 2.0 +================================== + +1. Definitions +-------------- + +1.1. "Contributor" + means each individual or legal entity that creates, contributes to + the creation of, or owns Covered Software. + +1.2. "Contributor Version" + means the combination of the Contributions of others (if any) used + by a Contributor and that particular Contributor's Contribution. + +1.3. "Contribution" + means Covered Software of a particular Contributor. + +1.4. "Covered Software" + means Source Code Form to which the initial Contributor has attached + the notice in Exhibit A, the Executable Form of such Source Code + Form, and Modifications of such Source Code Form, in each case + including portions thereof. + +1.5. "Incompatible With Secondary Licenses" + means + + (a) that the initial Contributor has attached the notice described + in Exhibit B to the Covered Software; or + + (b) that the Covered Software was made available under the terms of + version 1.1 or earlier of the License, but not also under the + terms of a Secondary License. + +1.6. "Executable Form" + means any form of the work other than Source Code Form. + +1.7. "Larger Work" + means a work that combines Covered Software with other material, in + a separate file or files, that is not Covered Software. + +1.8. "License" + means this document. + +1.9. "Licensable" + means having the right to grant, to the maximum extent possible, + whether at the time of the initial grant or subsequently, any and + all of the rights conveyed by this License. + +1.10. "Modifications" + means any of the following: + + (a) any file in Source Code Form that results from an addition to, + deletion from, or modification of the contents of Covered + Software; or + + (b) any new file in Source Code Form that contains any Covered + Software. + +1.11. "Patent Claims" of a Contributor + means any patent claim(s), including without limitation, method, + process, and apparatus claims, in any patent Licensable by such + Contributor that would be infringed, but for the grant of the + License, by the making, using, selling, offering for sale, having + made, import, or transfer of either its Contributions or its + Contributor Version. + +1.12. "Secondary License" + means either the GNU General Public License, Version 2.0, the GNU + Lesser General Public License, Version 2.1, the GNU Affero General + Public License, Version 3.0, or any later versions of those + licenses. + +1.13. "Source Code Form" + means the form of the work preferred for making modifications. + +1.14. "You" (or "Your") + means an individual or a legal entity exercising rights under this + License. For legal entities, "You" includes any entity that + controls, is controlled by, or is under common control with You. For + purposes of this definition, "control" means (a) the power, direct + or indirect, to cause the direction or management of such entity, + whether by contract or otherwise, or (b) ownership of more than + fifty percent (50%) of the outstanding shares or beneficial + ownership of such entity. + +2. License Grants and Conditions +-------------------------------- + +2.1. Grants + +Each Contributor hereby grants You a world-wide, royalty-free, +non-exclusive license: + +(a) under intellectual property rights (other than patent or trademark) + Licensable by such Contributor to use, reproduce, make available, + modify, display, perform, distribute, and otherwise exploit its + Contributions, either on an unmodified basis, with Modifications, or + as part of a Larger Work; and + +(b) under Patent Claims of such Contributor to make, use, sell, offer + for sale, have made, import, and otherwise transfer either its + Contributions or its Contributor Version. + +2.2. Effective Date + +The licenses granted in Section 2.1 with respect to any Contribution +become effective for each Contribution on the date the Contributor first +distributes such Contribution. + +2.3. Limitations on Grant Scope + +The licenses granted in this Section 2 are the only rights granted under +this License. No additional rights or licenses will be implied from the +distribution or licensing of Covered Software under this License. +Notwithstanding Section 2.1(b) above, no patent license is granted by a +Contributor: + +(a) for any code that a Contributor has removed from Covered Software; + or + +(b) for infringements caused by: (i) Your and any other third party's + modifications of Covered Software, or (ii) the combination of its + Contributions with other software (except as part of its Contributor + Version); or + +(c) under Patent Claims infringed by Covered Software in the absence of + its Contributions. + +This License does not grant any rights in the trademarks, service marks, +or logos of any Contributor (except as may be necessary to comply with +the notice requirements in Section 3.4). + +2.4. Subsequent Licenses + +No Contributor makes additional grants as a result of Your choice to +distribute the Covered Software under a subsequent version of this +License (see Section 10.2) or under the terms of a Secondary License (if +permitted under the terms of Section 3.3). + +2.5. Representation + +Each Contributor represents that the Contributor believes its +Contributions are its original creation(s) or it has sufficient rights +to grant the rights to its Contributions conveyed by this License. + +2.6. Fair Use + +This License is not intended to limit any rights You have under +applicable copyright doctrines of fair use, fair dealing, or other +equivalents. + +2.7. Conditions + +Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted +in Section 2.1. + +3. Responsibilities +------------------- + +3.1. Distribution of Source Form + +All distribution of Covered Software in Source Code Form, including any +Modifications that You create or to which You contribute, must be under +the terms of this License. You must inform recipients that the Source +Code Form of the Covered Software is governed by the terms of this +License, and how they can obtain a copy of this License. You may not +attempt to alter or restrict the recipients' rights in the Source Code +Form. + +3.2. Distribution of Executable Form + +If You distribute Covered Software in Executable Form then: + +(a) such Covered Software must also be made available in Source Code + Form, as described in Section 3.1, and You must inform recipients of + the Executable Form how they can obtain a copy of such Source Code + Form by reasonable means in a timely manner, at a charge no more + than the cost of distribution to the recipient; and + +(b) You may distribute such Executable Form under the terms of this + License, or sublicense it under different terms, provided that the + license for the Executable Form does not attempt to limit or alter + the recipients' rights in the Source Code Form under this License. + +3.3. Distribution of a Larger Work + +You may create and distribute a Larger Work under terms of Your choice, +provided that You also comply with the requirements of this License for +the Covered Software. If the Larger Work is a combination of Covered +Software with a work governed by one or more Secondary Licenses, and the +Covered Software is not Incompatible With Secondary Licenses, this +License permits You to additionally distribute such Covered Software +under the terms of such Secondary License(s), so that the recipient of +the Larger Work may, at their option, further distribute the Covered +Software under the terms of either this License or such Secondary +License(s). + +3.4. Notices + +You may not remove or alter the substance of any license notices +(including copyright notices, patent notices, disclaimers of warranty, +or limitations of liability) contained within the Source Code Form of +the Covered Software, except that You may alter any license notices to +the extent required to remedy known factual inaccuracies. + +3.5. Application of Additional Terms + +You may choose to offer, and to charge a fee for, warranty, support, +indemnity or liability obligations to one or more recipients of Covered +Software. However, You may do so only on Your own behalf, and not on +behalf of any Contributor. You must make it absolutely clear that any +such warranty, support, indemnity, or liability obligation is offered by +You alone, and You hereby agree to indemnify every Contributor for any +liability incurred by such Contributor as a result of warranty, support, +indemnity or liability terms You offer. You may include additional +disclaimers of warranty and limitations of liability specific to any +jurisdiction. + +4. Inability to Comply Due to Statute or Regulation +--------------------------------------------------- + +If it is impossible for You to comply with any of the terms of this +License with respect to some or all of the Covered Software due to +statute, judicial order, or regulation then You must: (a) comply with +the terms of this License to the maximum extent possible; and (b) +describe the limitations and the code they affect. Such description must +be placed in a text file included with all distributions of the Covered +Software under this License. Except to the extent prohibited by statute +or regulation, such description must be sufficiently detailed for a +recipient of ordinary skill to be able to understand it. + +5. Termination +-------------- + +5.1. The rights granted under this License will terminate automatically +if You fail to comply with any of its terms. However, if You become +compliant, then the rights granted under this License from a particular +Contributor are reinstated (a) provisionally, unless and until such +Contributor explicitly and finally terminates Your grants, and (b) on an +ongoing basis, if such Contributor fails to notify You of the +non-compliance by some reasonable means prior to 60 days after You have +come back into compliance. Moreover, Your grants from a particular +Contributor are reinstated on an ongoing basis if such Contributor +notifies You of the non-compliance by some reasonable means, this is the +first time You have received notice of non-compliance with this License +from such Contributor, and You become compliant prior to 30 days after +Your receipt of the notice. + +5.2. If You initiate litigation against any entity by asserting a patent +infringement claim (excluding declaratory judgment actions, +counter-claims, and cross-claims) alleging that a Contributor Version +directly or indirectly infringes any patent, then the rights granted to +You by any and all Contributors for the Covered Software under Section +2.1 of this License shall terminate. + +5.3. In the event of termination under Sections 5.1 or 5.2 above, all +end user license agreements (excluding distributors and resellers) which +have been validly granted by You or Your distributors under this License +prior to termination shall survive termination. + +************************************************************************ +* * +* 6. Disclaimer of Warranty * +* ------------------------- * +* * +* Covered Software is provided under this License on an "as is" * +* basis, without warranty of any kind, either expressed, implied, or * +* statutory, including, without limitation, warranties that the * +* Covered Software is free of defects, merchantable, fit for a * +* particular purpose or non-infringing. The entire risk as to the * +* quality and performance of the Covered Software is with You. * +* Should any Covered Software prove defective in any respect, You * +* (not any Contributor) assume the cost of any necessary servicing, * +* repair, or correction. This disclaimer of warranty constitutes an * +* essential part of this License. No use of any Covered Software is * +* authorized under this License except under this disclaimer. * +* * +************************************************************************ + +************************************************************************ +* * +* 7. Limitation of Liability * +* -------------------------- * +* * +* Under no circumstances and under no legal theory, whether tort * +* (including negligence), contract, or otherwise, shall any * +* Contributor, or anyone who distributes Covered Software as * +* permitted above, be liable to You for any direct, indirect, * +* special, incidental, or consequential damages of any character * +* including, without limitation, damages for lost profits, loss of * +* goodwill, work stoppage, computer failure or malfunction, or any * +* and all other commercial damages or losses, even if such party * +* shall have been informed of the possibility of such damages. This * +* limitation of liability shall not apply to liability for death or * +* personal injury resulting from such party's negligence to the * +* extent applicable law prohibits such limitation. Some * +* jurisdictions do not allow the exclusion or limitation of * +* incidental or consequential damages, so this exclusion and * +* limitation may not apply to You. * +* * +************************************************************************ + +8. Litigation +------------- + +Any litigation relating to this License may be brought only in the +courts of a jurisdiction where the defendant maintains its principal +place of business and such litigation shall be governed by laws of that +jurisdiction, without reference to its conflict-of-law provisions. +Nothing in this Section shall prevent a party's ability to bring +cross-claims or counter-claims. + +9. Miscellaneous +---------------- + +This License represents the complete agreement concerning the subject +matter hereof. If any provision of this License is held to be +unenforceable, such provision shall be reformed only to the extent +necessary to make it enforceable. Any law or regulation which provides +that the language of a contract shall be construed against the drafter +shall not be used to construe this License against a Contributor. + +10. Versions of the License +--------------------------- + +10.1. New Versions + +Mozilla Foundation is the license steward. Except as provided in Section +10.3, no one other than the license steward has the right to modify or +publish new versions of this License. Each version will be given a +distinguishing version number. + +10.2. Effect of New Versions + +You may distribute the Covered Software under the terms of the version +of the License under which You originally received the Covered Software, +or under the terms of any subsequent version published by the license +steward. + +10.3. Modified Versions + +If you create software not governed by this License, and you want to +create a new license for such software, you may create and use a +modified version of this License if you rename the license and remove +any references to the name of the license steward (except to note that +such modified license differs from this License). + +10.4. Distributing Source Code Form that is Incompatible With Secondary +Licenses + +If You choose to distribute Source Code Form that is Incompatible With +Secondary Licenses under the terms of this version of the License, the +notice described in Exhibit B of this License must be attached. + +Exhibit A - Source Code Form License Notice +------------------------------------------- + + This Source Code Form is subject to the terms of the Mozilla Public + License, v. 2.0. If a copy of the MPL was not distributed with this + file, You can obtain one at http://mozilla.org/MPL/2.0/. + +If it is not possible or desirable to put the notice in a particular +file, then You may include the notice in a location (such as a LICENSE +file in a relevant directory) where a recipient would be likely to look +for such a notice. + +You may add additional accurate notices of copyright ownership. + +Exhibit B - "Incompatible With Secondary Licenses" Notice +--------------------------------------------------------- + + This Source Code Form is "Incompatible With Secondary Licenses", as + defined by the Mozilla Public License, v. 2.0. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,37 @@ +# ED-E + +* [Introduction](#introduction) +* [Syntax](#syntax) +* [Contribute](#contribute) +* [Licence](#licence) + + +## Introduction + +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 errors. + +Please see the [documentation](http://brendanhay.github.io/ede/Text-EDE.html) +for more information. + + +## Syntax + +A set of syntatic/semantic fragments for all supported expressions can be +found in the [tests](test/resources) or the [documentation](http://brendanhay.github.io/ede/Text-EDE.html#syntax). + + +## Contribute + +For any problems, comments or feedback please create an issue [here on GitHub](github.com/brendanhay/ede/issues). + + +## Licence + +ED-E is released under the [Mozilla Public License Version 2.0](http://www.mozilla.org/MPL/) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/ede.cabal b/ede.cabal new file mode 100644 --- /dev/null +++ b/ede.cabal @@ -0,0 +1,126 @@ +name: ede +version: 0.2.1 +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 +copyright: Copyright (c) 2013-2014 Brendan Hay +stability: Experimental +category: Text, Template, Web +build-type: Simple +cabal-version: >= 1.10 + +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 + +source-repository head + type: git + location: git://github.com/brendanhay/ede.git + +flag build-executable + description: Whether to build the ed-e executable. + default: False + manual: True + +library + default-language: Haskell2010 + hs-source-dirs: src + + exposed-modules: + Text.EDE + , Text.EDE.Filters + + other-modules: + Text.EDE.Internal.Eval + , Text.EDE.Internal.HOAS + , Text.EDE.Internal.Parser + , Text.EDE.Internal.Syntax + , Text.EDE.Internal.Types + + , Paths_ede + + ghc-options: -Wall + + build-depends: + aeson >= 0.7 + , ansi-wl-pprint >= 0.6.6 + , base >= 4.6 && < 5 + , bifunctors >= 4 + , bytestring >= 0.9 + , directory >= 1.2 + , filepath >= 1.2 + , lens >= 4.0 + , mtl >= 2.2 + , parsers >= 0.12.1.1 + , scientific >= 0.3.1 + , semigroups >= 0.15 + , text >= 1.2 && < 1.3 + , text-format >= 0.3 + , text-manipulate >= 0.1 + , trifecta >= 1.5.1 + , unordered-containers >= 0.2.3 + , vector >= 0.7.1 + +executable ed-e + default-language: Haskell2010 + main-is: src/Main.hs + + ghc-options: -Wall -rtsopts "-with-rtsopts=-T -I0" + + if !flag(build-executable) + buildable: False + else + build-depends: + aeson + , base >= 4.6 && < 5 + , bytestring + , conduit == 1.2.* + , conduit-extra == 1.1.* + , directory + , ede + , optparse-applicative == 0.11.* + , text + +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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE RecordWildCards #-} + +-- Module : Text.EDE +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Main (main) where + +import Control.Monad +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.Conduit +import qualified Data.Conduit.Attoparsec as Conduit +import qualified Data.Conduit.Binary as Conduit +import Data.Monoid +import qualified Data.Text.Lazy.IO as Text +import Data.Version (showVersion) +import Options.Applicative +import qualified System.Directory as Dir +import qualified System.IO as IO +import qualified Text.EDE as EDE + +data Options = Options + { template :: FilePath + , bindings :: Maybe Object + , alternate :: !Bool + } deriving (Eq, Show) + +optionParser :: Parser Options +optionParser = Options + <$> (strOption + ( short 't' + <> long "template" + <> metavar "FILE" + <> help "ED-E template to render." + ) + <|> argument str (metavar "FILE")) + + <*> optional (option (eitherReader reader) + ( short 'd' + <> long "data" + <> metavar "JSON" + <> help ("Bindings to make available in the environment, as JSON. \ + \If not given, standard input is read.") + )) + + <*> switch + ( short 'a' + <> long "alternate-syntax" + <> help "Use alternate template syntax." + ) + +optionInfo :: ParserInfo Options +optionInfo = info (helper <*> optionParser) + ( fullDesc + <> header ("ed-e v" ++ showVersion EDE.version) + <> progDesc "ED-E Template Engine CLI." + ) + +main :: IO () +main = execParser optionInfo >>= render + where + render Options{..} = do + t <- parse template alternate + b <- maybe stdin return bindings + EDE.result errRender Text.putStrLn (EDE.render t b) + + parse f alt = do + p <- Dir.getPermissions f + unless (Dir.readable p) (errUnreadable f) + + let syntax | alt = EDE.alternateSyntax + | otherwise = EDE.defaultSyntax + + EDE.parseFileWith syntax f >>= + EDE.result (error . show) return + + stdin = do + IO.hSetBinaryMode IO.stdin True + v <- Conduit.sourceHandle IO.stdin $$ Conduit.sinkParser json' + either (error . show) return (fromValue v) + + errRender = error . mappend "Error rendering template:\n" . show + + errUnreadable = error . (<> " is not readable") + +reader :: String -> Either String Object +reader = join . fmap fromValue . eitherDecode . LBS.pack + +fromValue :: Value -> Either String Object +fromValue = maybe (Left "Bindings must be given as a JSON object") Right + . EDE.fromValue diff --git a/src/Text/EDE.hs b/src/Text/EDE.hs new file mode 100644 --- /dev/null +++ b/src/Text/EDE.hs @@ -0,0 +1,661 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} + +-- Module : Text.EDE +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | A (mostly logicless) textual templating language with similar syntax to +-- or . +-- +-- (ED-E is a character from Fallout New Vegas, pronounced 'Eddie'.) +module Text.EDE + ( + -- * How to use this library + -- $usage + + -- * Parsing and Rendering + -- $parsing_and_rendering + Template + + -- ** Parsing + , parse + , parseIO + , parseFile + , parseFileWith + , parseWith + + -- ** Includes + -- $resolvers + , Resolver + , includeMap + , includeFile + + -- ** Filters + , defaultFilters + + -- ** Rendering + , render + , renderWith + + -- ** Either Variants + , eitherParse + , eitherParseFile + , eitherParseWith + , eitherRender + , eitherRenderWith + + -- ** Results and Errors + -- $results + , Delta (..) + , Result (..) + , eitherResult + , result + , success + , failure + -- * Input + -- $input + , fromValue + , fromPairs + , (.=) + + -- * Version + , version + + -- * Syntax + , Delim + , Syntax + , delimPragma + , delimInline + , delimComment + , delimBlock + + , defaultSyntax + , alternateSyntax + + -- ** Pragmas + -- $pragmas + + -- ** Expressions + -- $expressions + + -- ** Variables + -- $variables + + -- ** Conditionals + -- $conditionals + + -- ** Case Analysis + -- $case + + -- ** Loops + -- $loops + + -- ** Includes + -- $includes + + -- ** Filters + -- $filters + + -- ** Raw + -- $raw + + -- ** Comments + -- $comments + + -- ** Let Expressions + -- $let + ) 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 +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 Text.EDE.Filters +import qualified Text.EDE.Internal.Eval as Eval +import qualified Text.EDE.Internal.Parser as Parser +import Text.EDE.Internal.Syntax +import Text.EDE.Internal.Types +import Text.PrettyPrint.ANSI.Leijen (string) +import Text.Trifecta.Delta + +-- FIXME: detect include/import loops +-- FIXME: {%- tags to deliberately strip/trim whitespace +-- FIXME: ... {% include %} inline adds a trailing newline +-- FIXME: streaming io +-- FIXME: add benchmarks +-- FIXME: add capture +-- FIXME: numerous 'try' calls were added during development, these should now be reduced. + +-- | ED-E Version. +version :: Version +version = Paths.version + +-- | Parse Lazy 'LText.Text' into a compiled 'Template'. +-- +-- Because this function is pure and does not resolve @include@s, +-- encountering an @include@ expression during parsing will result in an 'Error'. +-- +-- See 'parseFile' or 'parseWith' for mechanisms to deal with @include@ +-- dependencies. +parse :: ByteString -- ^ Strict 'ByteString' template definition. + -> 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 p = parseWith defaultSyntax (includeFile p) "Text.EDE.parse" + +-- | Load and parse a 'Template' from a file. +-- +-- 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 = 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)) + +-- | Parse a 'Template' from a Strict 'ByteString' using a custom function for +-- resolving @include@ expressions. +-- +-- Two custom @include@ resolvers are supplied: +-- +-- * 'includeMap' +-- +-- * '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 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 + + -- 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) + +-- | '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 Text Template -- ^ A 'HashMap' of named 'Template's. + -> Resolver m -- ^ Resolver for 'parseWith'. +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 + +-- | '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 p o k _ = loadFile f >>= result failure (parseWith o inc k) + where + inc = includeFile (takeDirectory f) + + 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 + +-- | 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 = renderWith defaultFilters + +-- | Render an 'Object' using the supplied 'Template'. +renderWith :: HashMap Text Binding -- ^ Filters to make available in the environment. + -> Template -- ^ Parsed 'Template' to render. + -> Object -- ^ Bindings to make available in the environment. + -> Result LText.Text +renderWith fs (Template _ u ts) = fmap toLazyText . Eval.render ts fs u + +-- | /See:/ 'parse' +eitherParse :: ByteString -> Either String Template +eitherParse = eitherResult . parse + +-- | /See:/ 'parseFile' +eitherParseFile :: FilePath -> IO (Either String Template) +eitherParseFile = fmap eitherResult . parseFile + +-- | /See:/ 'parseWith' +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 t = eitherResult . render t + +-- | /See:/ 'renderWith' +eitherRenderWith :: HashMap Text Binding + -> Template + -> Object + -> Either String LText.Text +eitherRenderWith fs t = eitherResult . renderWith fs t + +-- $usage +-- +-- A simple example of parsing and rendering 'Text' containing a basic conditional +-- expression and variable interpolation follows. +-- +-- First the 'Template' is defined: +-- +-- >>> let tmpl = "{% if var %}\nHello, {{ var }}!\n{% else %}\nnegative!\n{% endif %}\n" :: Data.ByteString.ByteString +-- +-- Then an 'Object' is defined containing the environment which will be +-- available to the 'Template' during rendering: +-- +-- >>> let env = fromPairs [ "var" .= "World" ] :: Object +-- +-- Note: the 'fromPairs' function above is a wrapper over Aeson's 'object' +-- which removes the 'Value' constructor, exposing the delicious 'HashMap' underneath. +-- +-- Finally the environment is applied to the 'Template': +-- +-- >>> render tmpl env :: Result Text +-- > Success "Hello, World!" +-- +-- In this manner, 'Template's can be pre-compiled to the internal AST and +-- the cost of parsing can be amortised if the same 'Template' is rendered multiple times. +-- +-- Another example, this time rendering a 'Template' from a file: +-- +-- > import qualified Data.Text.Lazy as LText +-- > import Text.EDE +-- > +-- > main :: IO () +-- > main = do +-- > r <- eitherParseFile "template.ede" +-- > either error print $ r >>= (`eitherRender` env) +-- > where +-- > env = fromPairs +-- > [ "text" .= "Some Text." +-- > , "int" .= 1 +-- > , "list" .= [5..10] +-- > ] +-- +-- Please see the syntax section for more information about available +-- statements and expressions. + +-- $parsing_and_rendering +-- +-- Parsing and rendering require two separate steps intentionally so that the +-- more expensive (and potentially impure) action of parsing and resolving +-- @include@s can be embedded and re-used in a pure fashion. +-- +-- * Parsing tokenises the input and converts it to an internal AST representation, +-- resolving @include@s using a custom function. The result is a compiled template +-- which can be cached for future use. +-- +-- * Rendering takes a 'HashMap' of custom 'Fun's (functions available in the +-- template context), an 'Object' as the binding environment, and a parsed +-- 'Template' to subsitute the values into. +-- The result is a Lazy 'LText.Text' value containing the rendered output. + +-- $resolvers +-- +-- The 'Resolver' used to resolve @include@ expressions determines the purity +-- of 'Template' parsing. +-- +-- For example, using the 'includeFile' 'Resolver' means parsing is restricted +-- to 'IO', while pre-caching a 'HashMap' of 'Template's and supplying them to +-- 'parseWith' using 'includeMap' offers a pure variant for @include@ resolution. + +-- $results +-- +-- The 'Result' of a 'parse' or 'render' steps can be inspected or analysed using +-- 'result' as follows: +-- +-- >>> result failure success $ render tmpl env +-- +-- If you're only interested in dealing with errors as strings, and the positional +-- information contained in 'Meta' is not of use you can use the convenience functions +-- 'eitherParse', 'eitherRender', or convert a 'Result' to 'Either' using 'eitherResult'. +-- +-- >>> either failure success $ eitherParse tmpl + +-- $input +-- +-- 'fromPairs' (or 'fromValue') is a wrapper around Aeson's 'object' function which +-- safely strips the outer 'Value' constructor, providing the correct type +-- signature for input into 'render'. +-- +-- It is used in combination with the re-exported '.=' as follows: +-- +-- >>> render (fromPairs [ "foo" .= "value", "bar" .= 1 ]) :: Template -> Result Text + +-- #syntax# +-- +-- $pragmas +-- +-- Syntax can be modified either via the arguments to 'parseWith' or alternatively +-- by specifying the delimiters via an @EDE_SYNTAX@ pragma. +-- +-- /Note:/ The pragmas must start on line1. Subsequently encountered +-- pragmas are parsed as textual template contents. +-- +-- For example: +-- +-- > {! EDE_SYNTAX pragma=("{*", "*}") inline=("#@", "@#") comment=("<#", "#>") block=("$$", "$$") !} +-- > {* EDE_SYNTAX block=("#[", "]#") *} +-- > ... +-- +-- Would result in the following syntax: +-- +-- * Pragmas: @{* ... *}@ +-- +-- * Inline: @\#\@ ... \@\#@ +-- +-- * Comment: @\<\# ... \#>@ +-- +-- * Block: @\#[ ... ]\#@ +-- +-- /Note:/ @EDE_SYNTAX@ pragmas only take effect for the current template, not +-- child includes. If you want to override the syntax for all templates use 'parseWith' +-- and custom 'Syntax' settings. + +-- $expressions +-- +-- Expressions behave as any simplistic programming language with a variety of +-- prefix, infix, and postifx operators available. (/See:/ "Text.EDE.Filters") +-- +-- A rough overview of the expression grammar: +-- +-- > expression ::= literal | identifier | '|' filter +-- > filter ::= identifier +-- > identifier ::= [a-zA-Z_]{1}[0-9A-Za-z_']* +-- > object ::= '{' pairs '}' +-- > pairs ::= string ':' literal | string ':' literal ',' pairs +-- > array ::= '[' elements ']' +-- > elements ::= literal | literal ',' elements +-- > literal ::= object | array | boolean | number | string +-- > boolean ::= true | false +-- > number ::= integer | double +-- > string ::= "char+|escape" + +-- +-- /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 + +-- $variables +-- +-- Variables are substituted directly for their renderable representation. +-- An error is raised if the varaible being substituted is not a literal type +-- (ie. an 'Array' or 'Object') or doesn't exist in the supplied environment. +-- +-- > {{ var }} +-- +-- Nested variable access is also supported for variables which resolve to an 'Object'. +-- Dot delimiters are used to chain access through multiple nested 'Object's. +-- The right-most accessor must resolve to a renderable type as with the previous +-- non-nested variable access. +-- +-- > {{ nested.var.access }} + +-- $conditionals +-- +-- A conditional is introduced and completed with the section syntax: +-- +-- > {% if %} +-- > ... consequent expressions +-- > {% elif %} +-- > ... consequent expressions +-- > {% elif %} +-- > ... consequent expressions +-- > {% else %} +-- > ... alternate expressions +-- > {% endif %} +-- +-- The boolean result of the @expr@ determines the branch that is rendered by +-- the template with multiple (or none) elif branches supported, and the +-- else branch being optional. +-- +-- In the case of a literal it conforms directly to the supported boolean or relation logical +-- operators from Haskell. +-- If a variable is singuarly used its existence determines the result of the predicate, +-- the exception to this rule is boolean values which will be substituted into the +-- expression if they exist in the supplied environment. +-- +-- The following logical expressions are supported as predicates in conditional statements +-- with parameters type checked and an error raised if the left and right +-- hand sides are not type equivalent. +-- +-- * @And@: '&&' +-- +-- * @Or@: '||' +-- +-- * @Equal@: '==' +-- +-- * @Not Equal@: @!=@ (/See:/ '/=') +-- +-- * @Greater@: '>' +-- +-- * @Greater Or Equal@: '>=' +-- +-- * @Less@: '<' +-- +-- * @Less Or Equal@: '<=' +-- +-- * @Negation@: @!@ (/See:/ 'not') +-- +-- /See:/ "Text.EDE.Filters" + +-- $case +-- +-- To pattern match a literal or variable, you can use the @case@ statement: +-- +-- > {% case var %} +-- > {% when "a" %} +-- > .. matched expressions +-- > {% when "b" %} +-- > .. matched expressions +-- > {% else %} +-- > .. alternate expressions +-- > {% endcase %} +-- +-- Patterns take the form of @variables@, @literals@, or the wild-card +-- '@_@' pattern (which matches anything). + +-- $loops +-- +-- Iterating over an 'Array' or 'Object' can be acheived using the 'for ... in' section syntax. +-- Attempting to iterate over any other type will raise an error. +-- +-- Example: +-- +-- > {% for var in list %} +-- > ... iteration expression +-- > {% else %} +-- > ... alternate expression +-- > {% endfor %} +-- +-- The iteration branch is rendering per item with the else branch being (which is optional) +-- being rendered if the @{{ list }}@ variable is empty. +-- +-- When iterating over an 'Object', a stable sort using key equivalence is applied, 'Array's +-- are unmodified. +-- +-- The resulting binding within the iteration expression (in this case, @{{ var }}@) is +-- an 'Object' containing the following keys: +-- +-- * @key :: Text@: They key if the loop target is an 'Object' +-- +-- * @value :: a@: The value of the loop target +-- +-- * @loop :: Object@: Loop metadata. +-- +-- * @length :: Int@: Length of the loop +-- +-- * @index :: Int@: Index of the iteration +-- +-- * @index0 :: Int@: Zero based index of the iteration +-- +-- * @remainder :: Int@: Remaining number of iterations +-- +-- * @remainder0 :: Int@: Zero based remaining number of iterations +-- +-- * @first :: Bool@: Is this the first iteration? +-- +-- * @last :: Bool@: Is this the last iteration? +-- +-- * @odd :: Bool@: Is this an odd iteration? +-- +-- * @even :: Bool@: Is this an even iteration? +-- +-- For example: +-- +-- > {% for item in items %} +-- > {{ item.index }}:{{ item.value }} +-- > {% if !item.last %} +-- > +-- > {% endif %} +-- > {% endfor %} +-- +-- Will render each item with its (1-based) loop index as a prefix, separated +-- by a blank newline, without a trailing at the end of the document. +-- +-- Valid loop targets are 'Object's, 'Array's, and 'String's, with only 'Object's +-- having an available @{{ .key }}@ in scope. + +-- $includes +-- +-- Includes are a way to reduce the amount of noise in large templates. +-- They can be used to abstract out common snippets and idioms into partials. +-- +-- If 'parseFile' or the 'includeFile' resolver is used, templates will be loaded +-- using 'FilePath's. (This is the default.) +-- +-- For example: +-- +-- > {% include "/var/tmp/partial.ede" %} +-- +-- Loads @partial.ede@ from the file system. +-- +-- The current environment is made directly available to the included template. +-- Additional bindings can be created (/See:/ @let@) which will be additionally +-- available only within the include under a specific identifier: +-- +-- > {% include "/var/tmp/partial.ede" with some_number = 123 %} +-- +-- Includes can also be resolved using pure 'Resolver's such as 'includeMap', +-- which will treat the @include@ expression's identifier as a 'HashMap' key: +-- +-- > {% include "arbitrary_key" %} +-- +-- Uses 'Map.lookup' to find @arbitrary_key@ in the 'HashMap' supplied to 'includeMap'. + +-- $filters +-- +-- Filters are typed functions which can be applied to variables and literals. +-- An example of rendering a lower cased boolean would be: +-- +-- > {{ true | show | lower }} +-- +-- The input is on the LHS and chained filters (delimited by the pipe operator @|@) +-- are on the RHS, with filters being applied postfix, left associatively. +-- +-- /See:/ "Text.EDE.Filters" + +-- $raw +-- +-- You can disable template processing for blocks of text using the @raw@ section: +-- +-- > {% raw %} +-- > Some {{{ handlebars }}} or {{ mustache }} or {{ jinja2 }} output tags etc. +-- > {% endraw %} +-- +-- This can be used to avoid parsing expressions which would otherwise be +-- considered valid @ED-E@ syntax. + +-- $comments +-- +-- Comments are ignored by the parser and omitted from the rendered output. +-- +-- > {# singleline comment #} +-- +-- > {# +-- > multiline +-- > comment +-- > #} +-- + +-- $let +-- +-- You can also bind an identifier to values which will be available within +-- the following expression scope. +-- +-- For example: +-- +-- > {% let var = false %} +-- > ... +-- > {{ var }} +-- > ... diff --git a/src/Text/EDE/Filters.hs b/src/Text/EDE/Filters.hs new file mode 100644 --- /dev/null +++ b/src/Text/EDE/Filters.hs @@ -0,0 +1,258 @@ +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + +-- Module : Text.EDE.Filters +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +-- | A default set of prelude-like filters and the means to construct your own. +-- +-- Please be aware that some of the 'defaultFilters' are assumed to be present +-- (for example during loop unrolling and assignment of else branches via 'empty'). +-- +-- It's recommended you supplement the default filters rather than replacing them +-- completely. (But hey, it's your call!) +module Text.EDE.Filters + ( + -- * Prelude + defaultFilters + + -- ** Boolean + -- $boolean + + -- ** Equality + -- $equality + + -- ** Relational + -- $relational + + -- ** Numeric + -- $numeric + + -- ** Fractional + -- $fractional + + -- ** Textual + -- $textual + + -- ** Collection + -- $collection + + -- ** Polymorphic + -- $polymorphic + + -- * Constructing filters + , Binding (..) + + -- ** Classes + , Quote (..) + , Unquote (..) + + -- ** Restricted quoters + , qapply + , qpoly2 + , qnum1 + , qnum2 + , qcol1 + + -- ** Errors + , unexpected + , typeOf + ) where + +import Data.Aeson (Value, encode) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +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.Vector as Vector +import Text.EDE.Internal.HOAS + +default (Integer) + +defaultFilters :: HashMap Text Binding +defaultFilters = Map.unions + [ boolean + , equality + , relational + , numeric + , fractional + , textual + , collection + , polymorphic + ] + +-- $boolean +-- +-- * @!@ @:: Bool -> Bool@ (/See:/ 'not') +-- +-- * '&&' @:: Bool -> Bool -> Bool@ +-- +-- * '||' @:: Bool -> Bool -> Bool@ + +boolean :: HashMap Text Binding +boolean = Map.fromList + [ "!" @: quote not + , "&&" @: quote (&&) + , "||" @: quote (||) + ] + +-- $equality +-- +-- * '==' @:: a -> a -> Bool@ +-- +-- * @!=@ @:: a -> a -> Bool@ (/See/: '/=') + +equality :: HashMap Text Binding +equality = Map.fromList + [ "==" @: qpoly2 (==) + , "!=" @: qpoly2 (/=) + ] + +-- $relational +-- +-- * '>' @:: a -> a -> Bool@ +-- +-- * '>=' @:: a -> a -> Bool@ +-- +-- * '<=' @:: a -> a -> Bool@ +-- +-- * '<=' @:: a -> a -> Bool@ + +relational :: HashMap Text Binding +relational = Map.fromList + [ ">" @: qnum2 (>) + , ">=" @: qnum2 (>=) + , "<=" @: qnum2 (<=) + , "<" @: qnum2 (<) + ] + +-- $numeric +-- +-- * '+' @:: Number -> Number -> Number@ +-- +-- * '-' @:: Number -> Number -> Number@ +-- +-- * '*' @:: Number -> Number -> Number@ +-- +-- * 'abs' @:: Number -> Number@ +-- +-- * 'signum' @:: Number -> Number@ +-- +-- * 'negate' @:: Number -> Number@ + +numeric :: HashMap Text Binding +numeric = Map.fromList + [ "+" @: qnum2 (+) + , "-" @: qnum2 (-) + , "*" @: qnum2 (*) + , "abs" @: qnum1 abs + , "signum" @: qnum1 signum + , "negate" @: qnum1 negate + ] + +-- $fractional +-- +-- * 'truncate' @:: Number -> Number@ +-- +-- * 'round' @:: Number -> Number@ +-- +-- * 'ceiling' @:: Number -> Number@ +-- +-- * 'floor' @:: Number -> Number@ + +fractional :: HashMap Text Binding +fractional = Map.fromList + [ "truncate" @: qnum1 (fromIntegral . truncate) + , "round" @: qnum1 (fromIntegral . round) + , "ceiling" @: qnum1 (fromIntegral . ceiling) + , "floor" @: qnum1 (fromIntegral . floor) + ] + +-- $textual +-- +-- * @takeWord@ @:: Text -> Text@ +-- +-- * @dropWord@ @:: Text -> Text@ +-- +-- * @lowerHead@ @:: Text -> Text@ +-- +-- * @upperHead@ @:: Text -> Text@ +-- +-- * @toTitle@ @:: Text -> Text@ +-- +-- * @toCamel@ @:: Text -> Text@ +-- +-- * @toPascal@ @:: Text -> Text@ +-- +-- * @toSnake@ @:: Text -> Text@ +-- +-- * @toSpinal@ @:: Text -> Text@ +-- +-- * @toTrain@ @:: Text -> Text@ +-- +-- * @toLower@ @:: Text -> Text@ +-- +-- * @toUpper@ @:: Text -> Text@ +-- +-- * @toOrdinal@ @:: Number -> Text@ +-- +-- /See:/ + +textual :: HashMap Text Binding +textual = Map.fromList + [ "takeWord" @: quote takeWord + , "dropWord" @: quote dropWord + , "lowerHead" @: quote lowerHead + , "upperHead" @: quote upperHead + , "toTitle" @: quote toTitle + , "toCamel" @: quote toCamel + , "toPascal" @: quote toPascal + , "toSnake" @: quote toSnake + , "toSpinal" @: quote toSpinal + , "toTrain" @: quote toTrain + , "toUpper" @: quote Text.toUpper + , "toLower" @: quote Text.toLower + , "toOrdinal" @: (toOrdinal . truncate :: Scientific -> Text) + ] + +-- $collection +-- +-- * @length@ @:: Collection -> Number@ (/See/: 'Data.Text.length', 'Data.Vector.length', 'Data.HashMap.Strict.size') +-- +-- * @empty@ @:: Collection -> Bool@ (/See/: 'Data.Text.null', 'Data.Vector.null', 'Data.HashMap.Strict.null') + +collection :: HashMap Text Binding +collection = Map.fromList + [ "length" @: qcol1 Text.length Map.size Vector.length + , "empty" @: qcol1 Text.null Map.null Vector.null + -- , ("join", quote + ] + +-- $polymorphic +-- +-- * 'show' @:: a -> Text@ + +polymorphic :: HashMap Text Binding +polymorphic = Map.fromList + [ "show" @: quote value + ] + +(@:) :: Quote a => Text -> a -> (Text, Binding) +k @: q = (k, quote q) + +value :: Value -> LText.Text +value = LText.decodeUtf8 . encode diff --git a/src/Text/EDE/Internal/Eval.hs b/src/Text/EDE/Internal/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Text/EDE/Internal/Eval.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- Module : Text.EDE.Internal.Eval +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Text.EDE.Internal.Eval where + +import Control.Applicative +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 qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid +import Data.Scientific (base10Exponent) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Buildable as Build +import Data.Text.Format (Format) +import Data.Text.Format.Params (Params) +import Data.Text.Lazy.Builder (Builder) +import Data.Text.Lazy.Builder.Scientific +import Text.EDE.Internal.HOAS +import Text.EDE.Internal.Types +import Text.Trifecta.Delta + +-- FIXME: add pretty printer formatted error messages + +data Env = Env + { _templates :: HashMap Text Exp + , _quoted :: HashMap Text Binding + , _values :: HashMap Text Value + } + +type Context = ReaderT Env Result + +render :: HashMap Text Exp + -> HashMap Text Binding + -> Exp + -> HashMap Text Value + -> Result Builder +render ts fs e o = runReaderT (eval e >>= nf) (Env ts fs o) + where + nf (BVal v) = build (delta e) v + nf _ = lift $ Failure + "unable to evaluate partially applied template to normal form." + +eval :: Exp -> Context Binding +eval (ELit _ l) = return (quote l) +eval (EVar _ v) = quote <$> variable v +eval (EFun d i) = do + q <- Map.lookup i <$> asks _quoted + maybe (throwError' d "binding {} doesn't exist." [i]) + return + q + +eval (EApp d a b) = do + x <- eval a + y <- eval b + binding d x y + +eval (ELet _ k rhs bdy) = do + q <- eval rhs + v <- lift (unquote q) + bind (Map.insert k v) (eval bdy) + +-- FIXME: We have to recompute c everytime due to the predicate .. +eval (ECase d p ws) = go ws + where + go [] = return (quote (String mempty)) + go ((a, e):as) = + case a of + PWild -> eval e + PVar v -> eval (EVar d v) >>= cond e as + PLit l -> eval (ELit d l) >>= cond e as + + cond e as y@(BVal Bool{}) = do + x <- predicate p + if x == y then eval e else go as + cond e as y@BVal{} = do + x <- eval p + if x == y then eval e else go as + cond _ as _ = go as + +eval (ELoop _ i v bdy) = eval v >>= lift . unquote >>= loop + where + d = delta bdy + + loop :: Collection -> Context Binding + loop (Col l xs) = snd <$> foldlM iter (1, quote (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 = do + m <- asks _values + maybe (return ()) + (\x -> throwError' d "binding {} shadows variable {} :: {}, {}" + [Text.unpack i, show x, typeOf x, show n]) + (Map.lookup i m) + + 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 = [] + +eval (EIncl d i) = do + ts <- asks _templates + case Map.lookup i ts of + Just e -> eval e + Nothing -> throwError' d "template {} is not in scope: [{}]" + [i, Text.intercalate "," $ Map.keys ts] + +bind :: (Object -> Object) -> Context a -> Context a +bind f = withReaderT (\x -> x { _values = f (_values x) }) + +variable :: Var -> Context Value +variable (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' undefined "binding {} doesn't exist." [fmt (k:r)]) + (go ks (k:r)) + (Map.lookup k m) + where + nest :: Value -> Context Object + nest (Object o) = return o + nest x = + throwError' undefined "variable {} :: {} doesn't supported nested accessors." + [fmt (k:r), typeOf x] + + fmt = Text.unpack . Text.intercalate "." + +-- | A variable can be tested for truthiness, but a non-whnf expr cannot. +predicate :: Exp -> Context Binding +predicate x = do + r <- runReaderT (eval x) <$> ask + lift $ case r of + Success q + | BVal Bool{} <- q -> Success q + Success q + | BVal Null <- q -> Success (quote False) + Success _ -> Success (quote True) + Failure _ + | EVar{} <- x -> Success (quote False) + Failure e -> Failure e + +binding :: Delta -> Binding -> Binding -> Context Binding +binding d x y = + case (x, y) of + (BVal l, BVal r) -> quote <$> liftM2 (<>) (build d l) (build d r) + _ -> lift (qapply x y) + +build :: Delta -> Value -> Context Builder +build _ Null = return mempty +build _ (String t) = return (Build.build t) +build _ (Bool True) = return "true" +build _ (Bool False) = return "false" +build _ (Number n) + | base10Exponent n == 0 = return (formatScientificBuilder Fixed (Just 0) n) + | otherwise = return (scientificBuilder n) +build d x = + throwError' d "unable to render literal {}\n{}" [typeOf x, show x] + +-- FIXME: Add delta information to the thrown error document. +throwError' :: Params ps => Delta -> Format -> ps -> Context a +throwError' _ f = lift . throwError f diff --git a/src/Text/EDE/Internal/HOAS.hs b/src/Text/EDE/Internal/HOAS.hs new file mode 100644 --- /dev/null +++ b/src/Text/EDE/Internal/HOAS.hs @@ -0,0 +1,191 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} + +-- Module : Text.EDE.Internal.HOAS +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Text.EDE.Internal.HOAS where + +import Control.Applicative +import Control.Monad +import Data.Aeson hiding (Result(..)) +import Data.Bifunctor +import qualified Data.HashMap.Strict as Map +import Data.List (sortBy) +import Data.Ord (comparing) +import Data.Scientific +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LText +import Data.Text.Lazy.Builder +import qualified Data.Vector as Vector +import Text.EDE.Internal.Types + +-- | A HOAS representation of (possibly partially applied) values +-- in the environment. +data Binding + = BVal !Value + | BLam (Binding -> Result Binding) + +instance Show Binding where + show (BVal v) = show v + show _ = "" + +instance Eq Binding where + BVal a == BVal b = a == b + _ == _ = False + +-- | Retrieve a consistent type from a 'Value' to use in error messages. +typeOf :: Value -> String +typeOf = \case + Null -> "Null" + Bool _ -> "Bool" + Number _ -> "Number" + Object _ -> "Object" + Array _ -> "Array" + String _ -> "String" + +-- | The default type for partially applied 'Binding's in error messages. +typeFun :: String +typeFun = "Function" + +-- | Attempt to apply two 'Binding's. +qapply :: Binding -> Binding -> Result Binding +qapply a b = case (a, b) of + (BLam f, x) -> f x + (BVal x, _) -> throwError "unable to apply literal {} -> {}\n{}" + [typeOf x, typeFun, show x] + +-- | Quote a binary function which takes the most general binding value. +qpoly2 :: Quote a => (Value -> Value -> a) -> Binding +qpoly2 = quote + +-- | Quote an unary numeric function. +qnum1 :: (Scientific -> Scientific) -> Binding +qnum1 = quote + +-- | Quote a binary numeric function. +qnum2 :: Quote a => (Scientific -> Scientific -> a) -> Binding +qnum2 = quote + +-- | Quote a comprehensive set of unary functions to create a binding +-- that supports all collection types. +qcol1 :: Quote a => (Text -> a) -> (Object -> a) -> (Array -> a) -> Binding +qcol1 f g h = BLam $ \case + BVal (String t) -> pure . quote $ f t + BVal (Object o) -> pure . quote $ g o + BVal (Array v) -> pure . quote $ h v + BVal y -> err (typeOf y) + _ -> err typeFun + where + err = throwError "expected a String, Object, or Array, but got {}" . (:[]) + +class Quote a where + quote :: a -> Binding + +instance Quote Binding where + quote = id + +instance Quote Value where + quote = BVal + +instance Quote Text where + quote = BVal . String + +instance Quote LText.Text where + quote = quote . LText.toStrict + +instance Quote Builder where + quote = quote . toLazyText + +instance Quote Bool where + quote = BVal . Bool + +instance Quote Int where + quote = BVal . Number . fromIntegral + +instance Quote Integer where + quote = BVal . Number . fromInteger + +instance Quote Double where + quote = BVal . Number . fromFloatDigits + +instance Quote Scientific where + quote = BVal . Number + +instance Quote Object where + quote = BVal . Object + +instance Quote Array where + quote = BVal . Array + +class Unquote a where + unquote :: Binding -> Result a + +instance Unquote Value where + unquote = \case + BVal v -> pure v + _ -> unexpected typeFun "Literal" + +instance Unquote Text where + unquote = unquote >=> \case + String t -> pure t + v -> unexpected (typeOf v) "String" + +instance Unquote LText.Text where + unquote = fmap LText.fromStrict . unquote + +instance Unquote Bool where + unquote = unquote >=> \case + Bool b -> pure b + v -> unexpected (typeOf v) "Bool" + +instance Unquote Scientific where + unquote = \case + BVal (Number n) -> pure n + BVal v -> unexpected (typeOf v) "Number" + _ -> unexpected typeFun "Number" + +instance Unquote Collection where + unquote q = text <$> unquote q + <|> hashMap <$> unquote q + <|> vector <$> unquote 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 + + vector v = Col (Vector.length v) (Vector.map (Nothing,) v) + +instance Unquote Object where + unquote = \case + BVal (Object o) -> pure o + BVal v -> unexpected (typeOf v) "Object" + _ -> unexpected typeFun "Object" + +instance Unquote Array where + unquote = \case + BVal (Array a) -> pure a + BVal v -> unexpected (typeOf v) "Array" + _ -> unexpected typeFun "Array" + +instance (Unquote a, Quote b) => Quote (a -> b) where + quote f = BLam (fmap (quote . f) . unquote) + +unexpected :: String -> String -> Result b +unexpected x y = throwError "unable to coerce {} -> {}" [x, y] diff --git a/src/Text/EDE/Internal/Parser.hs b/src/Text/EDE/Internal/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Text/EDE/Internal/Parser.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Text.EDE.Internal.Parser +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Text.EDE.Internal.Parser where + +import Control.Applicative +import Control.Lens hiding (both, noneOf) +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.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.Syntax +import Text.EDE.Internal.Types +import Text.Parser.Expression +import Text.Parser.LookAhead +import Text.Parser.Token.Style (buildSomeSpaceParser) +import qualified Text.Trifecta as Tri +import Text.Trifecta hiding (Parser, Result(..), spaces) +import Text.Trifecta.Delta + +data Env = Env + { _settings :: !Syntax + , _includes :: HashMap Text (NonEmpty Delta) + } + +makeLenses ''Env + +instance HasSyntax Env where + syntax = settings + +type Parser m = + ( Monad m + , 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 + ) + +instance TokenParsing EDE where + nesting (EDE m) = EDE (nesting m) + {-# INLINE nesting #-} + + someSpace = skipMany (satisfy $ \c -> c /= '\n' && isSpace c) + {-# INLINE someSpace #-} + + semi = EDE semi + {-# INLINE semi #-} + + highlight h (EDE m) = EDE (highlight h m) + {-# INLINE highlight #-} + +instance Errable (StateT Env EDE) where + raiseErr = lift . raiseErr + +runParser :: Syntax + -> Text + -> ByteString + -> Result (Exp, HashMap Text (NonEmpty Delta)) +runParser o n = res . parseByteString (runEDE run) pos + where + run = runStateT (pragma *> document <* eof) (Env o mempty) + pos = Directed (Text.encodeUtf8 n) 0 0 0 0 + + res (Tri.Success x) = Success (_includes `second` x) + res (Tri.Failure e) = Failure e + +pragma :: Parser m => m () +pragma = void . many $ do + !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 + +document :: Parser m => m Exp +document = eapp <$> position <*> many (statement <|> inline <|> fragment) + +inline :: Parser m => m Exp +inline = between inlinel inliner term + +fragment :: Parser m => m Exp +fragment = ELit <$> position <*> pack (notFollowedBy end0 >> try line0 <|> line1) + where + line0 = manyTill1 (noneOf "\n") (try (lookAhead end0) <|> eof) + line1 = manyEndBy1 anyChar newline + + end0 = void (inlinel <|> blockl <|> try end1) + end1 = multiLine (pure ()) (manyTill1 anyChar (lookAhead blockr)) + +statement :: Parser m => m Exp +statement = choice + [ ifelif + , cases + , loop + , include + , binding + , raw + , comment + ] + +block :: Parser m => String -> m a -> m a +block k p = try (multiLine (keyword k) p) <|> singleLine (keyword k) p + +multiLine :: Parser m => m b -> m a -> m a +multiLine s = between (try (triml blockl *> s)) (trimr blockr) + +singleLine :: Parser m => m b -> m a -> m a +singleLine s = between (try (blockl *> s)) blockr + +ifelif :: Parser m => m Exp +ifelif = eif + <$> branch "if" + <*> many (branch "elif") + <*> else' + <* exit "endif" + where + branch k = (,) <$> block k term <*> document + +cases :: Parser m => m Exp +cases = ecase + <$> block "case" term + <*> many + ((,) <$> block "when" pattern + <*> document) + <*> else' + <* exit "endcase" + +loop :: Parser m => m Exp +loop = do + d <- position + (i, v) <- block "for" + ((,) <$> identifier + <*> (keyword "in" *> collection)) + eempty d v + <$> (ELoop d i v <$> document) + <*> else' + <* exit "endfor" + +include :: Parser m => m Exp +include = do + d <- position + block "include" (incl d) + where + incl d = do + k <- stringLiteral + includes %= Map.insertWith (<>) k (d:|[]) + elet d (EIncl d k) <$> scope + + scope = optional $ + (,) <$> (keyword "with" *> identifier) + <*> (symbol "=" *> term) + +binding :: Parser m => m Exp +binding = do + d <- position + uncurry (ELet d) + <$> block "let" + ((,) <$> identifier + <*> (symbol "=" *> term)) + <*> document + <* exit "endlet" + +raw :: Parser m => m Exp +raw = ELit + <$> position + <*> (start *> pack (manyTill anyChar (lookAhead end)) <* end) + where + start = block "raw" (pure ()) + 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 +-- as part of the whitespace. +comment :: Parser m => m Exp +comment = ELit + <$> position + <*> pure (String mempty) + <* (try (triml (trimr go)) <|> go) + where + go = (commentStyle <$> commentl <*> commentr) >>= + buildSomeSpaceParser (fail "whitespace significant") + +else' :: Parser m => m (Maybe Exp) +else' = optional (block "else" (pure ()) *> document) + +exit :: Parser m => String -> m () +exit k = block k (pure ()) + +term :: Parser m => m Exp +term = buildExpressionParser table expr + where + table = + [ [prefix "!"] + , [infix' "*", infix' "/"] + , [infix' "-", infix' "+"] + , [infix' "==", infix' "!=", infix' ">", infix' ">=", infix' "<", infix' "<="] + , [infix' "&&"] + , [infix' "||"] + , [filter' "|"] + ] + + prefix n = Prefix (efun <$> operator n <*> pure n) + + infix' n = Infix (do + d <- operator n + return $ \l r -> + EApp d (efun d n l) r) AssocLeft + + filter' n = Infix (do + d <- operator n + i <- try (lookAhead identifier) + return $ \l _ -> + efun d i l) AssocLeft + + expr = parens term <|> apply EVar variable <|> apply ELit literal + +pattern :: Parser m => m Pat +pattern = PWild <$ char '_' <|> PVar <$> variable <|> PLit <$> literal + +collection :: Parser m => m Exp +collection = EVar <$> position <*> variable <|> ELit <$> position <*> col + where + col = Object <$> object + <|> Array <$> array + <|> String <$> stringLiteral + +literal :: Parser m => m Value +literal = Bool <$> bool + <|> Number <$> number + <|> String <$> stringLiteral + <|> Object <$> object + <|> Array <$> array + +number :: Parser m => m Scientific +number = either fromIntegral fromFloatDigits <$> integerOrDouble + +bool :: Parser m => m Bool +bool = symbol "true" *> return True <|> symbol "false" *> return False + +object :: Parser m => m Object +object = Map.fromList <$> braces (commaSep pair) + where + pair = (,) + <$> (stringLiteral <* spaces) + <*> (char ':' *> spaces *> literal) + +array :: Parser m => m Array +array = Vector.fromList <$> brackets (commaSep literal) + +operator :: Parser m => Text -> m Delta +operator n = position <* reserveText operatorStyle n + +keyword :: Parser m => String -> m Delta +keyword k = position <* try (reserve keywordStyle k) + +variable :: Parser m => m Var +variable = Var <$> (NonEmpty.fromList <$> sepBy1 identifier (char '.')) + +identifier :: Parser m => m Id +identifier = ident variableStyle + +spaces :: Parser m => m () +spaces = skipMany (oneOf "\t ") + +apply :: Parser m => (Delta -> a -> b) -> m a -> m b +apply f p = f <$> position <*> p + +manyTill1 :: Alternative m => m a -> m b -> m [a] +manyTill1 p end = (:) <$> p <*> manyTill p end + +manyEndBy1 :: Alternative m => m a -> m a -> m [a] +manyEndBy1 p end = go + where + go = (:[]) <$> end <|> (:) <$> p <*> go + +pack :: Functor f => f String -> f Value +pack = fmap (String . Text.pack) + +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" + +trimr :: Parser m => m a -> m a +trimr p = p <* spaces <* newline + +pragmak :: Parser m => String -> m () +pragmak = reserve pragmaStyle + +pragmal, pragmar :: Parser m => m String +pragmal = left delimPragma >>= symbol +pragmar = right delimPragma >>= string + +commentl, commentr :: MonadState Env m => m String +commentl = left delimComment +commentr = right delimComment + +inlinel, inliner :: Parser m => m String +inlinel = left delimInline >>= symbol +inliner = right delimInline >>= string + +blockl, blockr :: Parser m => m String +blockl = left delimBlock >>= symbol +blockr = right delimBlock >>= string + +left, right :: MonadState s m => Getter s Delim -> m String +left d = gets (fst . view d) +right d = gets (snd . view d) diff --git a/src/Text/EDE/Internal/Syntax.hs b/src/Text/EDE/Internal/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Text/EDE/Internal/Syntax.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- Module : Text.EDE.Internal.Syntax +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +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 + +-- | The default ED-E syntax. +-- +-- Delimiters: +-- +-- * Pragma: @{! ... !}@ +-- +-- * Inline: @{{ ... }}@ +-- +-- * Comments: @{# ... #}@ +-- +-- * Blocks: @{% ... %}@ +-- +defaultSyntax :: Syntax +defaultSyntax = Syntax + { _delimPragma = ("{!", "!}") + , _delimInline = ("{{", "}}") + , _delimComment = ("{#", "#}") + , _delimBlock = ("{%", "%}") + } + +-- | An alternate syntax (based on Play/Scala templates) designed to +-- be used when the default is potentially ambiguous due to another encountered +-- smarty based syntax. +-- +-- Delimiters: +-- +-- * Inline: @\<\@ ... \@>@ +-- +-- * Comments: @\@* ... *\@@ +-- +-- * Blocks: @\@( ... )\@@ +-- +alternateSyntax :: Syntax +alternateSyntax = Syntax + { _delimPragma = ("@!", "!@") + , _delimInline = ("<@", "@>") + , _delimComment = ("@*", "*@") + , _delimBlock = ("@(", ")@") + } + +commentStyle :: String -> String -> CommentStyle +commentStyle s e = emptyCommentStyle & commentStart .~ s & commentEnd .~ e + +operatorStyle :: TokenParsing m => IdentifierStyle m +operatorStyle = haskellOps & styleLetter .~ oneOf "-+!&|=><" + +variableStyle :: TokenParsing m => IdentifierStyle m +variableStyle = keywordStyle & styleName .~ "variable" + +keywordStyle :: TokenParsing m => IdentifierStyle m +keywordStyle = haskellIdents + & styleReserved .~ keywordSet + & styleName .~ "keyword" + +keywordSet :: HashSet String +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 + & styleReserved .~ pragmaSet + & styleName .~ "pragma field" + +pragmaSet :: HashSet String +pragmaSet = Set.fromList + [ "pragma" + , "inline" + , "comment" + , "block" + ] diff --git a/src/Text/EDE/Internal/Types.hs b/src/Text/EDE/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Text/EDE/Internal/Types.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- Module : Text.EDE.Internal.Types +-- Copyright : (c) 2013-2014 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +module Text.EDE.Internal.Types where + +import Control.Applicative +import Control.Lens +import Data.Aeson.Types hiding (Result(..)) +import Data.Foldable +import Data.HashMap.Strict (HashMap) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Monoid hiding ((<>)) +import Data.Maybe +import Data.Semigroup +import Data.Text (Text) +import Data.Text.Format (Format, format) +import Data.Text.Format.Params (Params) +import qualified Data.Text.Lazy as LText +import Text.PrettyPrint.ANSI.Leijen (Pretty(..), Doc, vsep) +import Text.Trifecta.Delta + +-- | The result of running parsing or rendering steps. +data Result a + = Success a + | Failure Doc + 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 (>>=) #-} + +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 (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 (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 + +-- | Convert a 'Result' to an 'Either' with the 'Left' case holding a +-- formatted error message, and 'Right' being the successful result over +-- which 'Result' is paramterised. +eitherResult :: Result a -> Either String a +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 _ g (Success x) = g x +result f _ (Failure e) = f e + +-- | Convenience for returning a successful 'Result'. +success :: Monad m => a -> m (Result a) +success = return . Success + +-- | Convenience for returning an error 'Result'. +failure :: Monad m => Doc -> m (Result a) +failure = return . Failure + +throwError :: Params ps => Format -> ps -> Result a +throwError fmt = Failure . pretty . LText.unpack . format fmt + +type Delim = (String, String) + +data Syntax = Syntax + { _delimPragma :: !Delim + , _delimInline :: !Delim + , _delimComment :: !Delim + , _delimBlock :: !Delim + } + +makeClassy ''Syntax + +-- | A function to resolve the target of an @include@ expression. +type Resolver m = Syntax -> Text -> Delta -> m (Result Template) + +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 + , _tmplIncl :: HashMap Text Exp + } deriving (Eq) + +type Id = Text + +newtype Var = Var (NonEmpty Id) + deriving (Eq, Show) + +data Collection where + Col :: Foldable f => Int -> f (Maybe Text, Value) -> Collection + +data Pat + = PWild + | PVar !Var + | PLit !Value + deriving (Eq, Show) + +type Alt = (Pat, Exp) + +data Exp + = ELit !Delta !Value + | EVar !Delta !Var + | EFun !Delta !Id + | EApp !Delta !Exp !Exp + | ELet !Delta !Id !Exp !Exp + | ECase !Delta !Exp [Alt] + | ELoop !Delta !Id !Exp !Exp + | EIncl !Delta !Text + deriving (Eq, Show) + +instance HasDelta Exp where + delta = \case + ELit d _ -> d + EVar d _ -> d + EFun d _ -> d + EApp d _ _ -> d + ELet d _ _ _ -> d + ECase d _ _ -> d + ELoop d _ _ _ -> d + EIncl d _ -> d + +var :: Id -> Var +var = Var . (:| []) + +eapp :: Delta -> [Exp] -> Exp +eapp d [] = ELit d (String mempty) +eapp _ [e] = e +eapp d (e:es) = foldl' (EApp d) e es + +efun :: Delta -> Id -> Exp -> Exp +efun d = EApp d . EFun d + +elet :: Delta -> Exp -> Maybe (Id, Exp) -> Exp +elet d e = \case + Nothing -> e + Just (i, b) -> ELet d i b e + +ecase :: Exp -> [Alt] -> Maybe Exp -> Exp +ecase p ws f = ECase (delta p) p (ws ++ maybe [] ((:[]) . wild) f) + +eif :: (Exp, Exp) -> [(Exp, Exp)] -> Maybe Exp -> Exp +eif t@(x, _) ts f = foldr' c (fromMaybe (bld (delta x)) f) (t:ts) + where + c (p, w) e = ECase (delta p) p [true w, false e] + +eempty :: Delta -> Exp -> Exp -> Maybe Exp -> Exp +eempty d v e = maybe e (eif (efun d "!" (efun d "empty" v), e) [] . Just) + +wild, true, false :: Exp -> Alt +wild = (PWild,) +true = (PLit (Bool True),) +false = (PLit (Bool False),) + +bld :: Delta -> Exp +bld = (`ELit` String mempty) + +-- | 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 + +-- | Create an 'Object' from a list of name/value 'Pair's. +-- +-- See 'Aeson''s documentation for more details. +fromPairs :: [Pair] -> Object +fromPairs = (\(Object o) -> o) . object diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- Module : Main +-- Copyright : (c) 2013 Brendan Hay +-- 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 +-- you can obtain it at http://mozilla.org/MPL/2.0/. +-- Maintainer : Brendan Hay +-- Stability : experimental +-- Portability : non-portable (GHC extensions) + +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.Text.Lazy.Encoding as LText +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 + +resources :: FilePath +resources = "test/resources/" + +include :: Resolver IO +include = includeFile resources + +tests :: IO [TestTree] +tests = files >>= mapM test + where + files :: IO [FilePath] + files = map (resources ++) . filter (isSuffixOf ".ede") + <$> getDirectoryContents resources + + test :: FilePath -> IO TestTree + test f = do + (bs, n) <- (,) + <$> BS.readFile f + <*> pure (takeWhile (/= '.') f) + + 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)) + + diff r n = ["diff", "-u", r, n] + + split = bimap input (BS.drop 4) . BS.breakSubstring "---" + + input = fromMaybe (error "Failed parsing JSON") + . Aeson.decode' + . LBS.fromStrict