ginger 0.2.6.0 → 0.2.7.0
raw patch · 8 files changed
+867/−587 lines, 8 files
Files
- ginger.cabal +4/−2
- src/Text/Ginger/GVal.hs +10/−11
- src/Text/Ginger/Optimizer.hs +70/−2
- src/Text/Ginger/Parse.hs +15/−16
- src/Text/Ginger/Run.hs +66/−556
- src/Text/Ginger/Run/Builtins.hs +366/−0
- src/Text/Ginger/Run/FuncUtils.hs +153/−0
- src/Text/Ginger/Run/Type.hs +183/−0
ginger.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: ginger-version: 0.2.6.0+version: 0.2.7.0 synopsis: An implementation of the Jinja2 template language in Haskell description: Ginger is Jinja, minus the most blatant pythonisms. Wants to be feature complete, but isn't quite there yet.@@ -26,7 +26,9 @@ , Text.Ginger.Parse , Text.Ginger.Run , Text.PrintfA- -- other-modules:+ other-modules: Text.Ginger.Run.Type+ , Text.Ginger.Run.FuncUtils+ , Text.Ginger.Run.Builtins -- other-extensions: build-depends: base >=4.5 && <5 , aeson
src/Text/Ginger/GVal.hs view
@@ -35,8 +35,7 @@ , Monad ) import qualified Prelude-import qualified Data.List as List-import Data.Maybe ( fromMaybe, catMaybes, isJust )+import Data.Maybe ( fromMaybe, catMaybes, isJust, mapMaybe ) import Data.Text (Text) import Data.String (IsString, fromString) import qualified Data.Text as Text@@ -129,11 +128,11 @@ toJSON g = if isNull g then JSON.Null- else (fromMaybe (JSON.toJSON $ asText g) $+ else fromMaybe (JSON.toJSON $ asText g) $ asJSON g <|> (JSON.toJSON <$> asList g) <|> (JSON.toJSON <$> asHashMap g) <|>- (JSON.toJSON <$> asNumber g))+ (JSON.toJSON <$> asNumber g) -- | For convenience, 'Show' is implemented in a way that looks similar to -- JavaScript / JSON@@ -167,7 +166,7 @@ 'c' -> formatString (Text.unpack $ asText x) fmt- f -> if f `Prelude.elem` ("fFgGeE" :: [Char])+ f -> if f `Prelude.elem` ['f', 'F', 'g', 'G', 'e', 'E'] then formatRealFloat (toRealFloat . fromMaybe 0 . asNumber $ x) fmt else formatInteger (Prelude.round . fromMaybe 0 . asNumber $ x) fmt @@ -192,7 +191,7 @@ numPositional = Prelude.length fromPositional namesRemaining = Prelude.drop numPositional names positional = Prelude.drop numPositional positionalRaw- fromNamed = catMaybes $ (List.map lookupName namesRemaining)+ fromNamed = mapMaybe lookupName namesRemaining lookupName n = do v <- HashMap.lookup n namedRaw return (n, v)@@ -240,7 +239,7 @@ , asText = mconcat . Prelude.map asText . HashMap.elems $ xs , asBoolean = not . HashMap.null $ xs , isNull = False- , asLookup = Just (\v -> HashMap.lookup v xs)+ , asLookup = Just (`HashMap.lookup` xs) , asDictItems = Just $ HashMap.toList xs } @@ -305,11 +304,11 @@ orderedDict :: [Pair m] -> GVal m orderedDict xs = def- { asHtml = mconcat . Prelude.map asHtml . Prelude.map snd $ xs- , asText = mconcat . Prelude.map asText . Prelude.map snd $ xs+ { asHtml = mconcat . Prelude.map (asHtml . snd) $ xs+ , asText = mconcat . Prelude.map (asText . snd) $ xs , asBoolean = not . Prelude.null $ xs , isNull = False- , asLookup = Just (\v -> HashMap.lookup v hm)+ , asLookup = Just (`HashMap.lookup` hm) , asDictItems = Just xs } where@@ -413,7 +412,7 @@ rawJSONToGVal (JSON.Number n) = toGVal n rawJSONToGVal (JSON.String s) = toGVal s rawJSONToGVal (JSON.Bool b) = toGVal b-rawJSONToGVal (JSON.Null) = def+rawJSONToGVal JSON.Null = def rawJSONToGVal (JSON.Array a) = toGVal $ Vector.toList a rawJSONToGVal (JSON.Object o) = toGVal o
src/Text/Ginger/Optimizer.hs view
@@ -4,7 +4,10 @@ where import Text.Ginger.AST+import Text.Ginger.GVal import Data.Monoid+import Control.Monad.Identity+import Data.Default class Optimizable a where optimize :: a -> a@@ -21,10 +24,13 @@ instance Optimizable Macro where optimize = optimizeMacro +instance Optimizable Expression where+ optimize = optimizeExpression+ optimizeTemplate t = t { templateBody = optimize $ templateBody t- , templateBlocks = fmap optimize $ templateBlocks t- , templateParent = fmap optimize $ templateParent t+ , templateBlocks = optimize <$> templateBlocks t+ , templateParent = optimize <$> templateParent t } {-@@ -45,6 +51,15 @@ [] -> NullS [x] -> x xs -> MultiS xs+optimizeStatement (InterpolationS e) =+ InterpolationS (optimize e)+optimizeStatement s@(IfS c t f) =+ let c' = optimize c+ in case compileTimeEval c' of+ Just gv -> case asBoolean gv of+ True -> t+ False -> f+ _ -> s optimizeStatement s = s optimizeBlock (Block b) = Block $ optimize b@@ -67,3 +82,56 @@ mergeLiterals [x] = [x] mergeLiterals (x@(LiteralS a):y@(LiteralS b):xs) = mergeLiterals $ (LiteralS $ a <> b):xs mergeLiterals (x:xs) = x:mergeLiterals xs+++{-+data Expression+ = StringLiteralE Text -- ^ String literal expression: "foobar"+ | NumberLiteralE Scientific -- ^ Numeric literal expression: 123.4+ | BoolLiteralE Bool -- ^ Boolean literal expression: true+ | NullLiteralE -- ^ Literal null+ | VarE VarName -- ^ Variable reference: foobar+ | ListE [Expression] -- ^ List construct: [ expr, expr, expr ]+ | ObjectE [(Expression, Expression)] -- ^ Object construct: { expr: expr, expr: expr, ... }+ | MemberLookupE Expression Expression -- ^ foo[bar] (also dot access)+ | CallE Expression [(Maybe Text, Expression)] -- ^ foo(bar=baz, quux)+ | LambdaE [Text] Expression -- ^ (foo, bar) -> expr+ | TernaryE Expression Expression Expression -- ^ expr ? expr : expr+ deriving (Show)+-}++optimizeExpression :: Expression -> Expression+optimizeExpression = expandConstExpressions . optimizeSubexpressions++expandConstExpressions :: Expression -> Expression+expandConstExpressions e@(TernaryE c t f) =+ case compileTimeEval c of+ Just gv -> case asBoolean gv of+ True -> t+ False -> f+ _ -> e+expandConstExpressions e = e++optimizeSubexpressions (ListE xs) = ListE (map optimize xs)+optimizeSubexpressions (ObjectE xs) = ObjectE [ (optimize k, optimize v) | (k, v) <- xs ]+optimizeSubexpressions (MemberLookupE k m) = MemberLookupE (optimize k) (optimize m)+optimizeSubexpressions (CallE f args) = CallE (optimize f) [(n, optimize v) | (n, v) <- args]+optimizeSubexpressions (LambdaE args body) = LambdaE args (optimize body)+optimizeSubexpressions (TernaryE c t f) = TernaryE (optimize c) (optimize t) (optimize f)+optimizeSubexpressions e = e++isConstExpression :: Expression -> Bool+isConstExpression (StringLiteralE _) = True+isConstExpression (BoolLiteralE _) = True+isConstExpression NullLiteralE = True+isConstExpression (ListE xs) = all isConstExpression xs+isConstExpression (ObjectE xs) = all (\(k,v) -> isConstExpression k && isConstExpression v) xs+isConstExpression (MemberLookupE k m) = isConstExpression k && isConstExpression m+isConstExpression e = False++compileTimeEval :: Expression -> Maybe (GVal Identity)+compileTimeEval (StringLiteralE s) = Just . toGVal $ s+compileTimeEval (NumberLiteralE n) = Just . toGVal $ n+compileTimeEval (BoolLiteralE b) = Just . toGVal $ b+compileTimeEval NullLiteralE = Just def+compileTimeEval e = Nothing
src/Text/Ginger/Parse.hs view
@@ -158,7 +158,7 @@ reduceStatements :: [Statement] -> Statement reduceStatements [] = NullS-reduceStatements (x:[]) = x+reduceStatements [x] = x reduceStatements xs = MultiS xs templateP :: Monad m => Parser m Template@@ -169,16 +169,16 @@ parentName <- try (spaces >> fancyTagP "extends" stringLiteralP) parentTemplate <- includeTemplate parentName blocks <- HashMap.fromList <$> many blockP- return $ Template { templateBody = NullS, templateParent = Just parentTemplate, templateBlocks = blocks }+ return Template { templateBody = NullS, templateParent = Just parentTemplate, templateBlocks = blocks } baseTemplateP :: Monad m => Parser m Template baseTemplateP = do body <- statementsP blocks <- psBlocks <$> getState- return $ Template { templateBody = body, templateParent = Nothing, templateBlocks = blocks }+ return Template { templateBody = body, templateParent = Nothing, templateBlocks = blocks } statementsP :: Monad m => Parser m Statement-statementsP = do+statementsP = reduceStatements . filter (not . isNullS) <$> many (try statementP) where isNullS NullS = True@@ -199,7 +199,7 @@ interpolationStmtP :: Monad m => Parser m Statement interpolationStmtP = do- try $ openInterpolationP+ try openInterpolationP spaces expr <- expressionP spaces@@ -223,8 +223,8 @@ commentStmtP :: Monad m => Parser m Statement commentStmtP = do- try $ openCommentP- manyTill anyChar (try $ closeCommentP)+ try openCommentP+ manyTill anyChar (try closeCommentP) return NullS ifStmtP :: Monad m => Parser m Statement@@ -340,7 +340,7 @@ let forLoop = ForS varNameIndex varNameVal iteree body return $ maybe forLoop- (\elseBranch -> IfS iteree forLoop elseBranch)+ (IfS iteree forLoop) elseBranchMay includeP :: Monad m => Parser m Statement@@ -392,14 +392,13 @@ return (iteree, varIdent, indexIdent) fancyTagP :: Monad m => String -> Parser m a -> Parser m a-fancyTagP tagName inner =+fancyTagP tagName = between (try $ do openTagP string tagName spaces) closeTagP- inner simpleTagP :: Monad m => String -> Parser m () simpleTagP tagName = openTagP >> string tagName >> closeTagP@@ -476,12 +475,12 @@ return $ foldl (flip ($)) lhs tails where opChars :: [Char]- opChars = nub . sort . concat . map fst $ operators+ opChars = nub . sort . concatMap fst $ operators operativeTail :: Parser m (Expression -> Expression) operativeTail = do funcName <-- foldl (<|>) (fail "operator") $- [ try (string op >> notFollowedBy (oneOf opChars)) >> return fn | (op, fn) <- operators ]+ foldl (<|>) (fail "operator")+ [ try (string op >> notFollowedBy (oneOf opChars)) >> return fn | (op, fn) <- operators ] spaces rhs <- operandP spaces@@ -589,7 +588,7 @@ namedFuncArgP :: Monad m => Parser m (Maybe Text, Expression) namedFuncArgP = do- name <- try $ identifierP `before` (between spaces spaces $ string "=")+ name <- try $ identifierP `before` between spaces spaces (string "=") expr <- expressionP return (Just name, expr) @@ -667,7 +666,7 @@ identCharP = oneOf (['a'..'z'] ++ ['A'..'Z'] ++ ['_'] ++ ['0'..'9']) stringLiteralExprP :: Monad m => Parser m Expression-stringLiteralExprP = do+stringLiteralExprP = StringLiteralE . Text.pack <$> stringLiteralP stringLiteralP :: Monad m => Parser m String@@ -707,7 +706,7 @@ return $ sign ++ integral ++ fractional followedBy :: Monad m => m b -> m a -> m a-followedBy b a = a >>= \x -> (b >> return x)+followedBy b a = a >>= \x -> b >> return x before :: Monad m => m a -> m b -> m a before = flip followedBy
src/Text/Ginger/Run.hs view
@@ -56,14 +56,16 @@ , id ) import qualified Prelude-import Data.Maybe (fromMaybe, isJust)+import Data.Maybe (fromMaybe, isJust, isNothing) import qualified Data.List as List import Text.Ginger.AST import Text.Ginger.Html import Text.Ginger.GVal+import Text.Ginger.Run.Type+import Text.Ginger.Run.Builtins+import Text.Ginger.Run.FuncUtils import Text.Printf import Text.PrintfA-import Data.Scientific (formatScientific) import Data.Text (Text) import Data.String (fromString)@@ -77,549 +79,59 @@ import Control.Applicative import qualified Data.HashMap.Strict as HashMap import Data.HashMap.Strict (HashMap)-import Data.Scientific (Scientific)-import Data.Scientific as Scientific+import Data.Scientific (Scientific, formatScientific)+import qualified Data.Scientific as Scientific import Data.Default (def) import Safe (readMay, lastDef, headMay) import Network.HTTP.Types (urlEncode) import Debug.Trace (trace)-import Data.Maybe (isNothing) import Data.List (lookup, zipWith, unzip) --- | Execution context. Determines how to look up variables from the--- environment, and how to write out template output.-data GingerContext m h- = GingerContext- { contextLookup :: VarName -> Run m h (GVal (Run m h))- , contextWrite :: h -> Run m h ()- , contextEncode :: GVal (Run m h) -> h- }--contextWriteEncoded :: GingerContext m h -> GVal (Run m h) -> Run m h ()-contextWriteEncoded context =- contextWrite context . contextEncode context--data RunState m h- = RunState- { rsScope :: HashMap VarName (GVal (Run m h))- , rsCapture :: h- , rsCurrentTemplate :: Template -- the template we are currently running- , rsCurrentBlockName :: Maybe Text -- the name of the innermost block we're currently in- }--unaryFunc :: forall m h. (Monad m) => (GVal (Run m h) -> GVal (Run m h)) -> Function (Run m h)-unaryFunc f [] = return def-unaryFunc f ((_, x):[]) = return (f x)--ignoreArgNames :: ([a] -> b) -> ([(c, a)] -> b)-ignoreArgNames f args = f (Prelude.map snd args)--variadicNumericFunc :: Monad m => Scientific -> ([Scientific] -> Scientific) -> [(Maybe Text, GVal (Run m h))] -> Run m h (GVal (Run m h))-variadicNumericFunc zero f args =- return . toGVal . f $ args'- where- args' :: [Scientific]- args' = Prelude.map (fromMaybe zero . asNumber . snd) args--unaryNumericFunc :: Monad m => Scientific -> (Scientific -> Scientific) -> [(Maybe Text, GVal (Run m h))] -> Run m h (GVal (Run m h))-unaryNumericFunc zero f args =- return . toGVal . f $ args'- where- args' :: Scientific- args' = case args of- [] -> 0- (arg:_) -> fromMaybe zero . asNumber . snd $ arg--variadicStringFunc :: Monad m => ([Text] -> Text) -> [(Maybe Text, GVal (Run m h))] -> Run m h (GVal (Run m h))-variadicStringFunc f args =- return . toGVal . f $ args'- where- args' :: [Text]- args' = Prelude.map (asText . snd) args---- | Match args according to a given arg spec, Python style.--- The return value is a triple of @(matched, args, kwargs, unmatchedNames)@,--- where @matches@ is a hash map of named captured arguments, args is a list of--- remaining unmatched positional arguments, kwargs is a list of remaining--- unmatched named arguments, and @unmatchedNames@ contains the argument names--- that haven't been matched.-extractArgs :: [Text] -> [(Maybe Text, a)] -> (HashMap Text a, [a], HashMap Text a, [Text])-extractArgs argNames args =- let (matchedPositional, argNames', args') = matchPositionalArgs argNames args- (matchedKeyword, argNames'', args'') = matchKeywordArgs argNames' args'- unmatchedPositional = [ a | (Nothing, a) <- args'' ]- unmatchedKeyword = HashMap.fromList [ (k, v) | (Just k, v) <- args'' ]- in ( HashMap.fromList (matchedPositional ++ matchedKeyword)- , unmatchedPositional- , unmatchedKeyword- , argNames''- )- where- matchPositionalArgs :: [Text] -> [(Maybe Text, a)] -> ([(Text, a)], [Text], [(Maybe Text, a)])- matchPositionalArgs [] args = ([], [], args)- matchPositionalArgs names [] = ([], names, [])- matchPositionalArgs names@(n:ns) allArgs@((anm, arg):args)- | Just n == anm || isNothing anm =- let (matched, ns', args') = matchPositionalArgs ns args- in ((n, arg):matched, ns', args')- | otherwise = ([], names, allArgs)-- matchKeywordArgs :: [Text] -> [(Maybe Text, a)] -> ([(Text, a)], [Text], [(Maybe Text, a)])- matchKeywordArgs [] args = ([], [], args)- matchKeywordArgs names allArgs@((Nothing, arg):args) =- let (matched, ns', args') = matchKeywordArgs names args- in (matched, ns', (Nothing, arg):args')- matchKeywordArgs names@(n:ns) args =- case (lookup (Just n) args) of- Nothing ->- let (matched, ns', args') = matchKeywordArgs ns args- in (matched, n:ns', args')- Just v ->- let args' = [ (k,v) | (k,v) <- args, k /= Just n ]- (matched, ns', args'') = matchKeywordArgs ns args'- in ((n,v):matched, ns', args'')---- | Parse argument list into type-safe argument structure.-extractArgsT :: ([Maybe a] -> b) -> [Text] -> [(Maybe Text, a)] -> Either ([a], HashMap Text a, [Text]) b-extractArgsT f argNames args =- let (matchedMap, freeArgs, freeKwargs, unmatched) = extractArgs argNames args- in if List.null freeArgs && HashMap.null freeKwargs- then Right (f $ fmap (\name -> HashMap.lookup name matchedMap) argNames)- else Left (freeArgs, freeKwargs, unmatched)---- | Parse argument list into flat list of matched arguments.-extractArgsL :: [Text] -> [(Maybe Text, a)] -> Either ([a], HashMap Text a, [Text]) [Maybe a]-extractArgsL = extractArgsT id--extractArgsDefL :: [(Text, a)] -> [(Maybe Text, a)] -> Either ([a], HashMap Text a, [Text]) [a]-extractArgsDefL argSpec args =- let (names, defs) = unzip argSpec- in injectDefaults defs <$> extractArgsL names args--injectDefaults :: [a] -> [Maybe a] -> [a]-injectDefaults = zipWith fromMaybe--defRunState :: forall m h. (Monoid h, Monad m) => Template -> RunState m h-defRunState tpl =- RunState- { rsScope = HashMap.fromList scope- , rsCapture = mempty- , rsCurrentTemplate = tpl- , rsCurrentBlockName = Nothing- }- where- scope :: [(Text, GVal (Run m h))]- scope =- [ ("raw", fromFunction gfnRawHtml)- , ("abs", fromFunction . unaryNumericFunc 0 $ Prelude.abs)- , ("any", fromFunction gfnAny)- , ("all", fromFunction gfnAll)- -- TODO: batch- , ("capitalize", fromFunction . variadicStringFunc $ mconcat . Prelude.map capitalize)- , ("ceil", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.ceiling)- , ("center", fromFunction gfnCenter)- , ("concat", fromFunction . variadicStringFunc $ mconcat)- , ("contains", fromFunction gfnContains)- , ("d", fromFunction gfnDefault)- , ("default", fromFunction gfnDefault)- , ("difference", fromFunction . variadicNumericFunc 0 $ difference)- , ("e", fromFunction gfnEscape)- , ("equals", fromFunction gfnEquals)- , ("escape", fromFunction gfnEscape)- , ("filesizeformat", fromFunction gfnFileSizeFormat)- , ("filter", fromFunction gfnFilter)- , ("floor", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.floor)- , ("greater", fromFunction gfnGreater)- , ("greaterEquals", fromFunction gfnGreaterEquals)- , ("int", fromFunction . unaryFunc $ toGVal . (fmap (Prelude.truncate :: Scientific -> Int)) . asNumber)- , ("int_ratio", fromFunction . variadicNumericFunc 1 $ fromIntegral . intRatio . Prelude.map Prelude.floor)- , ("iterable", fromFunction . unaryFunc $ toGVal . (\x -> isList x || isDict x))- , ("length", fromFunction . unaryFunc $ toGVal . length)- , ("less", fromFunction gfnLess)- , ("lessEquals", fromFunction gfnLessEquals)- , ("modulo", fromFunction . variadicNumericFunc 1 $ fromIntegral . modulo . Prelude.map Prelude.floor)- , ("nequals", fromFunction gfnNEquals)- , ("num", fromFunction . unaryFunc $ toGVal . asNumber)- , ("printf", fromFunction gfnPrintf)- , ("product", fromFunction . variadicNumericFunc 1 $ Prelude.product)- , ("ratio", fromFunction . variadicNumericFunc 1 $ Scientific.fromFloatDigits . ratio . Prelude.map Scientific.toRealFloat)- , ("replace", fromFunction $ gfnReplace)- , ("round", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.round)- , ("show", fromFunction . unaryFunc $ fromString . show)- , ("slice", fromFunction $ gfnSlice)- , ("sort", fromFunction $ gfnSort)- , ("str", fromFunction . unaryFunc $ toGVal . asText)- , ("sum", fromFunction . variadicNumericFunc 0 $ Prelude.sum)- , ("truncate", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.truncate)- , ("urlencode", fromFunction $ gfnUrlEncode)- ]-- gfnRawHtml :: Function (Run m h)- gfnRawHtml = unaryFunc (toGVal . unsafeRawHtml . asText)-- gfnUrlEncode :: Function (Run m h)- gfnUrlEncode =- unaryFunc- ( toGVal- . Text.pack- . UTF8.toString- . urlEncode True- . UTF8.fromString- . Text.unpack- . asText- )-- gfnDefault :: Function (Run m h)- gfnDefault [] = return def- gfnDefault ((_, x):xs)- | asBoolean x = return x- | otherwise = gfnDefault xs-- gfnEscape :: Function (Run m h)- gfnEscape = return . toGVal . html . mconcat . fmap (asText . snd)-- gfnAny :: Function (Run m h)- gfnAny xs = return . toGVal $ Prelude.any (asBoolean . snd) xs-- gfnAll :: Function (Run m h)- gfnAll xs = return . toGVal $ Prelude.all (asBoolean . snd) xs-- gfnEquals :: Function (Run m h)- gfnEquals [] = return $ toGVal True- gfnEquals (x:[]) = return $ toGVal True- gfnEquals (x:xs) =- return . toGVal $ Prelude.all ((snd x `looseEquals`) . snd) xs-- gfnNEquals :: Function (Run m h)- gfnNEquals [] = return $ toGVal True- gfnNEquals (x:[]) = return $ toGVal True- gfnNEquals (x:xs) =- return . toGVal $ Prelude.any (not . (snd x `looseEquals`) . snd) xs-- gfnContains :: Function (Run m h)- gfnContains [] = return $ toGVal False- gfnContains (list:elems) =- let rawList = fromMaybe [] . asList . snd $ list- rawElems = fmap snd elems- e `isInList` xs = Prelude.any (looseEquals e) xs- es `areInList` xs = Prelude.all (`isInList` xs) es- in return . toGVal $ rawElems `areInList` rawList-- looseEquals :: GVal (Run m h) -> GVal (Run m h) -> Bool- looseEquals a b- | isJust (asFunction a) || isJust (asFunction b) = False- | isJust (asList a) /= isJust (asList b) = False- | isJust (asDictItems a) /= isJust (asDictItems b) = False- -- Both numbers: do numeric comparison- | isJust (asNumber a) && isJust (asNumber b) = asNumber a == asNumber b- -- If either is NULL, the other must be falsy- | isNull a || isNull b = asBoolean a == asBoolean b- | otherwise = asText a == asText b-- gfnLess :: Function (Run m h)- gfnLess [] = return . toGVal $ False- gfnLess xs' =- let xs = fmap snd xs'- in return . toGVal $- Prelude.all (== Just True) (Prelude.zipWith less xs (Prelude.tail xs))-- gfnGreater :: Function (Run m h)- gfnGreater [] = return . toGVal $ False- gfnGreater xs' =- let xs = fmap snd xs'- in return . toGVal $- Prelude.all (== Just True) (Prelude.zipWith greater xs (Prelude.tail xs))-- gfnLessEquals :: Function (Run m h)- gfnLessEquals [] = return . toGVal $ False- gfnLessEquals xs' =- let xs = fmap snd xs'- in return . toGVal $- Prelude.all (== Just True) (Prelude.zipWith lessEq xs (Prelude.tail xs))-- gfnGreaterEquals :: Function (Run m h)- gfnGreaterEquals [] = return . toGVal $ False- gfnGreaterEquals xs' =- let xs = fmap snd xs'- in return . toGVal $- Prelude.all (== Just True) (Prelude.zipWith greaterEq xs (Prelude.tail xs))-- less :: GVal (Run m h) -> GVal (Run m h) -> Maybe Bool- less a b = (<) <$> asNumber a <*> asNumber b-- greater :: GVal (Run m h) -> GVal (Run m h) -> Maybe Bool- greater a b = (>) <$> asNumber a <*> asNumber b-- lessEq :: GVal (Run m h) -> GVal (Run m h) -> Maybe Bool- lessEq a b = (<=) <$> asNumber a <*> asNumber b-- greaterEq :: GVal (Run m h) -> GVal (Run m h) -> Maybe Bool- greaterEq a b = (>=) <$> asNumber a <*> asNumber b-- difference :: Prelude.Num a => [a] -> a- difference (x:xs) = x - Prelude.sum xs- difference [] = 0-- ratio :: (Show a, Prelude.Fractional a, Prelude.Num a) => [a] -> a- ratio (x:xs) = x / Prelude.product xs- ratio [] = 0-- intRatio :: (Prelude.Integral a, Prelude.Num a) => [a] -> a- intRatio (x:xs) = x `Prelude.div` Prelude.product xs- intRatio [] = 0-- modulo :: (Prelude.Integral a, Prelude.Num a) => [a] -> a- modulo (x:xs) = x `Prelude.mod` Prelude.product xs- modulo [] = 0-- capitalize :: Text -> Text- capitalize txt = Text.toUpper (Text.take 1 txt) <> Text.drop 1 txt-- gfnCenter :: Function (Run m h)- gfnCenter [] = gfnCenter [(Nothing, toGVal ("" :: Text))]- gfnCenter (x:[]) = gfnCenter [x, (Nothing, toGVal (80 :: Int))]- gfnCenter (x:y:[]) = gfnCenter [x, y, (Nothing, toGVal (" " :: Text))]- gfnCenter ((_, s):(_, w):(_, pad):_) =- return . toGVal $ center (asText s) (fromMaybe 80 $ Prelude.truncate <$> asNumber w) (asText pad)-- gfnSlice :: Function (Run m h)- gfnSlice args =- let argValues =- extractArgsDefL- [ ("slicee", def)- , ("start", def)- , ("length", def)- ]- args- in case argValues of- Right (slicee:startPos:length:[]) -> do- let startInt :: Int- startInt = fromMaybe 0 . fmap Prelude.round . asNumber $ startPos-- lengthInt :: Maybe Int- lengthInt = fmap Prelude.round . asNumber $ length-- slice :: [a] -> Int -> Maybe Int -> [a]- slice xs start Nothing =- Prelude.drop start $ xs- slice xs start (Just length) =- Prelude.take length . Prelude.drop start $ xs- case asDictItems slicee of- Just items -> do- let slicedItems = slice items startInt lengthInt- return $ dict slicedItems- Nothing -> do- let items = fromMaybe [] $ asList slicee- slicedItems = slice items startInt lengthInt- return $ toGVal slicedItems- _ -> fail "Invalid arguments to 'slice'"-- gfnReplace :: Function (Run m h)- gfnReplace args =- let argValues =- extractArgsDefL- [ ("str", def)- , ("search", def)- , ("replace", def)- ]- args- in case argValues of- Right (strG:searchG:replaceG:[]) -> do- let str = asText strG- search = asText searchG- replace = asText replaceG- return . toGVal $ Text.replace search replace str- _ -> fail "Invalid arguments to 'replace'"-- gfnSort :: Function (Run m h)- gfnSort [] = return def- gfnSort ((_,sortee):args) = do- let sortKeyMay = asText <$> List.lookup (Just "by") args- sortReverse = fromMaybe False $ asBoolean <$> List.lookup (Just "reverse") args- baseComparer :: (GVal (Run m h)) -> (GVal (Run m h)) -> Prelude.Ordering- baseComparer = \a b -> Prelude.compare (asText a) (asText b)- extractKey :: Text -> GVal (Run m h) -> GVal (Run m h)- extractKey k g = fromMaybe def $ do- l <- asLookup g- l k- if isDict sortee- then do- let comparer' :: (Text, GVal (Run m h)) -> (Text, GVal (Run m h)) -> Prelude.Ordering- comparer' = case sortKeyMay of- Nothing -> \(_, a) (_, b) -> baseComparer a b- Just "__key" -> \(a, _) (b, _) -> Prelude.compare a b- Just k -> \(_, a) (_, b) ->- baseComparer- (extractKey k a) (extractKey k b)- comparer =- if sortReverse- then \a b -> comparer' b a- else comparer'- return . toGVal $ List.sortBy comparer (fromMaybe [] $ asDictItems sortee)- else do- let comparer' :: (GVal (Run m h)) -> (GVal (Run m h)) -> Prelude.Ordering- comparer' = case sortKeyMay of- Nothing ->- baseComparer- Just k -> \a b ->- baseComparer- (extractKey k a) (extractKey k b)- let comparer =- if sortReverse- then \a b -> comparer' b a- else comparer'- return . toGVal $ List.sortBy comparer (fromMaybe [] $ asList sortee)-- center :: Text -> Prelude.Int -> Text -> Text- center str width pad =- if Text.length str Prelude.>= width- then str- else paddingL <> str <> paddingR- where- chars = width - Text.length str- charsL = chars `div` 2- charsR = chars - charsL- repsL = Prelude.succ charsL `div` Text.length pad- paddingL = Text.take charsL . Text.replicate repsL $ pad- repsR = Prelude.succ charsR `div` Text.length pad- paddingR = Text.take charsR . Text.replicate repsR $ pad-- gfnFileSizeFormat :: Function (Run m h)- gfnFileSizeFormat [(_, sizeG)] =- gfnFileSizeFormat [(Nothing, sizeG), (Nothing, def)]- gfnFileSizeFormat [(_, sizeG), (_, binaryG)] = do- let sizeM = Prelude.round <$> asNumber sizeG- binary = asBoolean binaryG- Prelude.maybe- (return def)- (return . toGVal . formatFileSize binary)- sizeM- gfnFileSizeFormat _ = return def-- formatFileSize :: Bool -> Integer -> String- formatFileSize binary size =- let units =- if binary- then- [ (1, "B")- , (1024, "kiB")- , (1024 ^ 2, "MiB")- , (1024 ^ 3, "GiB")- , (1024 ^ 4, "TiB")- , (1024 ^ 5, "PiB")- ]- else- [ (1, "B")- , (1000, "kB")- , (1000000, "MB")- , (1000000000, "GB")- , (1000000000000, "TB")- , (1000000000000000, "PB")- ]- (divisor, unitName) =- lastDef (1, "B") [ (d, u) | (d, u) <- units, d <= size ]- dividedSize :: Scientific- dividedSize = fromIntegral size / fromIntegral divisor- formattedSize =- if isInteger dividedSize- then formatScientific Fixed (Just 0) dividedSize- else formatScientific Fixed (Just 1) dividedSize- in formattedSize ++ " " ++ unitName-- gfnPrintf :: Function (Run m h)- gfnPrintf [] = return def- gfnPrintf [(_, fmtStrG)] = return fmtStrG- gfnPrintf ((_, fmtStrG):args) = do- return . toGVal $ printfG fmtStr (fmap snd args)- where- fmtStr = Text.unpack $ asText fmtStrG-- gfnFilter :: Function (Run m h)- gfnFilter [] = return def- gfnFilter [(_, xs)] = return xs- gfnFilter ((_, xs):(_, p):args) = do- pfnG <- maybe (fail "Not a function") return (asFunction p)- let pfn x = asBoolean <$> pfnG ((Nothing, x):args)- xsl = fromMaybe [] (asList xs)- filtered <- filterM pfn xsl- return $ toGVal filtered--printfG :: String -> [GVal m] -> String-printfG fmt args = printfa fmt (fmap P args)---- | Create an execution context for runGingerT.--- Takes a lookup function, which returns ginger values into the carrier monad--- based on a lookup key, and a writer function (outputting HTML by whatever--- means the carrier monad provides, e.g. @putStr@ for @IO@, or @tell@ for--- @Writer@s).-makeContextM' :: (Monad m, Functor m)- => (VarName -> Run m h (GVal (Run m h)))- -> (h -> m ())- -> (GVal (Run m h) -> h)- -> GingerContext m h-makeContextM' lookupFn writeFn encodeFn =- GingerContext- { contextLookup = lookupFn- , contextWrite = liftRun2 writeFn- , contextEncode = encodeFn- }--liftLookup :: (Monad m, ToGVal (Run m h) v) => (VarName -> m v) -> VarName -> Run m h (GVal (Run m h))-liftLookup f k = do- v <- liftRun $ f k- return . toGVal $ v---- | Create an execution context for runGinger.--- The argument is a lookup function that maps top-level context keys to ginger--- values. 'makeContext' is a specialized version of 'makeContextM', targeting--- the 'Writer' 'Html' monad (which is what is used for the non-monadic--- template interpreter 'runGinger').------ The type of the lookup function may look intimidating, but in most cases,--- marshalling values from Haskell to Ginger is a matter of calling 'toGVal'--- on them, so the 'GVal (Run (Writer Html))' part can usually be ignored.--- See the 'Text.Ginger.GVal' module for details.-makeContext' :: Monoid h- => (VarName -> GVal (Run (Writer h) h))- -> (GVal (Run (Writer h) h) -> h)- -> GingerContext (Writer h) h-makeContext' lookupFn encodeFn =- makeContextM'- (return . lookupFn)- tell- encodeFn--{-#DEPRECATED makeContext "Compatibility alias for makeContextHtml" #-}-makeContext :: (VarName -> GVal (Run (Writer Html) Html))- -> GingerContext (Writer Html) Html-makeContext = makeContextHtml--{-#DEPRECATED makeContextM "Compatibility alias for makeContextHtmlM" #-}-makeContextM :: (Monad m, Functor m)- => (VarName -> Run m Html (GVal (Run m Html)))- -> (Html -> m ())- -> GingerContext m Html-makeContextM = makeContextHtmlM--makeContextHtml :: (VarName -> GVal (Run (Writer Html) Html))- -> GingerContext (Writer Html) Html-makeContextHtml l = makeContext' l toHtml--makeContextHtmlM :: (Monad m, Functor m)- => (VarName -> Run m Html (GVal (Run m Html)))- -> (Html -> m ())- -> GingerContext m Html-makeContextHtmlM l w = makeContextM' l w toHtml--makeContextText :: (VarName -> GVal (Run (Writer Text) Text))- -> GingerContext (Writer Text) Text-makeContextText l = makeContext' l asText--makeContextTextM :: (Monad m, Functor m)- => (VarName -> Run m Text (GVal (Run m Text)))- -> (Text -> m ())- -> GingerContext m Text-makeContextTextM l w = makeContextM' l w asText+defaultScope :: forall m h. Monad m => [(Text, GVal (Run m h))]+defaultScope =+ [ ("raw", fromFunction gfnRawHtml)+ , ("abs", fromFunction . unaryNumericFunc 0 $ Prelude.abs)+ , ("any", fromFunction gfnAny)+ , ("all", fromFunction gfnAll)+ -- TODO: batch+ , ("capitalize", fromFunction . variadicStringFunc $ mconcat . Prelude.map capitalize)+ , ("ceil", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.ceiling)+ , ("center", fromFunction gfnCenter)+ , ("concat", fromFunction . variadicStringFunc $ mconcat)+ , ("contains", fromFunction gfnContains)+ , ("d", fromFunction gfnDefault)+ , ("default", fromFunction gfnDefault)+ , ("difference", fromFunction . variadicNumericFunc 0 $ difference)+ , ("e", fromFunction gfnEscape)+ , ("equals", fromFunction gfnEquals)+ , ("escape", fromFunction gfnEscape)+ , ("filesizeformat", fromFunction gfnFileSizeFormat)+ , ("filter", fromFunction gfnFilter)+ , ("floor", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.floor)+ , ("greater", fromFunction gfnGreater)+ , ("greaterEquals", fromFunction gfnGreaterEquals)+ , ("int", fromFunction . unaryFunc $ toGVal . fmap (Prelude.truncate :: Scientific -> Int) . asNumber)+ , ("int_ratio", fromFunction . variadicNumericFunc 1 $ fromIntegral . intRatio . Prelude.map Prelude.floor)+ , ("iterable", fromFunction . unaryFunc $ toGVal . (\x -> isList x || isDict x))+ , ("length", fromFunction . unaryFunc $ toGVal . length)+ , ("less", fromFunction gfnLess)+ , ("lessEquals", fromFunction gfnLessEquals)+ , ("modulo", fromFunction . variadicNumericFunc 1 $ fromIntegral . modulo . Prelude.map Prelude.floor)+ , ("nequals", fromFunction gfnNEquals)+ , ("num", fromFunction . unaryFunc $ toGVal . asNumber)+ , ("printf", fromFunction gfnPrintf)+ , ("product", fromFunction . variadicNumericFunc 1 $ Prelude.product)+ , ("ratio", fromFunction . variadicNumericFunc 1 $ Scientific.fromFloatDigits . ratio . Prelude.map Scientific.toRealFloat)+ , ("replace", fromFunction gfnReplace)+ , ("round", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.round)+ , ("show", fromFunction . unaryFunc $ fromString . show)+ , ("slice", fromFunction gfnSlice)+ , ("sort", fromFunction gfnSort)+ , ("str", fromFunction . unaryFunc $ toGVal . asText)+ , ("sum", fromFunction . variadicNumericFunc 0 $ Prelude.sum)+ , ("truncate", fromFunction . unaryNumericFunc 0 $ Prelude.fromIntegral . Prelude.truncate)+ , ("urlencode", fromFunction gfnUrlEncode)+ ] -- | Purely expand a Ginger template. The underlying carrier monad is 'Writer' -- 'h', which is used to collect the output and render it into a 'h'@@ -631,17 +143,6 @@ runGingerT :: (ToGVal (Run m h) h, Monoid h, Monad m, Functor m) => GingerContext m h -> Template -> m () runGingerT context tpl = runReaderT (evalStateT (runTemplate tpl) (defRunState tpl)) context --- | Internal type alias for our template-runner monad stack.-type Run m h = StateT (RunState m h) (ReaderT (GingerContext m h) m)---- | Lift a value from the host monad @m@ into the 'Run' monad.-liftRun :: Monad m => m a -> Run m h a-liftRun = lift . lift---- | Lift a function from the host monad @m@ into the 'Run' monad.-liftRun2 :: Monad m => (a -> m b) -> a -> Run m h b-liftRun2 f x = liftRun $ f x- -- | Find the effective base template of an inheritance chain baseTemplate :: Template -> Template baseTemplate t =@@ -677,7 +178,7 @@ tpl <- gets rsCurrentTemplate let blockMay = resolveBlock blockName tpl case blockMay of- Nothing -> fail $ "Block " <> (Text.unpack blockName) <> " not defined"+ Nothing -> fail $ "Block " <> Text.unpack blockName <> " not defined" Just block -> return block where resolveBlock :: VarName -> Template -> Maybe Block@@ -748,7 +249,7 @@ , "first" ~> (index == 0) , "last" ~> (Prelude.succ index == numItems) , "length" ~> numItems- , "cycle" ~> (fromFunction $ cycle index)+ , "cycle" ~> fromFunction (cycle index) ]) { asFunction = Just loop } case varNameIndex of@@ -775,7 +276,7 @@ f args = withLocalState . local (\c -> c { contextWrite = appendCapture }) $ do clearCapture- forM (HashMap.toList matchedArgs) (uncurry setVar)+ forM_ (HashMap.toList matchedArgs) (uncurry setVar) setVar "varargs" . toGVal $ positionalArgs setVar "kwargs" . toGVal $ namedArgs runStatement body@@ -836,7 +337,7 @@ runExpression (StringLiteralE str) = return . toGVal $ str runExpression (NumberLiteralE n) = return . toGVal $ n runExpression (BoolLiteralE b) = return . toGVal $ b-runExpression (NullLiteralE) = return def+runExpression NullLiteralE = return def runExpression (VarE key) = getVar key runExpression (ListE xs) = toGVal <$> forM xs runExpression runExpression (ObjectE xs) = do@@ -858,8 +359,7 @@ Just f -> f args runExpression (LambdaE argNames body) = do let fn args = withLocalScope $ do- forM (Prelude.zip argNames (fmap snd args)) $ \(argName, arg) ->- setVar argName arg+ forM_ (Prelude.zip argNames (fmap snd args)) $ uncurry setVar runExpression body return $ fromFunction fn runExpression (TernaryE condition yes no) = do@@ -874,3 +374,13 @@ e <- asks contextEncode p <- asks contextWrite p . e $ src++defRunState :: forall m h. (Monoid h, Monad m) => Template -> RunState m h+defRunState tpl =+ RunState+ { rsScope = HashMap.fromList defaultScope+ , rsCapture = mempty+ , rsCurrentTemplate = tpl+ , rsCurrentBlockName = Nothing+ }+
+ src/Text/Ginger/Run/Builtins.hs view
@@ -0,0 +1,366 @@+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TupleSections #-}+{-#LANGUAGE TypeSynonymInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE ScopedTypeVariables #-}+module Text.Ginger.Run.Builtins+where++import Prelude ( (.), ($), (==), (/=)+ , (>), (<), (>=), (<=)+ , (+), (-), (*), (/), div, (**), (^)+ , (||), (&&)+ , (++)+ , Show, show+ , undefined, otherwise+ , Maybe (..)+ , Bool (..)+ , Int, Integer, String+ , fromIntegral, floor, round+ , not+ , show+ , uncurry+ , seq+ , fst, snd+ , maybe+ , Either (..)+ , id+ , flip+ )+import qualified Prelude+import Data.Maybe (fromMaybe, isJust, isNothing)+import qualified Data.List as List+import Text.Ginger.AST+import Text.Ginger.Html+import Text.Ginger.GVal+import Text.Ginger.Run.Type+import Text.Ginger.Run.FuncUtils+import Text.Printf+import Text.PrintfA++import Data.Text (Text)+import Data.String (fromString)+import qualified Data.Text as Text+import qualified Data.ByteString.UTF8 as UTF8+import Control.Monad+import Control.Monad.Identity+import Control.Monad.Writer+import Control.Monad.Reader+import Control.Monad.State+import Control.Applicative+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import Data.Scientific (Scientific, formatScientific, FPFormat (Fixed) )+import qualified Data.Scientific as Scientific+import Data.Default (def)+import Safe (readMay, lastDef, headMay)+import Network.HTTP.Types (urlEncode)+import Debug.Trace (trace)+import Data.List (lookup, zipWith, unzip)++gfnRawHtml :: Monad m => Function (Run m h)+gfnRawHtml = unaryFunc (toGVal . unsafeRawHtml . asText)++gfnUrlEncode :: Monad m => Function (Run m h)+gfnUrlEncode =+ unaryFunc+ ( toGVal+ . Text.pack+ . UTF8.toString+ . urlEncode True+ . UTF8.fromString+ . Text.unpack+ . asText+ )++gfnDefault :: Monad m => Function (Run m h)+gfnDefault [] = return def+gfnDefault ((_, x):xs)+ | asBoolean x = return x+ | otherwise = gfnDefault xs++gfnEscape :: Monad m => Function (Run m h)+gfnEscape = return . toGVal . html . mconcat . fmap (asText . snd)++gfnAny :: Monad m => Function (Run m h)+gfnAny xs = return . toGVal $ Prelude.any (asBoolean . snd) xs++gfnAll :: Monad m => Function (Run m h)+gfnAll xs = return . toGVal $ Prelude.all (asBoolean . snd) xs++gfnEquals :: Monad m => Function (Run m h)+gfnEquals [] = return $ toGVal True+gfnEquals [x] = return $ toGVal True+gfnEquals (x:xs) =+ return . toGVal $ Prelude.all ((snd x `looseEquals`) . snd) xs++gfnNEquals :: Monad m => Function (Run m h)+gfnNEquals [] = return $ toGVal True+gfnNEquals [x] = return $ toGVal True+gfnNEquals (x:xs) =+ return . toGVal $ Prelude.any (not . (snd x `looseEquals`) . snd) xs++gfnContains :: Monad m => Function (Run m h)+gfnContains [] = return $ toGVal False+gfnContains (list:elems) =+ let rawList = fromMaybe [] . asList . snd $ list+ rawElems = fmap snd elems+ e `isInList` xs = Prelude.any (looseEquals e) xs+ es `areInList` xs = Prelude.all (`isInList` xs) es+ in return . toGVal $ rawElems `areInList` rawList++looseEquals :: GVal (Run m h) -> GVal (Run m h) -> Bool+looseEquals a b+ | isJust (asFunction a) || isJust (asFunction b) = False+ | isJust (asList a) /= isJust (asList b) = False+ | isJust (asDictItems a) /= isJust (asDictItems b) = False+ -- Both numbers: do numeric comparison+ | isJust (asNumber a) && isJust (asNumber b) = asNumber a == asNumber b+ -- If either is NULL, the other must be falsy+ | isNull a || isNull b = asBoolean a == asBoolean b+ | otherwise = asText a == asText b++gfnLess :: Monad m => Function (Run m h)+gfnLess [] = return . toGVal $ False+gfnLess xs' =+ let xs = fmap snd xs'+ in return . toGVal $+ Prelude.all (== Just True) (Prelude.zipWith less xs (Prelude.tail xs))++gfnGreater :: Monad m => Function (Run m h)+gfnGreater [] = return . toGVal $ False+gfnGreater xs' =+ let xs = fmap snd xs'+ in return . toGVal $+ Prelude.all (== Just True) (Prelude.zipWith greater xs (Prelude.tail xs))++gfnLessEquals :: Monad m => Function (Run m h)+gfnLessEquals [] = return . toGVal $ False+gfnLessEquals xs' =+ let xs = fmap snd xs'+ in return . toGVal $+ Prelude.all (== Just True) (Prelude.zipWith lessEq xs (Prelude.tail xs))++gfnGreaterEquals :: Monad m => Function (Run m h)+gfnGreaterEquals [] = return . toGVal $ False+gfnGreaterEquals xs' =+ let xs = fmap snd xs'+ in return . toGVal $+ Prelude.all (== Just True) (Prelude.zipWith greaterEq xs (Prelude.tail xs))++less :: Monad m => GVal (Run m h) -> GVal (Run m h) -> Maybe Bool+less a b = (<) <$> asNumber a <*> asNumber b++greater :: Monad m => GVal (Run m h) -> GVal (Run m h) -> Maybe Bool+greater a b = (>) <$> asNumber a <*> asNumber b++lessEq :: Monad m => GVal (Run m h) -> GVal (Run m h) -> Maybe Bool+lessEq a b = (<=) <$> asNumber a <*> asNumber b++greaterEq :: Monad m => GVal (Run m h) -> GVal (Run m h) -> Maybe Bool+greaterEq a b = (>=) <$> asNumber a <*> asNumber b++difference :: Prelude.Num a => [a] -> a+difference (x:xs) = x - Prelude.sum xs+difference [] = 0++ratio :: (Show a, Prelude.Fractional a, Prelude.Num a) => [a] -> a+ratio (x:xs) = x / Prelude.product xs+ratio [] = 0++intRatio :: (Prelude.Integral a, Prelude.Num a) => [a] -> a+intRatio (x:xs) = x `Prelude.div` Prelude.product xs+intRatio [] = 0++modulo :: (Prelude.Integral a, Prelude.Num a) => [a] -> a+modulo (x:xs) = x `Prelude.mod` Prelude.product xs+modulo [] = 0++capitalize :: Text -> Text+capitalize txt = Text.toUpper (Text.take 1 txt) <> Text.drop 1 txt++gfnCenter :: Monad m => Function (Run m h)+gfnCenter [] = gfnCenter [(Nothing, toGVal ("" :: Text))]+gfnCenter [x] = gfnCenter [x, (Nothing, toGVal (80 :: Int))]+gfnCenter [x,y] = gfnCenter [x, y, (Nothing, toGVal (" " :: Text))]+gfnCenter ((_, s):(_, w):(_, pad):_) =+ return . toGVal $ center (asText s) (fromMaybe 80 $ Prelude.truncate <$> asNumber w) (asText pad)++gfnSlice :: Monad m => Function (Run m h)+gfnSlice args =+ let argValues =+ extractArgsDefL+ [ ("slicee", def)+ , ("start", def)+ , ("length", def)+ ]+ args+ in case argValues of+ Right [slicee, startPos, length] -> do+ let startInt :: Int+ startInt = maybe 0 Prelude.round . asNumber $ startPos++ lengthInt :: Maybe Int+ lengthInt = fmap Prelude.round . asNumber $ length++ slice :: [a] -> Int -> Maybe Int -> [a]+ slice xs start Nothing =+ Prelude.drop start xs+ slice xs start (Just length) =+ Prelude.take length . Prelude.drop start $ xs+ case asDictItems slicee of+ Just items -> do+ let slicedItems = slice items startInt lengthInt+ return $ dict slicedItems+ Nothing -> do+ let items = fromMaybe [] $ asList slicee+ slicedItems = slice items startInt lengthInt+ return $ toGVal slicedItems+ _ -> fail "Invalid arguments to 'slice'"++gfnReplace :: Monad m => Function (Run m h)+gfnReplace args =+ let argValues =+ extractArgsDefL+ [ ("str", def)+ , ("search", def)+ , ("replace", def)+ ]+ args+ in case argValues of+ Right [strG, searchG, replaceG] -> do+ let str = asText strG+ search = asText searchG+ replace = asText replaceG+ return . toGVal $ Text.replace search replace str+ _ -> fail "Invalid arguments to 'replace'"++gfnSort :: Monad m => Function (Run m h)+gfnSort args = do+ let parsedArgs = extractArgsDefL+ [ ("sortee", def)+ , ("by", def)+ , ("reverse", toGVal False)+ ]+ args+ (sortee, sortKey, sortReverse) <- case parsedArgs of+ Right [sortee, sortKeyG, reverseG] ->+ return ( sortee+ , asText sortKeyG+ , asBoolean reverseG+ )+ _ ->+ fail "Invalid args to sort()"+ let baseComparer :: GVal (Run m h) -> GVal (Run m h) -> Prelude.Ordering+ baseComparer a b = Prelude.compare (asText a) (asText b)+ extractKey :: Text -> GVal (Run m h) -> GVal (Run m h)+ extractKey k g = fromMaybe def $ do+ l <- asLookup g+ l k+ if isDict sortee+ then do+ let comparer' :: (Text, GVal (Run m h)) -> (Text, GVal (Run m h)) -> Prelude.Ordering+ comparer' = case sortKey of+ "" -> \(_, a) (_, b) -> baseComparer a b+ "__key" -> \(a, _) (b, _) -> Prelude.compare a b+ k -> \(_, a) (_, b) ->+ baseComparer+ (extractKey k a) (extractKey k b)+ comparer =+ if sortReverse+ then flip comparer'+ else comparer'+ return . toGVal $ List.sortBy comparer (fromMaybe [] $ asDictItems sortee)+ else do+ let comparer' :: GVal (Run m h) -> GVal (Run m h) -> Prelude.Ordering+ comparer' = case sortKey of+ "" ->+ baseComparer+ k -> \a b ->+ baseComparer+ (extractKey k a) (extractKey k b)+ let comparer =+ if sortReverse+ then flip comparer'+ else comparer'+ return . toGVal $ List.sortBy comparer (fromMaybe [] $ asList sortee)++center :: Text -> Prelude.Int -> Text -> Text+center str width pad =+ if Text.length str Prelude.>= width+ then str+ else paddingL <> str <> paddingR+ where+ chars = width - Text.length str+ charsL = chars `div` 2+ charsR = chars - charsL+ repsL = Prelude.succ charsL `div` Text.length pad+ paddingL = Text.take charsL . Text.replicate repsL $ pad+ repsR = Prelude.succ charsR `div` Text.length pad+ paddingR = Text.take charsR . Text.replicate repsR $ pad++gfnFileSizeFormat :: Monad m => Function (Run m h)+gfnFileSizeFormat [(_, sizeG)] =+ gfnFileSizeFormat [(Nothing, sizeG), (Nothing, def)]+gfnFileSizeFormat [(_, sizeG), (_, binaryG)] = do+ let sizeM = Prelude.round <$> asNumber sizeG+ binary = asBoolean binaryG+ Prelude.maybe+ (return def)+ (return . toGVal . formatFileSize binary)+ sizeM+gfnFileSizeFormat _ = return def++formatFileSize :: Bool -> Integer -> String+formatFileSize binary size =+ let units =+ if binary+ then+ [ (1, "B")+ , (1024, "kiB")+ , (1024 ^ 2, "MiB")+ , (1024 ^ 3, "GiB")+ , (1024 ^ 4, "TiB")+ , (1024 ^ 5, "PiB")+ ]+ else+ [ (1, "B")+ , (1000, "kB")+ , (1000000, "MB")+ , (1000000000, "GB")+ , (1000000000000, "TB")+ , (1000000000000000, "PB")+ ]+ (divisor, unitName) =+ lastDef (1, "B") [ (d, u) | (d, u) <- units, d <= size ]+ dividedSize :: Scientific+ dividedSize = fromIntegral size / fromIntegral divisor+ formattedSize =+ if Scientific.isInteger dividedSize+ then formatScientific Fixed (Just 0) dividedSize+ else formatScientific Fixed (Just 1) dividedSize+ in formattedSize ++ " " ++ unitName++gfnPrintf :: Monad m => Function (Run m h)+gfnPrintf [] = return def+gfnPrintf [(_, fmtStrG)] = return fmtStrG+gfnPrintf ((_, fmtStrG):args) = do+ return . toGVal $ printfG fmtStr (fmap snd args)+ where+ fmtStr = Text.unpack $ asText fmtStrG++gfnFilter :: Monad m => Function (Run m h)+gfnFilter [] = return def+gfnFilter [(_, xs)] = return xs+gfnFilter ((_, xs):(_, p):args) = do+ pfnG <- maybe (fail "Not a function") return (asFunction p)+ let pfn x = asBoolean <$> pfnG ((Nothing, x):args)+ xsl = fromMaybe [] (asList xs)+ filtered <- filterM pfn xsl+ return $ toGVal filtered++printfG :: String -> [GVal m] -> String+printfG fmt args = printfa fmt (fmap P args)+
+ src/Text/Ginger/Run/FuncUtils.hs view
@@ -0,0 +1,153 @@+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TupleSections #-}+{-#LANGUAGE TypeSynonymInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE ScopedTypeVariables #-}+module Text.Ginger.Run.FuncUtils+where++import Prelude ( (.), ($), (==), (/=)+ , (>), (<), (>=), (<=)+ , (+), (-), (*), (/), div, (**), (^)+ , (||), (&&)+ , (++)+ , Show, show+ , undefined, otherwise+ , Maybe (..)+ , Bool (..)+ , Int, Integer, String+ , fromIntegral, floor, round+ , not+ , show+ , uncurry+ , seq+ , fst, snd+ , maybe+ , Either (..)+ , id+ )+import qualified Prelude+import Data.Maybe (fromMaybe, isJust)+import qualified Data.List as List+import Text.Ginger.AST+import Text.Ginger.Html+import Text.Ginger.GVal+import Text.Ginger.Run.Type+import Text.Printf+import Text.PrintfA+import Data.Scientific (formatScientific)++import Data.Text (Text)+import Data.String (fromString)+import qualified Data.Text as Text+import qualified Data.ByteString.UTF8 as UTF8+import Control.Monad+import Control.Monad.Identity+import Control.Monad.Writer+import Control.Monad.Reader+import Control.Monad.State+import Control.Applicative+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import Data.Scientific (Scientific)+import Data.Scientific as Scientific+import Data.Default (def)+import Safe (readMay, lastDef, headMay)+import Network.HTTP.Types (urlEncode)+import Debug.Trace (trace)+import Data.Maybe (isNothing)+import Data.List (lookup, zipWith, unzip)++unaryFunc :: forall m h. (Monad m) => (GVal (Run m h) -> GVal (Run m h)) -> Function (Run m h)+unaryFunc f [] = return def+unaryFunc f ((_, x):[]) = return (f x)++ignoreArgNames :: ([a] -> b) -> ([(c, a)] -> b)+ignoreArgNames f args = f (Prelude.map snd args)++variadicNumericFunc :: Monad m => Scientific -> ([Scientific] -> Scientific) -> [(Maybe Text, GVal (Run m h))] -> Run m h (GVal (Run m h))+variadicNumericFunc zero f args =+ return . toGVal . f $ args'+ where+ args' :: [Scientific]+ args' = Prelude.map (fromMaybe zero . asNumber . snd) args++unaryNumericFunc :: Monad m => Scientific -> (Scientific -> Scientific) -> [(Maybe Text, GVal (Run m h))] -> Run m h (GVal (Run m h))+unaryNumericFunc zero f args =+ return . toGVal . f $ args'+ where+ args' :: Scientific+ args' = case args of+ [] -> 0+ (arg:_) -> fromMaybe zero . asNumber . snd $ arg++variadicStringFunc :: Monad m => ([Text] -> Text) -> [(Maybe Text, GVal (Run m h))] -> Run m h (GVal (Run m h))+variadicStringFunc f args =+ return . toGVal . f $ args'+ where+ args' :: [Text]+ args' = Prelude.map (asText . snd) args++-- | Match args according to a given arg spec, Python style.+-- The return value is a triple of @(matched, args, kwargs, unmatchedNames)@,+-- where @matches@ is a hash map of named captured arguments, args is a list of+-- remaining unmatched positional arguments, kwargs is a list of remaining+-- unmatched named arguments, and @unmatchedNames@ contains the argument names+-- that haven't been matched.+extractArgs :: [Text] -> [(Maybe Text, a)] -> (HashMap Text a, [a], HashMap Text a, [Text])+extractArgs argNames args =+ let (matchedPositional, argNames', args') = matchPositionalArgs argNames args+ (matchedKeyword, argNames'', args'') = matchKeywordArgs argNames' args'+ unmatchedPositional = [ a | (Nothing, a) <- args'' ]+ unmatchedKeyword = HashMap.fromList [ (k, v) | (Just k, v) <- args'' ]+ in ( HashMap.fromList (matchedPositional ++ matchedKeyword)+ , unmatchedPositional+ , unmatchedKeyword+ , argNames''+ )+ where+ matchPositionalArgs :: [Text] -> [(Maybe Text, a)] -> ([(Text, a)], [Text], [(Maybe Text, a)])+ matchPositionalArgs [] args = ([], [], args)+ matchPositionalArgs names [] = ([], names, [])+ matchPositionalArgs names@(n:ns) allArgs@((anm, arg):args)+ | Just n == anm || isNothing anm =+ let (matched, ns', args') = matchPositionalArgs ns args+ in ((n, arg):matched, ns', args')+ | otherwise = ([], names, allArgs)++ matchKeywordArgs :: [Text] -> [(Maybe Text, a)] -> ([(Text, a)], [Text], [(Maybe Text, a)])+ matchKeywordArgs [] args = ([], [], args)+ matchKeywordArgs names allArgs@((Nothing, arg):args) =+ let (matched, ns', args') = matchKeywordArgs names args+ in (matched, ns', (Nothing, arg):args')+ matchKeywordArgs names@(n:ns) args =+ case (lookup (Just n) args) of+ Nothing ->+ let (matched, ns', args') = matchKeywordArgs ns args+ in (matched, n:ns', args')+ Just v ->+ let args' = [ (k,v) | (k,v) <- args, k /= Just n ]+ (matched, ns', args'') = matchKeywordArgs ns args'+ in ((n,v):matched, ns', args'')++-- | Parse argument list into type-safe argument structure.+extractArgsT :: ([Maybe a] -> b) -> [Text] -> [(Maybe Text, a)] -> Either ([a], HashMap Text a, [Text]) b+extractArgsT f argNames args =+ let (matchedMap, freeArgs, freeKwargs, unmatched) = extractArgs argNames args+ in if List.null freeArgs && HashMap.null freeKwargs+ then Right (f $ fmap (\name -> HashMap.lookup name matchedMap) argNames)+ else Left (freeArgs, freeKwargs, unmatched)++-- | Parse argument list into flat list of matched arguments.+extractArgsL :: [Text] -> [(Maybe Text, a)] -> Either ([a], HashMap Text a, [Text]) [Maybe a]+extractArgsL = extractArgsT id++extractArgsDefL :: [(Text, a)] -> [(Maybe Text, a)] -> Either ([a], HashMap Text a, [Text]) [a]+extractArgsDefL argSpec args =+ let (names, defs) = unzip argSpec+ in injectDefaults defs <$> extractArgsL names args++injectDefaults :: [a] -> [Maybe a] -> [a]+injectDefaults = zipWith fromMaybe
+ src/Text/Ginger/Run/Type.hs view
@@ -0,0 +1,183 @@+{-#LANGUAGE FlexibleContexts #-}+{-#LANGUAGE FlexibleInstances #-}+{-#LANGUAGE OverloadedStrings #-}+{-#LANGUAGE TupleSections #-}+{-#LANGUAGE TypeSynonymInstances #-}+{-#LANGUAGE MultiParamTypeClasses #-}+{-#LANGUAGE ScopedTypeVariables #-}+module Text.Ginger.Run.Type+( GingerContext (..)+, makeContext+, makeContextM+, makeContext'+, makeContextM'+, makeContextHtml+, makeContextHtmlM+, makeContextText+, makeContextTextM+, liftRun+, liftRun2+, Run (..)+, RunState (..)+)+where++import Prelude ( (.), ($), (==), (/=)+ , (>), (<), (>=), (<=)+ , (+), (-), (*), (/), div, (**), (^)+ , (||), (&&)+ , (++)+ , Show, show+ , undefined, otherwise+ , Maybe (..)+ , Bool (..)+ , Int, Integer, String+ , fromIntegral, floor, round+ , not+ , show+ , uncurry+ , seq+ , fst, snd+ , maybe+ , Either (..)+ , id+ )+import qualified Prelude+import Data.Maybe (fromMaybe, isJust)+import qualified Data.List as List+import Text.Ginger.AST+import Text.Ginger.Html+import Text.Ginger.GVal+import Text.Printf+import Text.PrintfA+import Data.Scientific (formatScientific)++import Data.Text (Text)+import Data.String (fromString)+import qualified Data.Text as Text+import qualified Data.ByteString.UTF8 as UTF8+import Control.Monad+import Control.Monad.Identity+import Control.Monad.Writer+import Control.Monad.Reader+import Control.Monad.State+import Control.Applicative+import qualified Data.HashMap.Strict as HashMap+import Data.HashMap.Strict (HashMap)+import Data.Scientific (Scientific)+import Data.Scientific as Scientific+import Data.Default (def)+import Safe (readMay, lastDef, headMay)+import Network.HTTP.Types (urlEncode)+import Debug.Trace (trace)+import Data.Maybe (isNothing)+import Data.List (lookup, zipWith, unzip)++-- | Execution context. Determines how to look up variables from the+-- environment, and how to write out template output.+data GingerContext m h+ = GingerContext+ { contextLookup :: VarName -> Run m h (GVal (Run m h))+ , contextWrite :: h -> Run m h ()+ , contextEncode :: GVal (Run m h) -> h+ }++contextWriteEncoded :: GingerContext m h -> GVal (Run m h) -> Run m h ()+contextWriteEncoded context =+ contextWrite context . contextEncode context++-- | Create an execution context for runGingerT.+-- Takes a lookup function, which returns ginger values into the carrier monad+-- based on a lookup key, and a writer function (outputting HTML by whatever+-- means the carrier monad provides, e.g. @putStr@ for @IO@, or @tell@ for+-- @Writer@s).+makeContextM' :: (Monad m, Functor m)+ => (VarName -> Run m h (GVal (Run m h)))+ -> (h -> m ())+ -> (GVal (Run m h) -> h)+ -> GingerContext m h+makeContextM' lookupFn writeFn encodeFn =+ GingerContext+ { contextLookup = lookupFn+ , contextWrite = liftRun2 writeFn+ , contextEncode = encodeFn+ }++liftLookup :: (Monad m, ToGVal (Run m h) v) => (VarName -> m v) -> VarName -> Run m h (GVal (Run m h))+liftLookup f k = do+ v <- liftRun $ f k+ return . toGVal $ v++-- | Create an execution context for runGinger.+-- The argument is a lookup function that maps top-level context keys to ginger+-- values. 'makeContext' is a specialized version of 'makeContextM', targeting+-- the 'Writer' 'Html' monad (which is what is used for the non-monadic+-- template interpreter 'runGinger').+--+-- The type of the lookup function may look intimidating, but in most cases,+-- marshalling values from Haskell to Ginger is a matter of calling 'toGVal'+-- on them, so the 'GVal (Run (Writer Html))' part can usually be ignored.+-- See the 'Text.Ginger.GVal' module for details.+makeContext' :: Monoid h+ => (VarName -> GVal (Run (Writer h) h))+ -> (GVal (Run (Writer h) h) -> h)+ -> GingerContext (Writer h) h+makeContext' lookupFn encodeFn =+ makeContextM'+ (return . lookupFn)+ tell+ encodeFn++{-#DEPRECATED makeContext "Compatibility alias for makeContextHtml" #-}+makeContext :: (VarName -> GVal (Run (Writer Html) Html))+ -> GingerContext (Writer Html) Html+makeContext = makeContextHtml++{-#DEPRECATED makeContextM "Compatibility alias for makeContextHtmlM" #-}+makeContextM :: (Monad m, Functor m)+ => (VarName -> Run m Html (GVal (Run m Html)))+ -> (Html -> m ())+ -> GingerContext m Html+makeContextM = makeContextHtmlM++makeContextHtml :: (VarName -> GVal (Run (Writer Html) Html))+ -> GingerContext (Writer Html) Html+makeContextHtml l = makeContext' l toHtml++makeContextHtmlM :: (Monad m, Functor m)+ => (VarName -> Run m Html (GVal (Run m Html)))+ -> (Html -> m ())+ -> GingerContext m Html+makeContextHtmlM l w = makeContextM' l w toHtml++makeContextText :: (VarName -> GVal (Run (Writer Text) Text))+ -> GingerContext (Writer Text) Text+makeContextText l = makeContext' l asText++makeContextTextM :: (Monad m, Functor m)+ => (VarName -> Run m Text (GVal (Run m Text)))+ -> (Text -> m ())+ -> GingerContext m Text+makeContextTextM l w = makeContextM' l w asText+++data RunState m h+ = RunState+ { rsScope :: HashMap VarName (GVal (Run m h))+ , rsCapture :: h+ , rsCurrentTemplate :: Template -- the template we are currently running+ , rsCurrentBlockName :: Maybe Text -- the name of the innermost block we're currently in+ }++-- | Internal type alias for our template-runner monad stack.+type Run m h = StateT (RunState m h) (ReaderT (GingerContext m h) m)++-- | Lift a value from the host monad @m@ into the 'Run' monad.+liftRun :: Monad m => m a -> Run m h a+liftRun = lift . lift++-- | Lift a function from the host monad @m@ into the 'Run' monad.+liftRun2 :: Monad m => (a -> m b) -> a -> Run m h b+liftRun2 f x = liftRun $ f x++