Optimizer.hs

{-#LANGUAGE GeneralizedNewtypeDeriving #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE OverloadedStrings #-}
{-#LANGUAGE ScopedTypeVariables #-}
{-#LANGUAGE FlexibleContexts #-}
-- | A syntax tree optimizer
module Text.Ginger.Optimizer
( Optimizable (..) )
where

import Text.Ginger.AST
import Text.Ginger.GVal
import Text.Ginger.Run
import Control.Monad.Identity
import Data.Default
import Control.Monad.State (execState, evalState)
import Control.Monad.Writer (Writer, execWriter, tell)
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (fromMaybe)
import Control.Applicative
import Data.Text (Text)
import qualified Data.Aeson as JSON
import Data.Semigroup as Semigroup

class Optimizable a where
    optimize :: a -> a

instance Optimizable (Template a) where
    optimize = optimizeTemplate

instance Optimizable (Statement a) where
    optimize = optimizeStatement

instance Optimizable (Block a) where
    optimize = optimizeBlock

instance Optimizable (Macro a) where
    optimize = optimizeMacro

instance Optimizable (Expression a) where
    optimize = optimizeExpression

optimizeTemplate t =
    t { templateBody = optimize $ templateBody t
      , templateBlocks = optimize <$> templateBlocks t
      , templateParent = optimize <$> templateParent t
      }

--    = MultiS p [Statement a] -- ^ A sequence of multiple statements
--    | ScopedS p Statement a -- ^ Run wrapped statement in a local scope
--    | LiteralS p Html -- ^ Literal output (anything outside of any tag)
--    | InterpolationS p Expression a -- ^ {{ expression }}
--    | IfS p Expression a Statement a Statement a -- ^ {% if expression %}statement{% else %}statement{% endif %}
--    | ForS p (Maybe VarName) VarName Expression a Statement a -- ^ {% for index, varname in expression %}statement{% endfor %}
--    | SetVarS p VarName Expression a -- ^ {% set varname = expr %}
--    | DefMacroS p VarName Macro a -- ^ {% macro varname %}statements{% endmacro %}
--    | BlockRefS p VarName
--    | PreprocessedIncludeS p Template a -- ^ {% include "template" %}
--    | NullS p -- ^ The do-nothing statement (NOP)

optimizeStatement (MultiS p items) =
    case optimizeStatementList items of
        [] -> NullS p
        [x] -> x
        xs -> MultiS p xs
optimizeStatement (InterpolationS p e) =
    InterpolationS p (optimize e)
optimizeStatement s@(IfS p c t f) =
    let c' = optimize c
        t' = optimize t
        f' = optimize f
    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

optimizeMacro (Macro args body) = Macro args (optimize body)

optimizeStatementList =
    mergeLiterals .
    cullNulls .
    fmap optimize

cullNulls :: [Statement a] -> [Statement a]
cullNulls = filter (not . isNullS)
    where
        isNullS (NullS _) = True
        isNullS _ = False

mergeLiterals :: [Statement a] -> [Statement a]
mergeLiterals [] = []
mergeLiterals [x] = [x]
mergeLiterals (x@(LiteralS p1 a):y@(LiteralS p2 b):xs) = mergeLiterals $ (LiteralS p1 $ a <> b):xs
mergeLiterals (x:xs) = x:mergeLiterals xs


-- data Expression a
--     = StringLiteralE p Text -- ^ String literal expression: "foobar"
--     | NumberLiteralE p Scientific -- ^ Numeric literal expression: 123.4
--     | BoolLiteralE p Bool -- ^ Boolean literal expression: true
--     | NullLiteralE p -- ^ Literal null
--     | VarE p VarName -- ^ Variable reference: foobar
--     | ListE p [Expression a] -- ^ List construct: [ expr, expr, expr ]
--     | ObjectE p [(Expression a, Expression a)] -- ^ Object construct: { expr: expr, expr: expr, ... }
--     | MemberLookupE p Expression a Expression a -- ^ foo[bar] (also dot access)
--     | CallE p Expression a [(Maybe Text, Expression a)] -- ^ foo(bar=baz, quux)
--     | LambdaE p [Text] Expression a -- ^ (foo, bar) -> expr
--     | TernaryE p Expression a Expression a Expression a -- ^ expr ? expr : expr
--     deriving (Show)

data Purity = Pure | Impure
    deriving (Show, Eq, Enum, Read, Ord, Bounded)

bothPure :: Purity -> Purity -> Purity
bothPure Pure Pure = Pure
bothPure _ _ = Impure

instance Semigroup.Semigroup Purity where
    (<>) = bothPure

instance Monoid Purity where
    mempty = Pure
    mappend = (<>)

pureExpression :: Expression a -> Purity
pureExpression (StringLiteralE p _) = Pure
pureExpression (NumberLiteralE p _) = Pure
pureExpression (NullLiteralE p) = Pure
pureExpression (ListE p items) = mconcat . map pureExpression $ items
pureExpression (ObjectE p pairs) =
    mconcat [ bothPure (pureExpression k) (pureExpression v)
            | (k, v) <- pairs
            ]
pureExpression (LambdaE _ args body) = pureExpression body
pureExpression (TernaryE _ cond yes no) =
    pureExpression cond <> pureExpression yes <> pureExpression no
pureExpression (MemberLookupE _ k v) =
    pureExpression k <> pureExpression v
pureExpression (CallE _ (VarE _ name) args) =
    pureFunction name <> mconcat (map (pureExpression . snd) args)
pureExpression _ = Impure

pureFunction name
    | name `elem` pureFunctionNames = Pure
    | otherwise = Impure

pureFunctionNames =
    [ "raw"
    , "abs"
    , "any"
    , "all"
    , "capitalize"
    , "ceil"
    , "center"
    , "concat"
    , "contains"
    , "default"
    , "dictsort"
    , "difference"
    , "e"
    , "equals"
    , "escape"
    , "filesizeformat"
    , "filter"
    , "floor"
    , "format"
    , "greater"
    , "greaterEquals"
    , "int"
    , "int_ratio"
    , "iterable"
    , "length"
    , "less"
    , "lessEquals"
    , "modulo"
    , "nequals"
    , "num"
    , "product"
    , "ratio"
    , "replace"
    , "round"
    , "show"
    , "slice"
    , "sort"
    , "str"
    , "sum"
    , "truncate"
    , "urlencode"
    ]

optimizeExpression :: Expression a -> Expression a
optimizeExpression = preEvalExpression . expandConstExpressions . optimizeSubexpressions

preEvalExpression :: Expression a -> Expression a
preEvalExpression e = fromMaybe e $ do
    compileTimeEval e >>= gvalToExpression (annotation e)

gvalToExpression :: forall a m
                  . a -> GVal m -> Maybe (Expression a)
gvalToExpression p g =
    (jsonLiteral =<< asJSON g) <|>
    (ObjectE p <$> (recurseDict =<< asDictItems g)) <|>
    (ListE p <$> (mapM (gvalToExpression p) =<< asList g))
    where
        jsonLiteral :: JSON.Value -> Maybe (Expression a)
        jsonLiteral (JSON.Bool b) = Just (BoolLiteralE p b)
        jsonLiteral (JSON.String s) = Just (StringLiteralE p s)
        jsonLiteral (JSON.Null) = Just (NullLiteralE p)
        jsonLiteral (JSON.Number n) = Just (NumberLiteralE p n)
        jsonLiteral _ = Nothing
        recurseDict :: [(Text, GVal m)] -> Maybe [(Expression a, Expression a)]
        recurseDict = mapM $ \(key, val) -> do
            let key' = StringLiteralE p key
            val' <- gvalToExpression p val
            return (key', val')


expandConstExpressions :: Expression a -> Expression a
expandConstExpressions e@(TernaryE p c t f) =
    case compileTimeEval c of
        Just gv -> case asBoolean gv of
            True -> optimizeExpression t
            False -> optimizeExpression f
        _ -> e
expandConstExpressions e = e

optimizeSubexpressions (ListE p xs) = ListE p (map optimize xs)
optimizeSubexpressions (ObjectE p xs) = ObjectE p [ (optimize k, optimize v) | (k, v) <- xs ]
optimizeSubexpressions (MemberLookupE p k m) = MemberLookupE p (optimize k) (optimize m)
optimizeSubexpressions (CallE p f args) = CallE p (optimize f) [(n, optimize v) | (n, v) <- args]
optimizeSubexpressions (LambdaE p args body) = LambdaE p args (optimize body)
optimizeSubexpressions (TernaryE p c t f) = TernaryE p (optimize c) (optimize t) (optimize f)
optimizeSubexpressions e = e

isConstExpression :: Expression a -> Bool
isConstExpression (StringLiteralE p _) = True
isConstExpression (BoolLiteralE p _) = True
isConstExpression (NullLiteralE p) = True
isConstExpression (ListE p xs) = all isConstExpression xs
isConstExpression (ObjectE p xs) = all (\(k,v) -> isConstExpression k && isConstExpression v) xs
isConstExpression (MemberLookupE p k m) = isConstExpression k && isConstExpression m
isConstExpression e = False

compileTimeEval :: Expression p -> Maybe (GVal Identity)
compileTimeEval (StringLiteralE p s) = Just . toGVal $ s
compileTimeEval (NumberLiteralE p n) = Just . toGVal $ n
compileTimeEval (BoolLiteralE p b) = Just . toGVal $ b
compileTimeEval (NullLiteralE p) = Just def
compileTimeEval e = case pureExpression e of
    Pure -> do
        let tpl =
              -- We're erasing source code positions here,
              -- because we don't have any use for them anyway.
              Template
                  (InterpolationS () (fmap (const ()) e))
                  HashMap.empty
                  Nothing
        Just . toGVal . runCT $ tpl
    Impure -> Nothing

newtype Collected = Collected [GVal Identity]
    deriving (Semigroup.Semigroup, Monoid)

instance ToGVal m Collected where
    toGVal = collectedToGVal

collectedToGVal :: Collected -> GVal m
collectedToGVal (Collected []) = def
collectedToGVal (Collected (x:_)) = marshalGVal x

runCT :: Template () -> Collected
runCT = runGinger ctContext

ctContext :: GingerContext () (Writer Collected) Collected
ctContext = makeContext' ctLookup ctEncode Nothing

ctLookup :: VarName -> GVal m
ctLookup = const def

ctEncode :: GVal m -> Collected
ctEncode g = Collected [marshalGVal g]