module Text.Glabrous
(
Template (..)
, Tag
, fromText
, readTemplateFile
, toText
, isFinal
, tagsOf
, tagsRename
, compress
, writeTemplateFile
, Context (..)
, initContext
, fromList
, fromTemplate
, setVariables
, deleteVariables
, unsetContext
, readContextFile
, writeContextFile
, initContextFile
, process
, processWithDefault
, partialProcess
, G.Result (..)
, partialProcess'
) where
import Data.Aeson
import Data.Aeson.Encode.Pretty (encodePretty)
import qualified Data.ByteString.Lazy as L
import qualified Data.HashMap.Strict as H
import Data.List (uncons)
import qualified Data.Text as T
import qualified Data.Text.IO as I
import Text.Glabrous.Internal
import Text.Glabrous.Types as G
compress :: Template -> Template
compress t =
Template { content = go (content t) [] }
where
go ts !o = do
let (a,b) = span isL ts
if not (null a)
then case uncons b of
Just (c,d) -> go d (o ++ [concatL a] ++ [c])
Nothing -> o ++ [concatL a]
else case uncons b of
Just (c,d) -> go d (o ++ [c])
Nothing -> o
where
isL (Literal _) = True
isL (Tag _) = False
concatL _ts =
foldr trans (Literal "") _ts
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 c@Context{..} =
case uncons ts of
Just ((k,v),ts') ->
setVariables ts' Context { variables = H.insert k v variables }
Nothing -> c
deleteVariables :: [T.Text] -> Context -> Context
deleteVariables ts c@Context{..} =
case uncons ts of
Just (k,ts') ->
deleteVariables ts' Context { variables = H.delete k variables }
Nothing -> c
fromList :: [(T.Text, T.Text)] -> Context
fromList ts = Context { variables = H.fromList ts }
fromTemplate :: Template -> Context
fromTemplate t = setVariables ((\e -> (e,T.empty)) <$> tagsOf t) initContext
readContextFile :: FilePath -> IO (Maybe Context)
readContextFile f = decode <$> L.readFile f
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
if vs /= H.empty
then Just Context { variables = vs }
else Nothing
readTemplateFile :: FilePath -> IO (Either String Template)
readTemplateFile f = fromText <$> I.readFile f
writeTemplateFile :: FilePath -> Template -> IO ()
writeTemplateFile f t = I.writeFile f $ toText t
toText :: Template -> T.Text
toText Template{..} =
T.concat $ trans <$> content
where
trans (Literal c) = c
trans (Tag k) = T.concat ["{{",k,"}}"]
tagsOf :: Template -> [Tag]
tagsOf Template{..} =
(\(Tag k) -> k) <$> filter isTag content
where
isTag (Tag _) = True
isTag _ = False
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{..} =
allLiteral content
where
allLiteral t =
case uncons t of
Just (t',ts) ->
case t' of
Literal _ -> allLiteral ts
Tag _ -> False
Nothing -> True
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 -> G.Result
partialProcess' t c@Context{..} =
case foldl trans (Template { content = [] },[]) (content t) of
(f,[]) -> Final $ toTextWithContext (const T.empty) c (content f)
(p,p') -> G.Partial p p'
where
trans (!c',ts) t' =
case t' of
Tag k ->
case H.lookup k variables of
Just v -> (addToken (Literal v) c',ts)
Nothing -> (addToken t' c',ts ++ [k])
Literal _ -> (addToken t' c',ts)
where
addToken a b = Template { content = content b ++ [a] }