{-# 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 (intersect, intersperse, 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 -> Text -> Text -> Maybe Template
addTag Template{[Token]
content :: Template -> [Token]
content :: [Token]
..} Text
r Text
n = do
let nc :: [Token]
nc = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Text -> Text -> Token -> [Token]
insertTag Text
r Text
n) [Token]
content
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Token]
nc forall a. Ord a => a -> a -> Bool
> forall (t :: * -> *) a. Foldable t => t a -> Int
length [Token]
content)
forall (m :: * -> *) a. Monad m => a -> m a
return Template { content :: [Token]
content = [Token]
nc }
where
insertTag :: Text -> Text -> Token -> [Token]
insertTag Text
t Text
t' (Literal Text
l) =
forall a. (a -> Bool) -> [a] -> [a]
filter
(forall a. Eq a => a -> a -> Bool
/= Text -> Token
Literal Text
T.empty)
(forall a. a -> [a] -> [a]
intersperse (Text -> Token
Tag Text
t') forall a b. (a -> b) -> a -> b
$ Text -> Token
Literal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> [Text]
T.splitOn Text
t Text
l)
insertTag Text
_ Text
_ t :: Token
t@(Tag Text
_) = [Token
t]
compress :: Template -> Template
compress :: Template -> Template
compress Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} =
Template { content :: [Token]
content = [Token] -> [Token] -> [Token]
go [Token]
content [] }
where
go :: [Token] -> [Token] -> [Token]
go [Token]
ts ![Token]
ac = do
let ([Token]
a,[Token]
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span Token -> Bool
isLiteral [Token]
ts
u :: Maybe (Token, [Token])
u = forall a. [a] -> Maybe (a, [a])
uncons [Token]
b
if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Token]
a)
then case Maybe (Token, [Token])
u of
Just (Token
c,[Token]
d) -> [Token] -> [Token] -> [Token]
go [Token]
d ([Token]
ac forall a. [a] -> [a] -> [a]
++ [[Token] -> Token
concatLiterals [Token]
a] forall a. [a] -> [a] -> [a]
++ [Token
c])
Maybe (Token, [Token])
Nothing -> [Token]
ac forall a. [a] -> [a] -> [a]
++ [[Token] -> Token
concatLiterals [Token]
a]
else case Maybe (Token, [Token])
u of
Just (Token
e,[Token]
f) -> [Token] -> [Token] -> [Token]
go [Token]
f ([Token]
ac forall a. [a] -> [a] -> [a]
++ [Token
e])
Maybe (Token, [Token])
Nothing -> [Token]
ac
where
concatLiterals :: [Token] -> Token
concatLiterals =
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Token -> Token -> Token
trans (Text -> Token
Literal Text
"")
where
trans :: Token -> Token -> Token
trans (Literal Text
a) (Literal Text
b) = Text -> Token
Literal (Text
a Text -> Text -> Text
`T.append` Text
b)
trans Token
_ Token
_ = forall a. HasCallStack => a
undefined
initContext :: Context
initContext :: Context
initContext = Context { variables :: HashMap Text Text
variables = forall k v. HashMap k v
H.empty }
setVariables :: [(T.Text,T.Text)] -> Context -> Context
setVariables :: [(Text, Text)] -> Context -> Context
setVariables [(Text, Text)]
ts Context{HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} =
[(Text, Text)] -> HashMap Text Text -> Context
go [(Text, Text)]
ts HashMap Text Text
variables
where
go :: [(Text, Text)] -> HashMap Text Text -> Context
go [(Text, Text)]
_ts HashMap Text Text
vs =
case forall a. [a] -> Maybe (a, [a])
uncons [(Text, Text)]
_ts of
Just ((Text
k,Text
v),[(Text, Text)]
ts') -> [(Text, Text)] -> HashMap Text Text -> Context
go [(Text, Text)]
ts' (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert Text
k Text
v HashMap Text Text
vs)
Maybe ((Text, Text), [(Text, Text)])
Nothing -> Context { variables :: HashMap Text Text
variables = HashMap Text Text
vs }
deleteVariables :: [T.Text] -> Context -> Context
deleteVariables :: [Text] -> Context -> Context
deleteVariables [Text]
ts Context{HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} =
[Text] -> HashMap Text Text -> Context
go [Text]
ts HashMap Text Text
variables
where
go :: [Text] -> HashMap Text Text -> Context
go [Text]
_ts HashMap Text Text
vs =
case forall a. [a] -> Maybe (a, [a])
uncons [Text]
_ts of
Just (Text
k,[Text]
ts') -> [Text] -> HashMap Text Text -> Context
go [Text]
ts' (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
H.delete Text
k HashMap Text Text
vs)
Maybe (Text, [Text])
Nothing -> Context { variables :: HashMap Text Text
variables = HashMap Text Text
vs }
fromList :: [(T.Text, T.Text)] -> Context
fromList :: [(Text, Text)] -> Context
fromList [(Text, Text)]
ts = Context { variables :: HashMap Text Text
variables = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
H.fromList [(Text, Text)]
ts }
fromTagsList :: [T.Text] -> Context
fromTagsList :: [Text] -> Context
fromTagsList [Text]
ts = [(Text, Text)] -> Context
fromList forall a b. (a -> b) -> a -> b
$ (,Text
T.empty) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
ts
fromTemplate :: Template -> Context
fromTemplate :: Template -> Context
fromTemplate Template
t =
[(Text, Text)] -> Context -> Context
setVariables (Token -> (Text, Text)
toPair forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template -> [Token]
tagsOf Template
t) Context
initContext
where
toPair :: Token -> (Text, Text)
toPair (Tag Text
e) = (Text
e,Text
T.empty)
toPair Token
_ = forall a. HasCallStack => a
undefined
readContextFile :: FilePath -> IO (Maybe Context)
readContextFile :: FilePath -> IO (Maybe Context)
readContextFile FilePath
f = forall a. FromJSON a => ByteString -> Maybe a
decode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
L.readFile FilePath
f
join :: Context
-> Context
-> Either Context Context
join :: Context -> Context -> Either Context Context
join Context
c Context
c' = do
let i :: HashMap Text Text
i = forall k v w.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k w -> HashMap k v
H.intersection (Context -> HashMap Text Text
variables Context
c) (Context -> HashMap Text Text
variables Context
c')
if HashMap Text Text
i forall a. Eq a => a -> a -> Bool
== forall k v. HashMap k v
H.empty
then forall a b. b -> Either a b
Right Context { variables :: HashMap Text Text
variables = forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
H.union (Context -> HashMap Text Text
variables Context
c) (Context -> HashMap Text Text
variables Context
c') }
else forall a b. a -> Either a b
Left Context { variables :: HashMap Text Text
variables = HashMap Text Text
i }
writeContextFile :: FilePath -> Context -> IO ()
writeContextFile :: FilePath -> Context -> IO ()
writeContextFile FilePath
f Context
c = FilePath -> ByteString -> IO ()
L.writeFile FilePath
f (forall a. ToJSON a => a -> ByteString
encodePretty Context
c)
initContextFile :: FilePath -> Context -> IO ()
initContextFile :: FilePath -> Context -> IO ()
initContextFile FilePath
f Context{HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} = FilePath -> ByteString -> IO ()
L.writeFile FilePath
f forall a b. (a -> b) -> a -> b
$
forall a. ToJSON a => a -> ByteString
encodePretty Context { variables :: HashMap Text Text
variables = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
H.map (forall a b. a -> b -> a
const Text
T.empty) HashMap Text Text
variables }
unsetContext :: Context -> Maybe Context
unsetContext :: Context -> Maybe Context
unsetContext Context {HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} = do
let vs :: HashMap Text Text
vs = forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
H.filter (forall a. Eq a => a -> a -> Bool
== Text
T.empty) HashMap Text Text
variables
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (HashMap Text Text
vs forall a. Eq a => a -> a -> Bool
/= forall k v. HashMap k v
H.empty)
forall (m :: * -> *) a. Monad m => a -> m a
return Context { variables :: HashMap Text Text
variables = HashMap Text Text
vs }
isSet :: Context -> Bool
isSet :: Context -> Bool
isSet Context{HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} =
forall v a k. (v -> a -> a) -> a -> HashMap k v -> a
H.foldr (\Text
v Bool
b -> Bool
b Bool -> Bool -> Bool
&& Text
v forall a. Eq a => a -> a -> Bool
/= Text
T.empty) Bool
True HashMap Text Text
variables
variablesOf :: Context -> [T.Text]
variablesOf :: Context -> [Text]
variablesOf Context{HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} = forall k v. HashMap k v -> [k]
H.keys HashMap Text Text
variables
readTemplateFile :: FilePath -> IO (Either String Template)
readTemplateFile :: FilePath -> IO (Either FilePath Template)
readTemplateFile FilePath
f = Text -> Either FilePath Template
fromText forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Text
I.readFile FilePath
f
writeTemplateFile :: FilePath -> Template -> IO ()
writeTemplateFile :: FilePath -> Template -> IO ()
writeTemplateFile FilePath
f Template
t = FilePath -> Text -> IO ()
I.writeFile FilePath
f (Template -> Text
toText Template
t)
insertTemplate :: Template
-> Token
-> Template
-> Maybe Template
insertTemplate :: Template -> Token -> Template -> Maybe Template
insertTemplate Template
_ (Literal Text
_) Template
_ = forall a. Maybe a
Nothing
insertTemplate Template
te Token
t Template
te' = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Token
t forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Template -> [Token]
content Template
te)
forall (m :: * -> *) a. Monad m => a -> m a
return Template { content :: [Token]
content = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Token] -> Token -> [Token]
trans [] (Template -> [Token]
content Template
te) }
where
trans :: [Token] -> Token -> [Token]
trans [Token]
o t' :: Token
t'@(Tag Text
_) =
if Token
t' forall a. Eq a => a -> a -> Bool
== Token
t
then [Token]
o forall a. [a] -> [a] -> [a]
++ Template -> [Token]
content Template
te'
else [Token]
o forall a. [a] -> [a] -> [a]
++ [Token
t']
trans [Token]
o Token
l = [Token]
o forall a. [a] -> [a] -> [a]
++ [Token
l]
insertManyTemplates :: Template -> [(Token,Template)] -> Maybe Template
insertManyTemplates :: Template -> [(Token, Template)] -> Maybe Template
insertManyTemplates Template
te [(Token, Template)]
ttps = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Template -> [Token]
tagsOf Template
te forall a. Eq a => [a] -> [a] -> [a]
`intersect` (forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Token, Template)]
ttps) forall a. Eq a => a -> a -> Bool
/= forall a. Monoid a => a
mempty)
forall (m :: * -> *) a. Monad m => a -> m a
return Template { content :: [Token]
content = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [Token] -> Token -> [Token]
trans [] (Template -> [Token]
content Template
te) }
where
trans :: [Token] -> Token -> [Token]
trans [Token]
o li :: Token
li@(Literal Text
_) = [Token]
o forall a. [a] -> [a] -> [a]
++ [Token
li]
trans [Token]
o ta :: Token
ta@(Tag Text
_) =
case forall {a}. Token -> [(Token, a)] -> Maybe a
lookupTemplate Token
ta [(Token, Template)]
ttps of
Maybe Template
Nothing -> [Token]
o forall a. [a] -> [a] -> [a]
++ [Token
ta]
Just Template
te' -> [Token]
o forall a. [a] -> [a] -> [a]
++ Template -> [Token]
content Template
te'
lookupTemplate :: Token -> [(Token, a)] -> Maybe a
lookupTemplate (Literal Text
_) [(Token, a)]
_ = forall a. Maybe a
Nothing
lookupTemplate Token
_ [] = forall a. Maybe a
Nothing
lookupTemplate Token
t ((Token, a)
p:[(Token, a)]
ps) =
if forall a b. (a, b) -> a
fst (Token, a)
p forall a. Eq a => a -> a -> Bool
== Token
t
then forall a. a -> Maybe a
Just (forall a b. (a, b) -> b
snd (Token, a)
p)
else Token -> [(Token, a)] -> Maybe a
lookupTemplate Token
t [(Token, a)]
ps
toText :: Template -> T.Text
toText :: Template -> Text
toText Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} =
[Text] -> Text
T.concat (Token -> Text
trans forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
content)
where
trans :: Token -> Text
trans (Literal Text
c) = Text
c
trans (Tag Text
k) = [Text] -> Text
T.concat [Text
"{{",Text
k,Text
"}}"]
toFinalText :: Template -> T.Text
toFinalText :: Template -> Text
toFinalText Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Text -> Token -> Text
trans Text
T.empty [Token]
content
where
trans :: Text -> Token -> Text
trans Text
o (Literal Text
l) = Text
o Text -> Text -> Text
`T.append` Text
l
trans Text
o (Tag Text
_) = Text
o
tagsOf :: Template -> [Token]
tagsOf :: Template -> [Token]
tagsOf Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} = forall a. (a -> Bool) -> [a] -> [a]
filter Token -> Bool
isTag [Token]
content
tagsRename :: [(T.Text,T.Text)] -> Template -> Template
tagsRename :: [(Text, Text)] -> Template -> Template
tagsRename [(Text, Text)]
ts Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} =
Template { content :: [Token]
content = Token -> Token
rename forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Token]
content }
where
rename :: Token -> Token
rename t :: Token
t@(Tag Text
n) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Token
t Text -> Token
Tag (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
n [(Text, Text)]
ts)
rename l :: Token
l@(Literal Text
_) = Token
l
isFinal :: Template -> Bool
isFinal :: Template -> Bool
isFinal Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Token -> Bool
isLiteral [Token]
content
process :: Template -> Context -> T.Text
process :: Template -> Context -> Text
process = Text -> Template -> Context -> Text
processWithDefault Text
T.empty
processWithDefault
:: T.Text
-> Template
-> Context
-> T.Text
processWithDefault :: Text -> Template -> Context -> Text
processWithDefault Text
d Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} Context
c = (Text -> Text) -> Context -> [Token] -> Text
toTextWithContext (forall a b. a -> b -> a
const Text
d) Context
c [Token]
content
partialProcess :: Template -> Context -> Template
partialProcess :: Template -> Context -> Template
partialProcess Template{[Token]
content :: [Token]
content :: Template -> [Token]
..} Context
c =
Template { content :: [Token]
content = forall {f :: * -> *}. Functor f => f Token -> Context -> f Token
transTags [Token]
content Context
c }
where
transTags :: f Token -> Context -> f Token
transTags f Token
ts Context{HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} =
Token -> Token
trans forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f Token
ts
where
trans :: Token -> Token
trans i :: Token
i@(Tag Text
k) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Token
i Text -> Token
Literal (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
k HashMap Text Text
variables)
trans Token
t = Token
t
partialProcess' :: Template -> Context -> Result
partialProcess' :: Template -> Context -> Result
partialProcess' Template
t c :: Context
c@Context{HashMap Text Text
variables :: HashMap Text Text
variables :: Context -> HashMap Text Text
..} =
case forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ([Token], [Text]) -> Token -> ([Token], [Text])
trans (forall a. Monoid a => a
mempty,forall a. Monoid a => a
mempty) (Template -> [Token]
content Template
t) of
([Token]
f,[]) -> Text -> Result
Final ((Text -> Text) -> Context -> [Token] -> Text
toTextWithContext (forall a b. a -> b -> a
const Text
T.empty) Context
c [Token]
f)
([Token]
p,[Text]
p') -> Template -> Context -> Result
Partial Template { content :: [Token]
content = [Token]
p } ([Text] -> Context
fromTagsList [Text]
p')
where
trans :: ([Token], [Text]) -> Token -> ([Token], [Text])
trans (![Token]
c',![Text]
ts) Token
t' =
case Token
t' of
Tag Text
k ->
case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
H.lookup Text
k HashMap Text Text
variables of
Just Text
v -> ([Token]
c' forall a. [a] -> [a] -> [a]
++ [Text -> Token
Literal Text
v],[Text]
ts)
Maybe Text
Nothing -> ([Token]
c' forall a. [a] -> [a] -> [a]
++ [Token
t'],[Text]
ts forall a. [a] -> [a] -> [a]
++ [Text
k])
Literal Text
_ -> ([Token]
c' forall a. [a] -> [a] -> [a]
++ [Token
t'],[Text]
ts)