{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
module Text.DocTemplates.Internal
( renderTemplate
, TemplateMonad(..)
, Context(..)
, Val(..)
, ToContext(..)
, FromContext(..)
, TemplateTarget(..)
, Template(..)
, Variable(..)
) where
import Safe (lastMay, initDef)
import Data.Aeson (Value(..), ToJSON(..), FromJSON(..), Result(..), fromJSON)
import Control.Monad.Identity
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import qualified Data.Text.IO as TIO
import qualified Text.DocLayout as DL
import Data.String (IsString(..))
import Data.Data (Data)
import Data.Typeable (Typeable)
import GHC.Generics (Generic)
import Data.Text (Text)
import qualified Data.Map as M
import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
import Data.Scientific (floatingOrInteger)
import Data.List (intersperse, intercalate)
#if MIN_VERSION_base(4,11,0)
#else
import Data.Semigroup
#endif
data Template =
Interpolate Variable
| Conditional Variable Template Template
| Iterate Variable Template Template
| Nested Int Template
| Partial Template
| Literal Text
| Concat Template Template
| BreakingSpace
| Empty
deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)
instance Semigroup Template where
x <> Empty = x
Empty <> x = x
x <> y = Concat x y
instance Monoid Template where
mappend = (<>)
mempty = Empty
newtype Variable = Variable { unVariable :: [Text] }
deriving (Show, Read, Data, Typeable, Generic, Eq, Ord)
instance Semigroup Variable where
Variable xs <> Variable ys = Variable (xs <> ys)
instance Monoid Variable where
mempty = Variable []
mappend = (<>)
class Monoid a => TemplateTarget a where
fromText :: Text -> a
toText :: a -> Text
removeFinalNewline :: a -> a
isEmpty :: a -> Bool
indent :: Int -> a -> a
breakingSpace :: a
instance TemplateTarget Text where
fromText = id
toText = id
removeFinalNewline t =
case T.unsnoc t of
Just (t', '\n') -> t'
_ -> t
isEmpty = T.null
indent 0 = id
indent ind = T.intercalate ("\n" <> T.replicate ind " ") . T.lines
breakingSpace = " "
instance TemplateTarget TL.Text where
fromText = TL.fromStrict
toText = TL.toStrict
removeFinalNewline t =
case TL.unsnoc t of
Just (t', '\n') -> t'
_ -> t
isEmpty = TL.null
indent 0 = id
indent ind = TL.intercalate ("\n" <> TL.replicate (fromIntegral ind) " ")
. TL.lines
breakingSpace = " "
instance TemplateTarget String where
fromText = T.unpack
toText = T.pack
removeFinalNewline t =
case lastMay t of
Just '\n' -> initDef t t
_ -> t
isEmpty = null
indent 0 = id
indent ind = intercalate ("\n" <> replicate ind ' ') . lines
breakingSpace = " "
instance (DL.HasChars a, IsString a, Eq a)
=> TemplateTarget (DL.Doc a) where
fromText = DL.text . T.unpack
toText = T.pack . DL.foldrChar (:) [] . DL.render Nothing
removeFinalNewline = DL.chomp
indent = DL.nest
isEmpty (DL.Empty) = True
isEmpty (DL.Text 0 _) = True
isEmpty (DL.Concat x y) = isEmpty x && isEmpty y
isEmpty _ = False
breakingSpace = DL.space
newtype Context a = Context { unContext :: M.Map Text (Val a) }
deriving (Show, Semigroup, Monoid, Traversable, Foldable, Functor)
data Val a =
SimpleVal a
| ListVal [Val a]
| MapVal (Context a)
| NullVal
deriving (Show, Traversable, Foldable, Functor)
class ToContext a b where
toContext :: b -> Context a
toContext x = case toVal x of
MapVal c -> c
_ -> mempty
toVal :: b -> Val a
instance TemplateTarget a => ToContext a (Context a) where
toContext = id
toVal = MapVal
instance TemplateTarget a => ToContext a (Val a) where
toVal = id
instance TemplateTarget a => ToContext a a where
toVal = SimpleVal
instance {-# OVERLAPS #-} ToContext String String where
toVal t = SimpleVal t
instance ToContext a b => ToContext a [b] where
toVal = ListVal . map toVal
instance TemplateTarget a => ToContext a Value where
toContext x = case fromJSON x of
Success y -> y
Error _ -> mempty
toVal x = case fromJSON x of
Success y -> y
Error _ -> NullVal
instance TemplateTarget a => ToContext a Bool where
toVal True = SimpleVal $ fromText "true"
toVal False = NullVal
instance (TemplateTarget a, DL.HasChars a) => ToContext (DL.Doc a) a where
toVal t = SimpleVal $ DL.Text (DL.realLength t) t
class FromContext a b where
fromVal :: Val a -> Maybe b
lookupContext :: Text -> Context a -> Maybe b
lookupContext t (Context m) = M.lookup t m >>= fromVal
instance TemplateTarget a => FromContext a (Val a) where
fromVal = Just
instance TemplateTarget a => FromContext a a where
fromVal (SimpleVal x) = Just x
fromVal _ = Nothing
instance {-# OVERLAPS #-} FromContext String String where
fromVal (SimpleVal x) = Just x
fromVal _ = Nothing
instance FromContext a b => FromContext a [b] where
fromVal (ListVal xs) = mapM fromVal xs
fromVal x = sequence [fromVal x]
instance TemplateTarget a => FromJSON (Context a) where
parseJSON v = do
val <- parseJSON v
case val of
MapVal o -> return o
_ -> fail "Not a MapVal"
instance TemplateTarget a => FromJSON (Val a) where
parseJSON v =
case v of
Array vec -> ListVal <$> mapM parseJSON (V.toList vec)
String t -> return $ SimpleVal $ fromText t
Number n -> return $ SimpleVal $ fromText . fromString $
case floatingOrInteger n of
Left (r :: Double) -> show r
Right (i :: Integer) -> show i
Bool True -> return $ SimpleVal $ fromText "true"
Object o -> MapVal . Context . M.fromList . H.toList <$>
mapM parseJSON o
_ -> return NullVal
instance TemplateTarget a => ToJSON (Context a) where
toJSON (Context m) = toJSON m
instance TemplateTarget a => ToJSON (Val a) where
toJSON NullVal = Null
toJSON (MapVal m) = toJSON m
toJSON (ListVal xs) = toJSON xs
toJSON (SimpleVal t) = toJSON $ toText t
multiLookup :: [Text] -> Val a -> Val a
multiLookup [] x = x
multiLookup (t:vs) (MapVal (Context o)) =
case M.lookup t o of
Nothing -> NullVal
Just v' -> multiLookup vs v'
multiLookup _ _ = NullVal
resolveVariable :: TemplateTarget a => Variable -> Context a -> [a]
resolveVariable v ctx = resolveVariable' v (MapVal ctx)
resolveVariable' :: TemplateTarget a => Variable -> Val a -> [a]
resolveVariable' v val =
case multiLookup (unVariable v) val of
ListVal xs -> concatMap (resolveVariable' mempty) xs
SimpleVal t
| isEmpty t -> []
| otherwise -> [removeFinalNewline t]
MapVal _ -> [fromText "true"]
NullVal -> []
withVariable :: TemplateTarget a
=> Variable -> Context a -> (Context a -> a) -> [a]
withVariable v ctx f =
case multiLookup (unVariable v) (MapVal ctx) of
NullVal -> mempty
ListVal xs -> map (\iterval -> f $
Context $ M.insert "it" iterval $ unContext ctx) xs
val' -> [f $ Context $ M.insert "it" val' $ unContext ctx]
renderTemplate :: (TemplateTarget a, ToContext a b)
=> Template -> b -> a
renderTemplate t = renderTemp t . toContext
renderTemp :: forall a . TemplateTarget a
=> Template -> Context a -> a
renderTemp (Literal t) _ = fromText t
renderTemp BreakingSpace _ = breakingSpace
renderTemp (Interpolate v) ctx = mconcat $ resolveVariable v ctx
renderTemp (Conditional v ift elset) ctx =
let res = resolveVariable v ctx
in case res of
[] -> renderTemp elset ctx
_ -> renderTemp ift ctx
renderTemp (Iterate v t sep) ctx =
let sep' = renderTemp sep ctx
in mconcat . intersperse sep' $ withVariable v ctx (renderTemp t)
renderTemp (Nested n t) ctx = indent n $ renderTemp t ctx
renderTemp (Partial t) ctx = renderTemp t ctx
renderTemp (Concat t1 t2) ctx =
mappend (renderTemp t1 ctx) (renderTemp t2 ctx)
renderTemp Empty _ = mempty
class Monad m => TemplateMonad m where
getPartial :: FilePath -> m Text
instance TemplateMonad Identity where
getPartial _ = return mempty
instance TemplateMonad IO where
getPartial = TIO.readFile