{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module Text.Glabrous
(
Template (..)
, fromText
, readTemplateFile
, addTag
, tagsOf
, tagsRename
, isFinal
, toText
, toFinalText
, compress
, writeTemplateFile
, insertTemplate
, insertManyTemplates
, Context (..)
, initContext
, fromTagsList
, fromList
, fromTemplate
, setVariables
, deleteVariables
, variablesOf
, isSet
, unsetContext
, join
, readContextFile
, writeContextFile
, initContextFile
, process
, processWithDefault
, partialProcess
, Result (..)
, partialProcess'
) where
import Control.Monad (guard)
import Data.Aeson hiding (Result)
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as H
import Data.List (intersperse,intersect,uncons)
import qualified Data.Text as T
import qualified Data.Text.IO as I
import Text.Glabrous.Internal
import Text.Glabrous.Types
addTag :: Template
-> T.Text
-> T.Text
-> Maybe Template
addTag Template{..} r n = do
let nc = concatMap (insertTag r n) content
guard (length nc > length content)
return Template { content = nc }
where
insertTag t t' (Literal l) =
filter
(/= Literal T.empty)
(intersperse (Tag t') $ Literal <$> T.splitOn t l)
insertTag _ _ t@(Tag _) = [t]
compress :: Template -> Template
compress Template{..} =
Template { content = go content [] }
where
go ts !ac = do
let (a,b) = span isLiteral ts
u = uncons b
if not (null a)
then case u of
Just (c,d) -> go d (ac ++ [concatLiterals a] ++ [c])
Nothing -> ac ++ [concatLiterals a]
else case u of
Just (e,f) -> go f (ac ++ [e])
Nothing -> ac
where
concatLiterals =
foldr trans (Literal "")
where
trans (Literal a) (Literal b) = Literal (a `T.append` b)
trans _ _ = undefined
initContext :: Context
initContext = Context { variables = H.empty }
setVariables :: [(T.Text,T.Text)] -> Context -> Context
setVariables ts Context{..} =
go ts variables
where
go _ts vs =
case uncons _ts of
Just ((k,v),ts') -> go ts' (H.insert k v vs)
Nothing -> Context { variables = vs }
deleteVariables :: [T.Text] -> Context -> Context
deleteVariables ts Context{..} =
go ts variables
where
go _ts vs =
case uncons _ts of
Just (k,ts') -> go ts' (H.delete k vs)
Nothing -> Context { variables = vs }
fromList :: [(T.Text, T.Text)] -> Context
fromList ts = Context { variables = H.fromList ts }
fromTagsList :: [T.Text] -> Context
fromTagsList ts = fromList $ (,T.empty) <$> ts
fromTemplate :: Template -> Context
fromTemplate t = setVariables ((\(Tag e) -> (e,T.empty)) <$> tagsOf t) initContext
readContextFile :: FilePath -> IO (Maybe Context)
readContextFile f = decode <$> L.readFile f
join :: Context
-> Context
-> Either Context Context
join c c' = do
let i = H.intersection (variables c) (variables c')
if i == H.empty
then Right Context { variables = H.union (variables c) (variables c') }
else Left Context { variables = i }
writeContextFile :: FilePath -> Context -> IO ()
writeContextFile f c = L.writeFile f (encodePretty c)
initContextFile :: FilePath -> Context -> IO ()
initContextFile f Context{..} = L.writeFile f $
encodePretty Context { variables = H.map (const T.empty) variables }
unsetContext :: Context -> Maybe Context
unsetContext Context {..} = do
let vs = H.filter (== T.empty) variables
guard (vs /= H.empty)
return Context { variables = vs }
isSet :: Context -> Bool
isSet Context{..} =
H.foldr (\v b -> b && v /= T.empty) True variables
variablesOf :: Context -> [T.Text]
variablesOf Context{..} = H.keys variables
readTemplateFile :: FilePath -> IO (Either String Template)
readTemplateFile f = fromText <$> I.readFile f
writeTemplateFile :: FilePath -> Template -> IO ()
writeTemplateFile f t = I.writeFile f (toText t)
insertTemplate :: Template
-> Token
-> Template
-> Maybe Template
insertTemplate _ (Literal _) _ = Nothing
insertTemplate te t te' = do
guard (t `elem` content te)
return Template { content = foldl trans [] (content te) }
where
trans o t'@(Tag _) =
if t' == t
then o ++ content te'
else o ++ [t']
trans o l = o ++ [l]
insertManyTemplates :: Template -> [(Token,Template)] -> Maybe Template
insertManyTemplates te ttps = do
guard (tagsOf te `intersect` (fst <$> ttps) /= mempty)
return Template { content = foldl trans [] (content te) }
where
trans o li@(Literal _) = o ++ [li]
trans o ta@(Tag _) =
case lookupTemplate ta ttps of
Nothing -> o ++ [ta]
Just te' -> o ++ content te'
lookupTemplate (Literal _) _ = Nothing
lookupTemplate _ [] = Nothing
lookupTemplate t (p:ps) =
if fst p == t
then Just (snd p)
else lookupTemplate t ps
toText :: Template -> T.Text
toText Template{..} =
T.concat (trans <$> content)
where
trans (Literal c) = c
trans (Tag k) = T.concat ["{{",k,"}}"]
toFinalText :: Template -> T.Text
toFinalText Template{..} =
foldl trans T.empty content
where
trans o (Literal l) = o `T.append` l
trans o (Tag _) = o
tagsOf :: Template -> [Token]
tagsOf Template{..} = filter isTag content
tagsRename :: [(T.Text,T.Text)] -> Template -> Template
tagsRename ts Template{..} =
Template { content = rename <$> content }
where
rename t@(Tag n) =
case lookup n ts of
Just r -> Tag r
Nothing -> t
rename l@(Literal _) = l
isFinal :: Template -> Bool
isFinal Template{..} = all isLiteral content
process :: Template -> Context -> T.Text
process = processWithDefault T.empty
processWithDefault
:: T.Text
-> Template
-> Context
-> T.Text
processWithDefault d Template{..} c = toTextWithContext (const d) c content
partialProcess :: Template -> Context -> Template
partialProcess Template{..} c =
Template { content = transTags content c }
where
transTags ts Context{..} =
trans <$> ts
where
trans i@(Tag k) =
case H.lookup k variables of
Just v -> Literal v
Nothing -> i
trans t = t
partialProcess' :: Template -> Context -> Result
partialProcess' t c@Context{..} =
case foldl trans (mempty,mempty) (content t) of
(f,[]) -> Final (toTextWithContext (const T.empty) c f)
(p,p') -> Partial Template { content = p } (fromTagsList p')
where
trans (!c',!ts) t' =
case t' of
Tag k ->
case H.lookup k variables of
Just v -> (c' ++ [Literal v],ts)
Nothing -> (c' ++ [t'],ts ++ [k])
Literal _ -> (c' ++ [t'],ts)