module Network.URI.Template
( TemplateEnv
, newEnv
, addToEnv
, addListToEnv
, URITemplate
, URIString
, expand
) where
import Data.Map as M
import Data.List
import Codec.Binary.UTF8.String as UTF8
import Codec.Web.Percent
type URIString = String
type URITemplate = String
newtype TemplateEnv = TemplateEnv { tenv :: Map String TempValue }
data TempValue
= ValStr URIString
| ValList [URIString]
newEnv :: TemplateEnv
newEnv = TemplateEnv{tenv=M.empty}
normalize :: String -> String
normalize s = getEncodedString (UTF8.encodeString s)
addToEnv :: String -> String -> TemplateEnv -> TemplateEnv
addToEnv k v env
= TemplateEnv{tenv=M.insert k (ValStr (normalize v)) (tenv env)}
addListToEnv :: String -> [String] -> TemplateEnv -> TemplateEnv
addListToEnv k vs env
= TemplateEnv{tenv=M.insert k (ValList (Data.List.map normalize vs)) (tenv env)}
expand :: TemplateEnv -> URITemplate -> URIString
expand _ "" = ""
expand env ('{':xs) =
case break (=='}') xs of
(_,[]) -> '{' : expand env xs
('-':str,_:bs) ->
case wordsBy "|" str of
[fun,arg,vars] ->
case Data.List.lookup fun funEnv of
Just f -> (f env arg vars) ++ expand env bs
Nothing -> expand env bs
_ -> expand env bs
(str,_:bs) ->
case break (=='=') str of
(k,_:def) ->
let (def',_isOpt) = if last def == '?' then (init def, True) else (def,False) in
case M.lookup k (tenv env) of
Nothing -> def' ++ expand env bs
Just (ValStr v) -> v ++ expand env bs
Just (ValList vs) -> concat (intersperse "," vs) ++ expand env bs
_ ->
let
(k0,_isOpt)
| last str == '?' = (init str, True)
| otherwise = (str,False)
(k,pre) =
case break (==':') k0 of
(as,_:rs) -> (rs,as++":")
_ -> (k0,"")
in
case M.lookup k (tenv env) of
Nothing -> expand env bs
Just (ValStr v) -> pre ++ v ++ expand env bs
Just (ValList vs) -> concat (intersperse "," $
Data.List.map (pre++) vs) ++ expand env bs
expand env (x:xs) = x : expand env xs
type TemplateFun = TemplateEnv -> String -> String -> String
funEnv :: [(String, TemplateFun)]
funEnv =
[ ("opt", optExp False)
, ("neg", optExp True)
, ("prefix", preExp)
, ("suffix", sufExp)
, ("join", joinExp)
, ("list", listExp)
]
optExp :: Bool -> TemplateFun
optExp isNeg env sep vs
| all isEmpty vals = if isNeg then sep else ""
| otherwise = if isNeg then "" else sep
where
vals = wordsBy "," vs
isEmpty x =
case M.lookup x (tenv env) of
Nothing -> True
Just (ValList []) -> True
_ -> False
preExp :: TemplateFun
preExp env sep vs =
case wordsBy "," vs of
[_] ->
case M.lookup vs (tenv env) of
Just (ValStr x) -> sep ++ x
Just (ValList xs) -> sep ++ concat (intersperse sep xs)
_ -> ""
_ -> ""
sufExp :: TemplateFun
sufExp env sep vs =
case wordsBy "," vs of
[_] ->
case M.lookup vs (tenv env) of
Just (ValStr x) -> x ++ sep
Just (ValList xs) -> concat (intersperse sep xs) ++ sep
_ -> ""
_ -> ""
joinExp :: TemplateFun
joinExp env sep vs = concat (intersperse sep (go (wordsBy "," vs)))
where
go [] = []
go (k:ks) =
case M.lookup k (tenv env) of
Nothing -> go ks
Just ValList{} -> go ks
Just (ValStr s) -> (k ++ '=':s ) : go ks
listExp :: TemplateFun
listExp env sep vs =
case wordsBy "," vs of
[_] -> case M.lookup vs (tenv env) of
Nothing -> ""
Just (ValList []) -> ""
Just (ValList as) -> concat (intersperse sep as)
_ -> ""
_ -> ""
wordsBy :: String -> String -> [String]
wordsBy _ "" = []
wordsBy sep ls =
case spanUntil (sep `isPrefixOf`) ls of
(as,[]) -> [as]
(as,bs) -> as : wordsBy sep (drop (length sep) bs)
spanUntil :: ([a] -> Bool) -> [a] -> ([a],[a])
spanUntil _ [] = ([],[])
spanUntil p ls@(x:xs)
| p ls = ([],ls)
| otherwise =
case spanUntil p xs of
(as,bs) -> (x:as,bs)