Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Cannot retrieve contributors at this time

178 lines (156 sloc) 5.685 kb
{-# LANGUAGE PatternGuards, ScopedTypeVariables, TupleSections #-}
module Text.Themplates
( Chunk
, parseSplices, substSplices
-- * Parsec parsers
, spliceParser, curlySplice, thSplice, nestParser, escapeParser, delimParser
-- * Misc Utilities
, dedentQuote, generateNames
) where
import Control.Applicative ( (<$>), (<*>) )
import Control.Monad.Trans.Either ( EitherT )
import Data.Char ( isSpace )
import Data.Generics ( Data, extT, everywhere' )
import Data.List ( isPrefixOf, stripPrefix, tails )
import qualified Data.Map as M
import Data.Maybe ( maybeToList )
import Text.Parsec
( Parsec, parse, try, eof, anyToken, noneOf, char, string, choice, (<|>)
, lookAhead, anyChar, manyTill )
type Chunk c s = Either c s
substSplices :: forall t s e m r. (Monad m, Data r, Ord r)
=> (s -> [t])
-> ([t] -> EitherT e m r)
-> (s -> EitherT e m [(r, r)])
-> [Chunk [t] s]
-> EitherT e m r
substSplices placeholder parser subst xs = do
subs <- sequence [subst s | Right s <- xs]
let subs_map = M.fromList $ concat subs
do_subst :: r -> r
do_subst x
| Just r <- M.lookup x subs_map = r
| otherwise = x
parsed <- parser
$ concatMap (either id placeholder) xs
return $ everywhere' (id `extT` do_subst) parsed
-- Utilities for parsing spliced stuff.
parseSplices :: forall t s. Show t
=> Parsec [t] () s
-> [t]
-> Either String [Chunk [t] s]
parseSplices splice =
either (Left . show) Right . parse (spliceParser splice) ""
spliceParser :: forall t s. Show t
=> Parsec [t] () s
-> Parsec [t] () [Chunk [t] s]
spliceParser parse_splice = do
s <- (Right <$> try parse_splice)
<|> (Left . (:[]) <$> anyToken)
<|> (eof >> return (Left []))
case s of
c@(Left []) -> return [c]
_ -> do
rest <- spliceParser parse_splice
case (s, rest) of
(Left [c], Left acc:rs) -> return $ Left (c:acc) : rs
_ -> return $ s : rest
-- The same splice style as the old ast quoters.
-- TODO: Make the quasi-quoter configurable to use this.
thSplice :: Parsec String () (Maybe String, String)
thSplice = do
_ <- try $ string "$("
fancySplice (concat <$> nestParser (delimParser '(' ')')
[try $ char ')' >> return ""])
-- To be passed as the first parameter to parseSplices or spliceParser.
curlySplice :: Parsec String () (Maybe String, String)
curlySplice = do
_ <- try $ string "{{"
fancySplice (concat <$> nestParser (delimParser '{' '}')
[try $ string "}}" >> return ""])
fancySplice :: Parsec String () s
-> Parsec String () (Maybe String, s)
fancySplice code_parser = do
c <- lookAhead anyChar
case c of
'<' -> do
_ <- char '<'
splice <- manyTill
(escapeParser '\\' [('>', '>'), ('\\', '\\')])
(char '>')
code <- code_parser
return (Just splice, code)
_ -> do
code <- code_parser
return (Nothing, code)
{-
parseList :: Parsec String () (Either String (String, String, String))
parseList = do
input <- getInput
(try $ do
prefix <- manyTill anyChar (lookAhead ((string "..." >> return ())
<|> eof))
string "..."
rest <- many (noneOf " ")
return $ Right (prefix, rest)
) <|> (many anyChar >> return (Left input))
-}
nestParser
:: forall t r. Show t
=> Parsec [t] () (r, Maybe (Parsec [t] () r))
-> [Parsec [t] () r]
-> Parsec [t] () [r]
nestParser open closers = case closers of
[] -> return []
(close:cs)
-> ((:) <$> close <*> nestParser open cs)
<|> (open >>= \(x, c) -> (x:) <$> nestParser open (maybeToList c ++ closers))
<|> return []
escapeParser :: Char -> [(Char, Char)] -> Parsec String () Char
escapeParser c xs =
(char c >> choice (map escape xs)) <|> noneOf [c]
where
escape (code, repl) = char code >> return repl
delimParser :: Char -> Char
-> Parsec String () (String, Maybe (Parsec String () String))
delimParser start end = do
r <- try (string [start]) <|> ((:[]) <$> noneOf [end])
return (r, if r == [start] then Just (try $ string [end]) else Nothing)
-- | Dedents a qq based on the indentation of the first line that has content.
-- As a safety measure, if any of the lines have content but not the same
-- indentation, then an error is yielded.
dedentQuote :: String -> String -> Either String String
dedentQuote qq code =
case lines code of
(l0:l1:ls)
| all isSpace l0 -> dedent $ zip ixs (l1:ls)
| otherwise -> dedent $ zip ixs (l0':l1:ls)
where
l0' = replicate (length qq + 2) ' ' ++ l0
_ -> Right $ dropWhile isSpace code
where
ixs :: [Int]
ixs = [1..]
dedent [] = Right ""
dedent ls@((_, l):_) = unlines <$> mapM removePrefix ls
where
prefix = takeWhile isSpace l
removePrefix (ix, x)
| all isSpace x = Right x
| Just x' <- stripPrefix prefix x = Right x'
| otherwise = Left $ unwords
[ "While dedenting a quote, line "
, show ix
, " had less indentation, or used tabs."
]
generateNames :: String -> String -> [String]
generateNames prefix input =
[ prefix ++ s
| s <- map show [(0::Int)..]
, all (not . isPrefixOf s) avoids
]
where
avoids = [ drop (length prefix) t
| t <- tails input
, prefix `isPrefixOf` t
]
Jump to Line
Something went wrong with that request. Please try again.