module Text.Ginger.Run.Type
( GingerContext (..)
, makeContext
, makeContextM
, makeContext'
, makeContextM'
, makeContextHtml
, makeContextHtmlM
, makeContextText
, makeContextTextM
, easyContext
, ContextEncodable (..)
, liftRun
, liftRun2
, Run (..)
, RunState (..)
, Newlines (..)
, hoistContext
, hoistRun
, hoistNewlines
, hoistRunState
)
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.Char (isSpace)
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)
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
, contextNewlines :: Maybe (Newlines h)
}
hoistContext :: Monad m => (h -> t) -> (t -> h) -> GingerContext m h -> GingerContext m t
hoistContext fwd rev c =
GingerContext
{ contextLookup = \varName ->
marshalGValEx
(hoistRun fwd rev)
(hoistRun rev fwd) <$>
hoistRun fwd rev (contextLookup c varName)
, contextWrite = \val ->
hoistRun fwd rev (contextWrite c $ rev val)
, contextEncode = \gval ->
fwd .
contextEncode c .
marshalGValEx (hoistRun rev fwd) (hoistRun fwd rev) $
gval
, contextNewlines =
hoistNewlines fwd rev <$> contextNewlines c
}
contextWriteEncoded :: GingerContext m h -> GVal (Run m h) -> Run m h ()
contextWriteEncoded context =
contextWrite context . contextEncode context
easyContext :: (Monad m, ContextEncodable h, ToGVal (Run m h) v)
=> (h -> m ())
-> v
-> GingerContext m h
easyContext emit context =
makeContextM'
(\varName ->
return
(lookupLooseDef def
(toGVal varName)
(toGVal context)))
emit
encode
newlines
class ContextEncodable h where
encode :: forall m. GVal m -> h
newlines :: Maybe (Newlines h)
newlines = Nothing
instance ContextEncodable Text where
encode = asText
newlines = Just textNewlines
instance ContextEncodable Html where
encode = toHtml
newlines = Just htmlNewlines
makeContextM' :: (Monad m, Functor m)
=> (VarName -> Run m h (GVal (Run m h)))
-> (h -> m ())
-> (GVal (Run m h) -> h)
-> Maybe (Newlines h)
-> GingerContext m h
makeContextM' lookupFn writeFn encodeFn newlines =
GingerContext
{ contextLookup = lookupFn
, contextWrite = liftRun2 writeFn
, contextEncode = encodeFn
, contextNewlines = newlines
}
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
makeContext' :: Monoid h
=> (VarName -> GVal (Run (Writer h) h))
-> (GVal (Run (Writer h) h) -> h)
-> Maybe (Newlines h)
-> GingerContext (Writer h) h
makeContext' lookupFn =
makeContextM'
(return . lookupFn)
tell
makeContext :: (VarName -> GVal (Run (Writer Html) Html))
-> GingerContext (Writer Html) Html
makeContext = makeContextHtml
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 (Just htmlNewlines)
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 (Just htmlNewlines)
makeContextText :: (VarName -> GVal (Run (Writer Text) Text))
-> GingerContext (Writer Text) Text
makeContextText l = makeContext' l asText (Just textNewlines)
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 (Just textNewlines)
data Newlines h =
Newlines
{ splitLines :: h -> [h]
, joinLines :: [h] -> h
, stripIndent :: h -> h
, endsWithNewline :: h -> Bool
}
hoistNewlines :: (h -> t) -> (t -> h) -> Newlines h -> Newlines t
hoistNewlines fwd rev n =
Newlines
{ splitLines = List.map fwd . splitLines n . rev
, joinLines = fwd . joinLines n . List.map rev
, stripIndent = fwd . stripIndent n . rev
, endsWithNewline = endsWithNewline n . rev
}
textNewlines :: Newlines Text
textNewlines =
Newlines
{ splitLines = reNewline . Text.splitOn "\n"
, joinLines = mconcat
, stripIndent = Text.stripStart
, endsWithNewline = ("\n" `Text.isSuffixOf`)
}
htmlNewlines :: Newlines Html
htmlNewlines =
Newlines
{ splitLines = fmap unsafeRawHtml . splitLines textNewlines . htmlSource
, joinLines = unsafeRawHtml . joinLines textNewlines . fmap htmlSource
, stripIndent = unsafeRawHtml . stripIndent textNewlines . htmlSource
, endsWithNewline = endsWithNewline textNewlines . htmlSource
}
reNewline :: [Text] -> [Text]
reNewline [] = []
reNewline ("":[]) = []
reNewline (x:[]) = [x]
reNewline (x:"":[]) = [x <> "\n"]
reNewline (x:xs) = (x <> "\n") : reNewline xs
data RunState m h
= RunState
{ rsScope :: HashMap VarName (GVal (Run m h))
, rsCapture :: h
, rsCurrentTemplate :: Template
, rsCurrentBlockName :: Maybe Text
, rsIndentation :: Maybe [h]
, rsAtLineStart :: Bool
}
hoistRunState :: Monad m => (h -> t) -> (t -> h) -> RunState m h -> RunState m t
hoistRunState fwd rev rs =
RunState
{ rsScope = marshalGValEx (hoistRun fwd rev) (hoistRun rev fwd) <$> rsScope rs
, rsCapture = fwd $ rsCapture rs
, rsCurrentTemplate = rsCurrentTemplate rs
, rsCurrentBlockName = rsCurrentBlockName rs
, rsIndentation = fmap fwd <$> rsIndentation rs
, rsAtLineStart = rsAtLineStart rs
}
type Run m h = StateT (RunState m h) (ReaderT (GingerContext m h) m)
liftRun :: Monad m => m a -> Run m h a
liftRun = lift . lift
liftRun2 :: Monad m => (a -> m b) -> a -> Run m h b
liftRun2 f x = liftRun $ f x
hoistRun :: Monad m => (h -> t) -> (t -> h) -> Run m h a -> Run m t a
hoistRun fwd rev action = do
contextT <- ask
let contextH = hoistContext rev fwd contextT
stateT <- get
let stateH = hoistRunState rev fwd stateT
(x, stateH') <- lift . lift $ runReaderT (runStateT action stateH) contextH
let stateT' = hoistRunState fwd rev stateH'
put stateT'
return x