ede 0.2.2 → 0.2.3
raw patch · 12 files changed
+721/−542 lines, 12 filesdep +comonaddep +freedep ~text-manipulate
Dependencies added: comonad, free
Dependency ranges changed: text-manipulate
Files
- ede.cabal +8/−4
- src/Main.hs +2/−2
- src/Text/EDE.hs +12/−12
- src/Text/EDE/Filters.hs +40/−142
- src/Text/EDE/Internal/AST.hs +73/−0
- src/Text/EDE/Internal/Eval.hs +83/−58
- src/Text/EDE/Internal/Filters.hs +200/−0
- src/Text/EDE/Internal/HOAS.hs +0/−191
- src/Text/EDE/Internal/Parser.hs +63/−63
- src/Text/EDE/Internal/Quoting.hs +184/−0
- src/Text/EDE/Internal/Syntax.hs +0/−1
- src/Text/EDE/Internal/Types.hs +56/−69
ede.cabal view
@@ -1,5 +1,5 @@ name: ede-version: 0.2.2+version: 0.2.3 synopsis: Templating language with similar syntax and features to Liquid or Jinja2. homepage: http://github.com/brendanhay/ede license: OtherLicense@@ -56,9 +56,11 @@ , Text.EDE.Filters other-modules:- Text.EDE.Internal.Eval- , Text.EDE.Internal.HOAS+ Text.EDE.Internal.AST+ , Text.EDE.Internal.Eval , Text.EDE.Internal.Parser+ , Text.EDE.Internal.Quoting+ , Text.EDE.Internal.Filters , Text.EDE.Internal.Syntax , Text.EDE.Internal.Types @@ -72,8 +74,10 @@ , base >= 4.6 && < 5 , bifunctors >= 4 , bytestring >= 0.9+ , comonad >= 4.2 , directory >= 1.2 , filepath >= 1.2+ , free >= 4.8 , lens >= 4.0 , mtl >= 2.2 , parsers >= 0.12.1.1@@ -81,7 +85,7 @@ , semigroups >= 0.15 , text >= 1.2 && < 1.3 , text-format >= 0.3- , text-manipulate >= 0.1+ , text-manipulate >= 0.1.2 , trifecta >= 1.5.1 , unordered-containers >= 0.2.3 , vector >= 0.7.1
src/Main.hs view
@@ -46,8 +46,8 @@ ( short 'd' <> long "data" <> metavar "JSON"- <> help ("Bindings to make available in the environment, as JSON. \- \If not given, standard input is read.")+ <> help "Bindings to make available in the environment, as JSON. \+ \If not given, standard input is read." )) <*> switch
src/Text/EDE.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -- Module : Text.EDE@@ -38,9 +37,6 @@ , includeMap , includeFile - -- ** Filters- , defaultFilters- -- ** Rendering , render , renderWith@@ -132,9 +128,9 @@ 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.Quoting (Term) import Text.EDE.Internal.Syntax import Text.EDE.Internal.Types import Text.PrettyPrint.ANSI.Leijen (string)@@ -147,7 +143,11 @@ -- FIXME: add benchmarks -- FIXME: add capture -- FIXME: numerous 'try' calls were added during development, these should now be reduced.+-- FIXME: add pretty printer formatted error messages to the evaluator +-- FIXME: would like to use PHOAS in-place of Term if it can be annotated+-- in a similar fashion such as comonad/cofree.+ -- | ED-E Version. version :: Version version = Paths.version@@ -224,8 +224,8 @@ -- 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'.+ => HashMap Id 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))@@ -256,12 +256,12 @@ render :: Template -- ^ Parsed 'Template' to render. -> Object -- ^ Bindings to make available in the environment. -> Result LText.Text-render = renderWith defaultFilters+render = renderWith mempty -- | 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.+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 fs (Template _ u ts) = fmap toLazyText . Eval.render ts fs u @@ -289,7 +289,7 @@ eitherRender t = eitherResult . render t -- | /See:/ 'renderWith'-eitherRenderWith :: HashMap Text Binding+eitherRenderWith :: HashMap Id Term -> Template -> Object -> Either String LText.Text
src/Text/EDE/Filters.hs view
@@ -1,9 +1,3 @@-{-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--{-# OPTIONS_GHC -fno-warn-type-defaults #-}- -- Module : Text.EDE.Filters -- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com> -- License : This Source Code Form is subject to the terms of@@ -14,17 +8,11 @@ -- 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!)+-- | The means to construct your own filters. module Text.EDE.Filters ( -- * Prelude- defaultFilters+ -- $prelude -- ** Boolean -- $boolean@@ -51,13 +39,14 @@ -- $polymorphic -- * Constructing filters- , Binding (..)+ Term (..) -- ** Classes , Quote (..) , Unquote (..) -- ** Restricted quoters+ , (@:) , qapply , qpoly2 , qnum1@@ -65,35 +54,20 @@ , qcol1 -- ** Errors- , unexpected- , typeOf+ , typeErr+ , argumentErr ) 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)+import Text.EDE.Internal.Quoting+import Text.EDE.Internal.Filters -defaultFilters :: HashMap Text Binding-defaultFilters = Map.unions- [ boolean- , equality- , relational- , numeric- , fractional- , textual- , collection- , polymorphic- ]+-- $prelude+--+-- The default filters available to a template are documented by the subsequent categories.+--+-- These filters cannot be overriden and attempting to supply your own filters to+-- 'Text.EDE.renderWith' will cause the similarly named filters to disappear when+-- they are merged with the prelude during evaluation. (/See:/ 'Data.HashMap.Strict.union') -- $boolean --@@ -103,25 +77,12 @@ -- -- * '||' @:: 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@@@ -132,127 +93,64 @@ -- -- * '<=' @:: a -> a -> Bool@ -relational :: HashMap Text Binding-relational = Map.fromList- [ ">" @: qnum2 (>)- , ">=" @: qnum2 (>=)- , "<=" @: qnum2 (<=)- , "<" @: qnum2 (<)- ]- -- $numeric ----- * '+' @:: Number -> Number -> Number@+-- * '+' @:: Scientific -> Scientific -> Scientific@ ----- * '-' @:: Number -> Number -> Number@+-- * '-' @:: Scientific -> Scientific -> Scientific@ ----- * '*' @:: Number -> Number -> Number@+-- * '*' @:: Scientific -> Scientific -> Scientific@ ----- * 'abs' @:: Number -> Number@+-- * 'abs' @:: Scientific -> Scientific@ ----- * 'signum' @:: Number -> Number@+-- * 'signum' @:: Scientific -> Scientific@ ----- * 'negate' @:: Number -> Number@--numeric :: HashMap Text Binding-numeric = Map.fromList- [ "+" @: qnum2 (+)- , "-" @: qnum2 (-)- , "*" @: qnum2 (*)- , "abs" @: qnum1 abs- , "signum" @: qnum1 signum- , "negate" @: qnum1 negate- ]+-- * 'negate' @:: Scientific -> Scientific@ -- $fractional ----- * 'truncate' @:: Number -> Number@+-- * 'truncate' @:: Scientific -> Scientific@ ----- * 'round' @:: Number -> Number@+-- * 'round' @:: Scientific -> Scientific@ ----- * 'ceiling' @:: Number -> Number@+-- * 'ceiling' @:: Scientific -> Scientific@ ----- * '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)- ]+-- * 'floor' @:: Scientific -> Scientific@ -- $textual ----- * @takeWord@ @:: Text -> Text@------ * @dropWord@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.takeWord' @:: Text -> Text@ ----- * @lowerHead@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.dropWord' @:: Text -> Text@ ----- * @upperHead@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.lowerHead' @:: Text -> Text@ ----- * @toTitle@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.upperHead' @:: Text -> Text@ ----- * @toCamel@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.toTitle' @:: Text -> Text@ ----- * @toPascal@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.toCamel' @:: Text -> Text@ ----- * @toSnake@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.toPascal' @:: Text -> Text@ ----- * @toSpinal@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.toSnake' @:: Text -> Text@ ----- * @toTrain@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.toSpinal' @:: Text -> Text@ ----- * @toLower@ @:: Text -> Text@+-- * 'Data.Text.Manipulate.toTrain' @:: Text -> Text@ ----- * @toUpper@ @:: Text -> Text@+-- * 'Data.Text.toLower' @:: Text -> Text@ ----- * @toOrdinal@ @:: Number -> Text@+-- * 'Data.Text.toUpper' @:: Text -> Text@ ----- /See:/ <http://hackage.haskell.org/package/text-manipulate text-manipulate>--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)- ]+-- * 'Data.Text.Manipulate.toOrdinal' @:: Scientific -> Text@ -- $collection ----- * @length@ @:: Collection -> Number@ (/See/: 'Data.Text.length', 'Data.Vector.length', '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/: '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- ]+-- * @empty@ @:: Collection -> Bool@ (/See/: Text:'Data.Text.null', Vector.'Data.Vector.null', HashMap.'Data.HashMap.Strict.null') -- $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
+ src/Text/EDE/Internal/AST.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++-- Module : Text.EDE.Internal.AST+-- Copyright : (c) 2013-2014 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+-- you can obtain it at http://mozilla.org/MPL/2.0/.+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)++-- | AST smart constructors.+module Text.EDE.Internal.AST where++import Control.Comonad+import Control.Comonad.Cofree+import Data.Aeson.Types+import Data.Foldable+import Data.List.NonEmpty (NonEmpty(..))+import Data.Maybe+import Data.Monoid+import Text.EDE.Internal.Types++newtype Mu f = Mu (f (Mu f))++cofree :: Functor f => a -> Mu f -> Cofree f a+cofree x = go+ where+ go (Mu f) = x :< fmap go f++var :: Id -> Var+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++efun :: Id -> Exp a -> Exp a+efun i e = let x = extract e in x :< EApp (x :< EFun i) e++efilter :: Exp a -> (Id, [Exp a]) -> Exp a+efilter e (i, ps) = let x = extract e in eapp x ((x :< EFun i) : e : ps)++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)++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]++eempty :: Exp a -> Exp a -> Maybe (Exp a) -> Exp a+eempty v e = maybe e (eif (efun "!" (efun "empty" v), e) [] . Just)++true, false, wild :: Exp a -> Alt (Exp a)+true = (PLit (Bool True),)+false = (PLit (Bool False),)+wild = (PWild,)++blank :: Mu ExpF+blank = Mu (ELit (String mempty))
src/Text/EDE/Internal/Eval.hs view
@@ -15,90 +15,102 @@ 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 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 Data.Text.Manipulate (toOrdinal)+import Text.EDE.Internal.Quoting+import Text.EDE.Internal.Filters (stdlib) import Text.EDE.Internal.Types+import Text.PrettyPrint.ANSI.Leijen (Doc, Pretty(..), (<+>))+import qualified Text.PrettyPrint.ANSI.Leijen as PP 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+ { _templates :: HashMap Id (Exp Delta)+ , _quoted :: HashMap Id Term+ , _values :: HashMap Id Value } type Context = ReaderT Env Result -render :: HashMap Text Exp- -> HashMap Text Binding- -> Exp- -> HashMap Text Value+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 fs o)+render ts fs e o = runReaderT (eval e >>= nf) (Env ts (stdlib <> fs) o) where- nf (BVal v) = build (delta e) v+ nf (TVal 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+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 "binding {} doesn't exist." [i])+ maybe (throwError d $ "filter" <+> PP.bold (pp i) <+> "doesn't exist.") return q -eval (EApp d a b) = do+eval (_ :< EApp (_ :< EFun "defined") e) = predicate e++eval (d :< EApp a b) = do x <- eval a y <- eval b binding d x y -eval (ELet _ k rhs bdy) = do+eval (_ :< ELet k rhs bdy) = do q <- eval rhs- v <- lift (unquote q)+ 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 (ECase d p ws) = go ws+eval (d :< ECase p ws) = go ws where- go [] = return (quote (String mempty))+ go [] = return (qprim (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+ PVar v -> eval (d :< EVar v) >>= cond e as+ PLit l -> eval (d :< ELit l) >>= cond e as - cond e as y@(BVal Bool{}) = do+ cond e as y@(TVal Bool{}) = do x <- predicate p- if x == y then eval e else go as- cond e as y@BVal{} = do+ if x `eq` y+ then eval e+ else go as++ cond e as y@TVal{} = do x <- eval p- if x == y then eval e else go as+ if x `eq` y+ then eval e+ else go as+ cond _ as _ = go as -eval (ELoop _ i v bdy) = eval v >>= lift . unquote >>= loop+ eq (TVal a) (TVal b) = a == b+ eq _ _ = False++eval (_ :< ELoop i v bdy) = eval v >>= lift . unquote i 0 >>= loop where d = delta bdy - loop :: Collection -> Context Binding- loop (Col l xs) = snd <$> foldlM iter (1, quote (String mempty)) xs+ loop :: Collection -> Context Term+ loop (Col l xs) = snd <$> foldlM iter (1, qprim (String mempty)) xs where iter (n, p) x = do shadowed n@@ -109,10 +121,18 @@ shadowed n = do m <- asks _values maybe (return ())- (\x -> throwError' d "binding {} shadows variable {} :: {}, {}"- [Text.unpack i, show x, typeOf x, show n])+ (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."+ context n (k, x) = object $ [ "value" .= x , "length" .= l@@ -129,53 +149,58 @@ key (Just k) = ["key" .= k] key Nothing = [] -eval (EIncl d i) = do+eval (d :< EIncl 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]+ Nothing -> throwError d $+ "template"+ <+> PP.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) }) -variable :: Var -> Context Value-variable (Var is) = asks _values >>= go (NonEmpty.toList is) [] . Object+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' undefined "binding {} doesn't exist." [fmt (k:r)])+ maybe (throwError d $ "variable" <+> pretty cur <+> "doesn't exist.") (go ks (k:r)) (Map.lookup k m) where+ cur = Var (k:|r)+ 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 "."+ nest x = throwError d $ "variable"+ <+> pretty cur+ <+> "::"+ <+> pp x+ <+> "doesn't supported nested accessors." -- | A variable can be tested for truthiness, but a non-whnf expr cannot.-predicate :: Exp -> Context Binding+predicate :: Exp Delta -> Context Term predicate x = do r <- runReaderT (eval x) <$> ask lift $ case r of Success q- | BVal Bool{} <- q -> Success q+ | TVal Bool{} <- q -> Success q Success q- | BVal Null <- q -> Success (quote False)- Success _ -> Success (quote True)+ | TVal Null <- q -> Success (qprim False)+ Success _ -> Success (qprim True) Failure _- | EVar{} <- x -> Success (quote False)+ | _ :< EVar{} <- x -> Success (qprim False) Failure e -> Failure e -binding :: Delta -> Binding -> Binding -> Context Binding+binding :: Delta -> Term -> Term -> Context Term binding d x y = case (x, y) of- (BVal l, BVal r) -> quote <$> liftM2 (<>) (build d l) (build d r)- _ -> lift (qapply x y)+ (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@@ -186,8 +211,8 @@ | 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]+ throwError d ("unable to render literal" <+> pp x) -- FIXME: Add delta information to the thrown error document.-throwError' :: Params ps => Delta -> Format -> ps -> Context a-throwError' _ f = lift . throwError f+throwError :: Delta -> Doc -> Context a+throwError d doc = lift . Failure $ pretty d <+> PP.red "error:" <+> doc
+ src/Text/EDE/Internal/Filters.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++-- Module : Text.EDE.Internal.Filters+-- Copyright : (c) 2013-2014 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+-- you can obtain it at http://mozilla.org/MPL/2.0/.+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)++module Text.EDE.Internal.Filters where++import Control.Applicative+import Data.Aeson (Value(..), Array, Object, 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+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(..), (<+>))++default (Integer)++stdlib :: HashMap Text Term+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)++ -- FIXME: existence checks currently hardcoded into the evaluator:+ -- "default"+ -- "defined"+ ]++(@:) :: Quote a => Id -> a -> (Id, Term)+k @: q = (k, quote k 0 q)++-- | Quote a binary function which takes the most general binding value.+qpoly2 :: Quote a => Id -> (Value -> Value -> a) -> (Id, Term)+qpoly2 k = (k,) . quote k 0++-- | Quote an unary numeric function.+qnum1 :: Id -> (Scientific -> Scientific) -> (Id, Term)+qnum1 k = (k,) . quote k 0++-- | Quote a binary numeric function.+qnum2 :: Quote a => Id -> (Scientific -> Scientific -> a) -> (Id, Term)+qnum2 k = (k,) . quote k 0++-- | 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 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++-- | 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 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++headT, lastT, tailT, initT :: Text -> Value+headT = text (Text.singleton . Text.unsafeHead)+lastT = text (Text.singleton . Text.last)+tailT = text Text.unsafeTail+initT = text Text.init++headV, lastV, tailV, initV :: Array -> Value+headV = vec Vector.unsafeHead+lastV = vec Vector.unsafeLast+tailV = vec (Array . Vector.unsafeTail)+initV = vec (Array . Vector.unsafeInit)++text :: (Text -> Text) -> Text -> Value+text f = String . safe mempty Text.null f++vec :: (Array -> Value) -> Array -> Value+vec = safe (Array Vector.empty) Vector.null++safe :: b -> (a -> Bool) -> (a -> b) -> a -> b+safe v f g x+ | f x = v+ | otherwise = g x
− src/Text/EDE/Internal/HOAS.hs
@@ -1,191 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}---- Module : Text.EDE.Internal.HOAS--- Copyright : (c) 2013-2014 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--- you can obtain it at http://mozilla.org/MPL/2.0/.--- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>--- 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 _ = "<function>"--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]
src/Text/EDE/Internal/Parser.hs view
@@ -22,7 +22,9 @@ module Text.EDE.Internal.Parser where import Control.Applicative-import Control.Lens hiding (both, noneOf)+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@@ -38,6 +40,7 @@ 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@@ -99,7 +102,7 @@ runParser :: Syntax -> Text -> ByteString- -> Result (Exp, HashMap Text (NonEmpty Delta))+ -> Result (Exp Delta, HashMap Text (NonEmpty Delta)) runParser o n = res . parseByteString (runEDE run) pos where run = runStateT (pragma *> document <* eof) (Env o mempty)@@ -122,14 +125,14 @@ <|> pragmak "comment" *> pure delimComment <|> pragmak "block" *> pure delimBlock -document :: Parser m => m Exp+document :: Parser m => m (Exp Delta) document = eapp <$> position <*> many (statement <|> inline <|> fragment) -inline :: Parser m => m Exp+inline :: Parser m => m (Exp Delta) inline = between inlinel inliner term -fragment :: Parser m => m Exp-fragment = ELit <$> position <*> pack (notFollowedBy end0 >> try line0 <|> line1)+fragment :: Parser m => m (Exp Delta)+fragment = ann (ELit <$> pack (notFollowedBy end0 >> try line0 <|> line1)) where line0 = manyTill1 (noneOf "\n") (try (lookAhead end0) <|> eof) line1 = manyEndBy1 anyChar newline@@ -137,7 +140,7 @@ end0 = void (inlinel <|> blockl <|> try end1) end1 = multiLine (pure ()) (manyTill1 anyChar (lookAhead blockr)) -statement :: Parser m => m Exp+statement :: Parser m => m (Exp Delta) statement = choice [ ifelif , cases@@ -157,7 +160,7 @@ singleLine :: Parser m => m b -> m a -> m a singleLine s = between (try (blockl *> s)) blockr -ifelif :: Parser m => m Exp+ifelif :: Parser m => m (Exp Delta) ifelif = eif <$> branch "if" <*> many (branch "elif")@@ -166,7 +169,7 @@ where branch k = (,) <$> block k term <*> document -cases :: Parser m => m Exp+cases :: Parser m => m (Exp Delta) cases = ecase <$> block "case" term <*> many@@ -175,69 +178,65 @@ <*> else' <* exit "endcase" -loop :: Parser m => m Exp+loop :: Parser m => m (Exp Delta) loop = do- d <- position (i, v) <- block "for" ((,) <$> identifier <*> (keyword "in" *> collection))- eempty d v- <$> (ELoop d i v <$> document)- <*> else'+ d <- document+ eempty v (extract v :< ELoop i v d)+ <$> else' <* exit "endfor" -include :: Parser m => m Exp-include = do+include :: Parser m => m (Exp Delta)+include = block "include" $ do d <- position- block "include" (incl d)+ k <- stringLiteral+ includes %= Map.insertWith (<>) k (d:|[])+ elet <$> scope <*> pure (d :< EIncl k) 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"+binding :: Parser m => m (Exp Delta)+binding = elet . Just+ <$> block "let"+ ((,) <$> identifier+ <*> (symbol "=" *> term))+ <*> document+ <* exit "endlet" -raw :: Parser m => m Exp-raw = ELit- <$> position- <*> (start *> pack (manyTill anyChar (lookAhead end)) <* end)+raw :: Parser m => m (Exp Delta)+raw = ann (ELit <$> body) where+ body = start *> pack (manyTill anyChar (lookAhead end)) <* end 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)+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") -else' :: Parser m => m (Maybe Exp)+else' :: Parser m => m (Maybe (Exp Delta)) 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+pattern :: Parser m => m Pat+pattern = PWild <$ char '_' <|> PVar <$> variable <|> PLit <$> literal++term :: Parser m => m (Exp Delta)+term = chainl1' term0 (try filter') (symbol "|" *> pure efilter) <|> term0++term0 :: Parser m => m (Exp Delta)+term0 = buildExpressionParser table expr where table = [ [prefix "!"]@@ -246,29 +245,24 @@ , [infix' "==", infix' "!=", infix' ">", infix' ">=", infix' "<", infix' "<="] , [infix' "&&"] , [infix' "||"]- , [filter' "|"] ] - prefix n = Prefix (efun <$> operator n <*> pure n)+ 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+ d :< EApp (efun n l) r) AssocLeft - expr = parens term <|> apply EVar variable <|> apply ELit literal+ expr = parens term+ <|> ann (EVar <$> variable)+ <|> ann (ELit <$> literal) -pattern :: Parser m => m Pat-pattern = PWild <$ char '_' <|> PVar <$> variable <|> PLit <$> literal+filter' :: Parser m => m (Id, [Exp Delta])+filter' = (,) <$> identifier <*> (parens (commaSep1 term) <|> pure []) -collection :: Parser m => m Exp-collection = EVar <$> position <*> variable <|> ELit <$> position <*> col+collection :: Parser m => m (Exp Delta)+collection = ann (EVar <$> variable <|> ELit <$> col) where col = Object <$> object <|> Array <$> array@@ -303,18 +297,15 @@ keyword :: Parser m => String -> m Delta keyword k = position <* try (reserve keywordStyle k) -variable :: Parser m => m Var+variable :: (Monad m, TokenParsing m) => m Var variable = Var <$> (NonEmpty.fromList <$> sepBy1 identifier (char '.')) -identifier :: Parser m => m Id+identifier :: (Monad m, TokenParsing m) => m Id identifier = ident variableStyle -spaces :: Parser m => m ()+spaces :: (Monad m, TokenParsing 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 @@ -322,6 +313,15 @@ manyEndBy1 p end = go where 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++ann :: (DeltaParsing m, Functor f) => m (f (Mu f)) -> m (Cofree f Delta)+ann p = cofree <$> position <*> (Mu <$> p) pack :: Functor f => f String -> f Value pack = fmap (String . Text.pack)
+ src/Text/EDE/Internal/Quoting.hs view
@@ -0,0 +1,184 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-}++{-# OPTIONS_GHC -fno-warn-type-defaults #-}++-- Module : Text.EDE.Internal.Quoting+-- Copyright : (c) 2013-2014 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+-- you can obtain it at http://mozilla.org/MPL/2.0/.+-- Maintainer : Brendan Hay <brendan.g.hay@gmail.com>+-- Stability : experimental+-- Portability : non-portable (GHC extensions)++module Text.EDE.Internal.Quoting where++import Control.Applicative+import Control.Monad+import qualified Data.Aeson as A+import Data.Aeson hiding (Result(..))+import Data.Bifunctor+import qualified Data.ByteString.Char8 as BS+import qualified Data.HashMap.Strict as Map+import Data.List (sortBy)+import Data.Monoid+import Data.Ord (comparing)+import Data.Scientific+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++default (Doc, Double, Integer)++-- | A HOAS representation of (possibly partially applied) values+-- in the environment.+data Term+ = TVal !Value+ | TLam (Term -> Result Term)++instance Pretty Term where+ pretty = \case+ TLam _ -> "Function"+ TVal v -> PP.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++-- | 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++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++instance Unquote Integer where+ 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++ 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)++class Quote a where+ 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++instance Quote Term where+ 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++typeErr :: Id -> Int -> Doc -> Doc -> 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)+ <+> "to left hand side:"+ </> PP.indent 4 (pretty e </> pretty mark)++ arg = "invalid"+ <+> PP.bold (pp $ toOrdinal (n - 1))+ <+> "argument to"+ <+> PP.bold (pp k)+ <> ":"+ </> PP.indent 4 (pretty e </> pretty mark)++ mark = renderingCaret (Columns col col) $+ "... | " <> Text.encodeUtf8 k <> line++ col | self = 1+ | otherwise = fromIntegral (Text.length k + 4 + (n * 2))++ line | self = "\n"+ | otherwise =+ "(" <> BS.intercalate ", " (replicate (n - 1) "...") <> "\n"++ self = n <= 1
src/Text/EDE/Internal/Syntax.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-} -- Module : Text.EDE.Internal.Syntax -- Copyright : (c) 2013-2014 Brendan Hay <brendan.g.hay@gmail.com>
src/Text/EDE/Internal/Types.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}@@ -21,21 +22,42 @@ 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 Data.Monoid hiding ((<>))+import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe+import Data.Monoid hiding ((<>)) 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 qualified Data.Text as Text+import Text.PrettyPrint.ANSI.Leijen (Pretty(..), Doc)+import qualified Text.PrettyPrint.ANSI.Leijen as PP import Text.Trifecta.Delta +-- | Convenience wrapper for Pretty instances.+newtype PP a = PP { unPP :: a }++pp :: Pretty (PP a) => a -> Doc+pp = pretty . PP++instance Pretty (PP Text) where+ pretty = PP.string . Text.unpack . unPP++instance Pretty (PP Value) where+ pretty (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@@ -57,14 +79,14 @@ 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'])+ 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 (vsep [e, e'])+ Failure e <|> Failure e' = Failure (PP.vsep [e, e']) {-# INLINE (<|>) #-} empty = Failure mempty {-# INLINE empty #-}@@ -95,9 +117,6 @@ 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@@ -110,7 +129,7 @@ makeClassy ''Syntax -- | A function to resolve the target of an @include@ expression.-type Resolver m = Syntax -> Text -> Delta -> m (Result Template)+type Resolver m = Syntax -> Id -> 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!@@ -119,15 +138,24 @@ -- | A parsed and compiled template. data Template = Template { _tmplName :: !Text- , _tmplExp :: !Exp- , _tmplIncl :: HashMap Text Exp+ , _tmplExp :: !(Exp Delta)+ , _tmplIncl :: HashMap Id (Exp Delta) } deriving (Eq) type Id = Text newtype Var = Var (NonEmpty Id)- deriving (Eq, Show)+ deriving (Eq) +instance Pretty Var where+ pretty (Var is) = PP.hcat+ . PP.punctuate "."+ . map (PP.bold . pp)+ $ NonEmpty.toList is++instance Show Var where+ show = show . pretty+ data Collection where Col :: Foldable f => Int -> f (Maybe Text, Value) -> Collection @@ -137,64 +165,23 @@ | 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]+type Alt a = (Pat, a) -eempty :: Delta -> Exp -> Exp -> Maybe Exp -> Exp-eempty d v e = maybe e (eif (efun d "!" (efun d "empty" v), e) [] . Just)+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) -wild, true, false :: Exp -> Alt-wild = (PWild,)-true = (PLit (Bool True),)-false = (PLit (Bool False),)+type Exp = Cofree ExpF -bld :: Delta -> Exp-bld = (`ELit` String mempty)+instance HasDelta (Exp Delta) where+ delta = extract -- | Unwrap a 'Value' to an 'Object' safely. --