| 8 | 8 |
type Result a = Either String (String, a)
|
| 9 | 9 |
type Parse a = String -> Result a
|
| 10 | 10 |
|
| 11 |
-- All of these characters are the ones which need escaping if used
|
| 12 |
-- inside a document.
|
| 11 | 13 |
isSpecial :: Char -> Bool
|
| 12 | 14 |
isSpecial c = c `elem` "\\{}|"
|
| 13 | 15 |
|
| 16 |
-- This is here for, uh, aesthetic reasons.
|
| 14 | 17 |
throw :: a -> Either a b
|
| 15 | 18 |
throw = Left
|
| 16 | 19 |
|
| 20 |
-- This is 'fmap' named in such a way that it does not conflict with
|
| 21 |
-- 'fmap'.
|
| 17 | 22 |
over :: (a -> b) -> Result a -> Result b
|
| 18 | 23 |
over _ (Left err) = Left err
|
| 19 | 24 |
over f (Right (s, x)) = Right (s, f x)
|
| 20 | 25 |
|
| 26 |
{- And this is a monadic bind. You'll note that this basically has the
|
| 27 |
- same type as almost any other monadic parser combinator library, so
|
| 28 |
- you might be wondering why I'm not just using parsec. On the other
|
| 29 |
- hand, this is literally the only function I actually need there, so
|
| 30 |
- why have another dependency I need to keep up-to-date when I could
|
| 31 |
- just define this trivial function here?
|
| 32 |
-
|
| 33 |
- I'm also not defining this for `Monad` itself because then I'd have
|
| 34 |
- to deal with newtype wrappers and defining methods for the whole
|
| 35 |
- Functor=>Applicative=>Monad hierarchy, when all I really need is
|
| 36 |
- this.
|
| 37 |
-}
|
| 21 | 38 |
bind :: Result a -> ((String, a) -> Result b) -> Result b
|
| 22 | 39 |
bind (Left err) _ = Left err
|
| 23 | 40 |
bind (Right a) f = f a
|
| 24 | 41 |
|
| 42 |
-- Parse a text fragment, handling escapes. This will end as soon as it
|
| 43 |
-- sees any non-escaped special character.
|
| 25 | 44 |
pText :: Parse Fragment
|
| 26 | 45 |
pText = over Text . go
|
| 27 | 46 |
where go ('\\':x:xs)
|
|
| 31 | 50 |
| otherwise = (x:) `over` go xs
|
| 32 | 51 |
go "" = return ("", "")
|
| 33 | 52 |
|
| 53 |
-- Parse a tag name of length >= 0.
|
| 34 | 54 |
pTagName :: Parse String
|
| 35 | 55 |
pTagName s = go s `bind` ensureLen
|
| 36 | 56 |
where go i@(x:xs)
|
|
| 42 | 62 |
| length name > 0 = return (xs, name)
|
| 43 | 63 |
| otherwise = throw "expected tag name after `\\'"
|
| 44 | 64 |
|
| 65 |
-- Skip any space charaters, returning () for the first non-space
|
| 66 |
-- character (including EOF).
|
| 45 | 67 |
skipSpace :: Parse ()
|
| 46 | 68 |
skipSpace i@(x:xs)
|
| 47 | 69 |
| isSpace x = skipSpace xs
|
| 48 | 70 |
| otherwise = return (i, ())
|
| 49 | 71 |
skipSpace _ = return ("", ())
|
| 50 | 72 |
|
| 73 |
-- Parse a tag assuming that a backslash has already been encountered.
|
| 51 | 74 |
pTag :: Parse Fragment
|
| 52 | 75 |
pTag i =
|
| 53 | 76 |
bind (pTagName i) $ \ (i', name) ->
|
|
| 56 | 79 |
("",_) -> throw "unexpected end-of-document while parsing tag"
|
| 57 | 80 |
_ -> throw "expected start of block"
|
| 58 | 81 |
|
| 82 |
-- Parse the vertical-bar-separated arguments to a tag, ending when a
|
| 83 |
-- right curly brace is encountered.
|
| 59 | 84 |
pArgs :: Parse [Document]
|
| 60 | 85 |
pArgs ('}':xs) = return (xs, [])
|
| 61 | 86 |
pArgs s = bind (pFragments s) $ \case
|
|
| 63 | 88 |
('}':xs, cs) -> return (xs, [cs])
|
| 64 | 89 |
_ -> throw "[unreachable]"
|
| 65 | 90 |
|
| 91 |
-- Parse any fragment, deciding whether to parse it as a tag or a text chunk
|
| 66 | 92 |
pFragment :: Parse Fragment
|
| 67 | 93 |
pFragment s@('\\':c:_)
|
| 68 | 94 |
| isSpecial c = pText s
|
| 69 | 95 |
pFragment ('\\':xs) = pTag xs
|
| 70 | 96 |
pFragment s = pText s
|
| 71 | 97 |
|
| 98 |
-- Parse multiple fragments, ending when it encounters a }, or |, or end-of-file.
|
| 72 | 99 |
pFragments :: Parse Document
|
| 73 | 100 |
pFragments "" = return ("", [])
|
| 74 | 101 |
pFragments ('{':s) = bind (pFragments s) $ \case
|
|
| 81 | 108 |
bind (pFragment s) $ \case
|
| 82 | 109 |
(s', c) -> (c:) `over` pFragments s'
|
| 83 | 110 |
|
| 111 |
-- | Parse a string into a @TeLML@ 'Fragment'.
|
| 84 | 112 |
parse :: String -> Either String Document
|
| 85 | 113 |
parse str = case pFragments str of
|
| 86 | 114 |
Right ("", r) -> return r
|