Commit 82ea3e8a270a951fd73690bb08a1d1ada57c3ee6 - telml

ormolu Getty Ritter 1 year, 10 months ago

8 changed file(s) with 217 addition(s) and 201 deletion(s). Collapse all Expand all

+48

-46

telml/Data/TeLML/Parser.hs less more

1	1	{-# LANGUAGE LambdaCase #-}
2	2
3		module Data.TeLML.Parser (Fragment~~(..), Tag~~(..), Document, parse) where
	3	module Data.TeLML.Parser (Fragment (..), Tag (..), Document, parse) where
4	4
5	5	import Data.Char (isAlpha, isAlphaNum, isSpace)
6	6	import Data.TeLML.Type
7
8	7	import qualified Data.Text as T
9	8
10	9	type Result a = Either String (String, a)
	10
11	11	type Parse a = String -> Result a
12	12
13	13	-- All of these characters are the ones which need escaping if used

22	22	-- This is 'fmap' named in such a way that it does not conflict with
23	23	-- 'fmap'.
24	24	over :: (a -> b) -> Result a -> Result b
25		over _ (Left err) = Left err
	25	over _ (Left err) = Left err
26	26	over f (Right (s, x)) = Right (s, f x)
27	27
28	28	{- And this is a monadic bind. You'll note that this basically has the

39	39	-}
40	40	bind :: Result a -> ((String, a) -> Result b) -> Result b
41	41	bind (Left err) _ = Left err
42		bind (Right a) f = f a
	42	bind (Right a) f = f a
43	43
44	44	-- Parse a text fragment, handling escapes. This will end as soon as it
45	45	-- sees any non-escaped special character.
46	46	pText :: Parse Fragment
47	47	pText = over (TextFrag . T.pack) . go
48		where go ('\\':x:xs)
49		\| isSpecial x = (x:) `over` go xs
50		go i@(x:xs)
51		\| isSpecial x = return (i, "")
52		\| otherwise = (x:) `over` go xs
53		go "" = return ("", "")
	48	where
	49	go ('\\' : x : xs)
	50	\| isSpecial x = (x :) `over` go xs
	51	go i@(x : xs)
	52	\| isSpecial x = return (i, "")
	53	\| otherwise = (x :) `over` go xs
	54	go "" = return ("", "")
54	55
55	56	-- Parse a tag name of length >= 0.
56	57	pTagName :: Parse String
57	58	pTagName s = go s `bind` ensureName
58		where go i@(x:xs)
59		\| isAlphaNum x = (x:) `over` go xs
60		\| elem x "-_" = (x:) `over` go xs
61		\| otherwise = return (i, "")
62		go [] = throw "unexpected end-of-document while parsing tag"
63		ensureName (xs, name)
64		\| length name == 0 =
65		throw "expected tag name after `\\'"
66		\| not (isAlpha (head name)) =
67		throw "tag names must begin with an alphabetic character"
68		~~\| otherwise = return (xs, name)~~
	59	where
	60	go i@(x : xs)
	61	\| isAlphaNum x = (x :) `over` go xs
	62	\| elem x "-_" = (x :) `over` go xs
	63	\| otherwise = return (i, "")
	64	go [] = throw "unexpected end-of-document while parsing tag"
	65	ensureName (xs, name)
	66	\| length name == 0 =
	67	throw "expected tag name after `\\'"
	68	\| not (isAlpha (head name)) =
	69	throw "tag names must begin with an alphabetic character"
	70	\| otherwise = return (xs, name)
69	71
70	72	-- Skip any space charaters, returning () for the first non-space
71	73	-- character (including EOF).
72	74	skipSpace :: Parse ()
73		skipSpace i@(x:xs)
	75	skipSpace i@(x : xs)
74	76	\| isSpace x = skipSpace xs
75	77	\| otherwise = return (i, ())
76	78	skipSpace _ = return ("", ())

78	80	-- Parse a tag assuming that a backslash has already been encountered.
79	81	pTag :: Parse Fragment
80	82	pTag i =
81		bind (pTagName i) $ \ (i', name) ->
	83	bind (pTagName i) $ \(i', name) ->
82	84	bind (skipSpace i') $ \case
83		('{':i'', ()) -> TagFrag `over` (Tag (T.pack name) `over` pArgs i'')
84		("",_) -> throw "unexpected end-of-document while parsing tag"
85		~~_ -> throw "expected start of block"~~
	85	('{' : i'', ()) -> TagFrag `over` (Tag (T.pack name) `over` pArgs i'')
	86	("", _) -> throw "unexpected end-of-document while parsing tag"
	87	_ -> throw "expected start of block"
86	88
87	89	-- Parse the vertical-bar-separated arguments to a tag, ending when a
88	90	-- right curly brace is encountered.
89	91	pArgs :: Parse [Document]
90		pArgs ('}':xs) = return (xs, [])
	92	pArgs ('}' : xs) = return (xs, [])
91	93	pArgs s = bind (pFragments s) $ \case
92		('\|':xs, cs) -> (cs:) `over` pArgs xs
93		('}':xs, cs) -> return (xs, [cs])
94		~~_ -> throw "[unreachable]"~~
	94	('\|' : xs, cs) -> (cs :) `over` pArgs xs
	95	('}' : xs, cs) -> return (xs, [cs])
	96	_ -> throw "[unreachable]"
95	97
96	98	-- Parse any fragment, deciding whether to parse it as a tag or a text chunk
97	99	pFragment :: Parse Fragment
98		pFragment s@('\\':c:_)
99		\| isSpecial c = pText s
100		pFragment ('\\':xs) = pTag xs
101		pFragment s = pText s
	100	pFragment s@('\\' : c : _)
	101	\| isSpecial c = pText s
	102	pFragment ('\\' : xs) = pTag xs
	103	pFragment s = pText s
102	104
103	105	-- Parse multiple fragments, ending when it encounters a }, or \|, or end-of-file.
104	106	pFragments :: Parse Document
105	107	pFragments "" = return ("", [])
106		pFragments ('{':s) = bind (pFragments s) $ \case
107		('}':xs, cs) -> bind (pFragments xs) $ \(xs', cs') -> return (xs', cs ++ cs')
108		(x:_, _) -> throw ("unexpected " ++ show x ++ "; expected '}'")
109		([], _) -> throw ("unexpected end-of-document while parsing block")
110		pFragments ~~s@(x:_)~~
	108	pFragments ('{' : s) = bind (pFragments s) $ \case
	109	('}' : xs, cs) -> bind (pFragments xs) $ \(xs', cs') -> return (xs', cs ++ cs')
	110	(x : _, _) -> throw ("unexpected " ++ show x ++ "; expected '}'")
	111	([], _) -> throw ("unexpected end-of-document while parsing block")
	112	pFragments s@(x : _)
111	113	\| x `elem` "}\|" = return (s, [])
112		\| otherwise =
113		bind (pFragment s) $ \case
114		~~(s', c) -> (c:) `over` pFragments s'~~
	114	\| otherwise =
	115	bind (pFragment s) $ \case
	116	(s', c) -> (c :) `over` pFragments s'
115	117
116	118	-- \| Parse a string into a @TeLML@ 'Fragment'.
117	119	parse :: String -> Either String Document
118	120	parse str = case pFragments str of
119		Right ("", r) -> return r
120		Right ('}':_, _) -> throw ("Found unmatched '}' in document")
121		Right (s, _) -> throw ("expected end of document but found " ++ show s)
122		Left err -> throw err
	121	Right ("", r) -> return r
	122	Right ('}' : _, _) -> throw ("Found unmatched '}' in document")
	123	Right (s, _) -> throw ("expected end of document but found " ++ show s)
	124	Left err -> throw err

+11

-10

telml/Data/TeLML/Type.hs less more

1	1	{-# LANGUAGE DeriveDataTypeable #-}
2	2
3		module Data.TeLML.Type (Document, Fragment~~(..), Tag~~(..)) where
	3	module Data.TeLML.Type (Document, Fragment (..), Tag (..)) where
4	4
5		import Control.DeepSeq (NFData(..))
6		import Data.Data (Data)
	5	import Control.DeepSeq (NFData (..))
	6	import Data.Data (Data)
	7	import Data.String (IsString (..))
7	8	import qualified Data.Text as T
8		import Data.Typeable (Typeable)
9		import Data.String (IsString(..))
	9	import Data.Typeable (Typeable)
10	10
11	11	-- \| A 'Document' is zero or more 'Fragment's.
12	12	type Document = [Fragment]

18	18	data Fragment
19	19	= TextFrag T.Text
20	20	\| TagFrag Tag
21		deriving (Eq, Show, Typeable, Data)
	21	deriving (Eq, Show, Typeable, Data)
22	22
23	23	data Tag = Tag
24		{ tagName :: T.Text
25		, tagPayload :: [Document]
26		~~} deriving (Eq, Show, Typeable, Data)~~
	24	{ tagName :: T.Text,
	25	tagPayload :: [Document]
	26	}
	27	deriving (Eq, Show, Typeable, Data)
27	28
28	29	instance IsString Fragment where
29	30	fromString = TextFrag . fromString
30	31
31	32	instance NFData Fragment where
32		rnf (TextFrag s) = rnf s
	33	rnf (TextFrag s) = rnf s
33	34	rnf (TagFrag t) = rnf t
34	35
35	36	instance NFData Tag where

-1

telml/Data/TeLML.hs less more

1		module Data.TeLML~~(parse, Document, Fragment(..), Tag~~(..)) where
	1	module Data.TeLML (parse, Document, Fragment (..), Tag (..)) where
2	2
3	3	import Data.TeLML.Parser

-0

telml/Setup.hs less more

1	1	import Distribution.Simple
	2
2	3	main = defaultMain

+93

-85

telml-markup/Data/TeLML/Markup.hs less more

	1	{-# LANGUAGE ExistentialQuantification #-}
	2	{-# LANGUAGE FlexibleInstances #-}
	3	{-# LANGUAGE OverloadedStrings #-}
1	4	{-# LANGUAGE ScopedTypeVariables #-}
2		{-# LANGUAGE ExistentialQuantification #-}
3		{-# LANGUAGE OverloadedStrings #-}
4		{-# LANGUAGE FlexibleInstances #-}
5	5	{-# LANGUAGE TypeFamilies #-}
6	6
7	7	module Data.TeLML.Markup
8		( renderWith
9		, render
10		, basicTags
11		, mkTag
12		, simpleTag
13		, listTag
14		, H(..)
15		, Hs(..)
16		, Str(..)
17		, TagDescription
18		) where
	8	( renderWith,
	9	render,
	10	basicTags,
	11	mkTag,
	12	simpleTag,
	13	listTag,
	14	H (..),
	15	Hs (..),
	16	Str (..),
	17	TagDescription,
	18	)
	19	where
19	20
20	21	import Control.Monad (void)
21	22	import Data.TeLML
22	23	import qualified Data.Text as T
23	24	import Text.Blaze.Html
24		import Text.Blaze.Html5 hiding (~~map, head, html~~)
	25	import Text.Blaze.Html5 hiding (head, html, map)
25	26	import Text.Blaze.Html5.Attributes hiding (name, span)
26
27	27	import Prelude hiding (div, span)
28	28
29	29	-- \| Render a TeLML document with an extra set of possible tags.

40	40	-- splits it apart whenever it comes across double newlines.
41	41	gatherPara :: Document -> [Document]
42	42	gatherPara = reverse . map reverse . go [[]]
43		where go rs [] = rs
44		go (r:rs) (t@TagFrag {}:ts) = go ((t:r):rs) ts
45		go (r:rs) (TextFrag s:ts) = case splitString s of
46		[] -> go (r:rs) ts
47		[x] -> go ((TextFrag x:r):rs) ts
48		xs -> go (map ((:[]) . TextFrag) (tail xs) ++
49		((TextFrag (head xs):r) : rs)) ts
50		go _ _ = error "[unreachable]"
	43	where
	44	go rs [] = rs
	45	go (r : rs) (t@TagFrag {} : ts) = go ((t : r) : rs) ts
	46	go (r : rs) (TextFrag s : ts) = case splitString s of
	47	[] -> go (r : rs) ts
	48	[x] -> go ((TextFrag x : r) : rs) ts
	49	xs ->
	50	go
	51	( map ((: []) . TextFrag) (tail xs)
	52	++ ((TextFrag (head xs) : r) : rs)
	53	)
	54	ts
	55	go _ _ = error "[unreachable]"
51	56
52	57	-- Split a string at double-newlines.
53	58	splitString :: T.Text -> [T.Text]
54	59	splitString = T.splitOn "\n\n"
55	60
56
57	61	-- \| The 'TagArguments' class allow us to define a new tag with a name
58	62	-- and a simple function, and cuts out a lot of the boilerplate.
59	63	class TagArguments t where
60	64	toType :: t -> [T.Text]
61		taExec :: t
62		-> [Document]
63		-> (Fragment -> Either String Html)
64		-> Maybe (Either String Html)
	65	taExec ::
	66	t ->
	67	[Document] ->
	68	(Fragment -> Either String Html) ->
	69	Maybe (Either String Html)
65	70
66	71	instance TagArguments Html where
67	72	toType _ = []
68	73	taExec h [] _ = Just (Right h)
69		taExec _ _ _ = Nothing
	74	taExec _ _ _ = Nothing
70	75
71	76	instance TagArguments r => TagArguments (Str -> r) where
72	77	toType _ = "str" : toType (undefined :: r)
73		taExec f ([TextFrag t]:rs) go = taExec (f (Str t)) rs go
74		taExec _ _ _ = Nothing
	78	taExec f ([TextFrag t] : rs) go = taExec (f (Str t)) rs go
	79	taExec _ _ _ = Nothing
75	80
76	81	instance TagArguments r => TagArguments (Maybe Str -> r) where
77	82	toType _ = "str?" : toType (undefined :: r)
78		taExec f ([TextFrag t]:rs) go = taExec (f (Just (Str t))) rs go
79		taExec f [] go = taExec (f Nothing) [] go
80		taExec ~~_ _ _ = Nothing~~
	83	taExec f ([TextFrag t] : rs) go = taExec (f (Just (Str t))) rs go
	84	taExec f [] go = taExec (f Nothing) [] go
	85	taExec _ _ _ = Nothing
81	86
82	87	instance TagArguments r => TagArguments (H -> r) where
83	88	toType _ = "frag" : toType (undefined :: r)
84		taExec f (doc:rs) go =
	89	taExec f (doc : rs) go =
85	90	let h = fmap sequence_ (mapM go doc)
86		in case h of
87		Left err -> return (Left err)
88		Right h' -> taExec (f (H h')) rs go
89		taExec _ [] _ = Nothing
	91	in case h of
	92	Left err -> return (Left err)
	93	Right h' -> taExec (f (H h')) rs go
	94	taExec _ [] _ = Nothing
90	95
91	96	instance (h ~ Html) => TagArguments (Hs -> h) where
92	97	toType _ = ["..."]
93	98	taExec f docs go =
94	99	let h = mapM (fmap sequence_ . mapM go) docs
95		in case h of
96		Left err -> return (Left err)
97		~~Right hs -> return (Right (f (Hs hs)))~~
	100	in case h of
	101	Left err -> return (Left err)
	102	Right hs -> return (Right (f (Hs hs)))
98	103
99	104	data TagDescription
100		= forall t. ~~TagArguments t =>~~
	105	= forall t.
	106	TagArguments t =>
101	107	TagDescription T.Text t
102	108
103	109	-- \| The 'Str' newtype will match a literal chunk of non-formatted,
104	110	-- non-structured text.
105		newtype Str = Str { ~~fromStr :: T.Text~~ }
	111	newtype Str = Str {fromStr :: T.Text}
106	112
107	113	-- \| The 'H' newtype will match a single, pre-rendered argument
108		newtype H = H { ~~fromHtml :: Html~~ }
	114	newtype H = H {fromHtml :: Html}
109	115
110	116	-- \| The 'Hs' newtype will match a concatenated set of pre-rendered
111	117	-- arguments
112		newtype Hs = Hs { ~~fromHtmlList :: [Html]~~ }
	118	newtype Hs = Hs {fromHtmlList :: [Html]}
113	119
114	120	mkTag :: TagArguments t => T.Text -> t -> TagDescription
115	121	mkTag = TagDescription

117	123	-- The built-in set of tags (subject to change)
118	124	basicTags :: [TagDescription]
119	125	basicTags =
120		[ simpleTag "em" em
121		, simpleTag "strong" strong
122		, simpleTag "li" li
123		, simpleTag "h1" h1
124		, simpleTag "h2" h2
125		, simpleTag "p" (\ rs -> span ! class_ "para" $ rs)
126		, simpleTag "blockquote" blockquote
127		, simpleTag "tt" code
128		, simpleTag "code" (pre . code)
129		, simpleTag "ttcom" (\ rs -> span ! class_ "comment" $ rs)
130		, simpleTag "ttkw" (\ rs -> span ! class_ "keyword" $ rs)
131		, simpleTag "ttcn" (\ rs -> span ! class_ "constr" $ rs)
132		, simpleTag "ttstr" (\ rs -> span ! class_ "string" $ rs)
133
134		, listTag "ul" ul
135		, listTag "ol" ol
136		, mkTag "list" (\ (Hs hs) -> ul $ mapM_ li hs)
137		, listTag "center" (\ rs -> div ! class_ "center" $ rs)
138
139		, TagDescription "br" br
140		, TagDescription "comment" ("" :: Html)
141		, TagDescription "link" (\ (Str l) (H h) -> a ! href (toValue l) $ h)
142		, TagDescription "img" $ \ (Str l) altText -> case altText of
143		Just r -> img ! src (toValue l) ! alt (toValue (fromStr r))
	126	[ simpleTag "em" em,
	127	simpleTag "strong" strong,
	128	simpleTag "li" li,
	129	simpleTag "h1" h1,
	130	simpleTag "h2" h2,
	131	simpleTag "p" (\rs -> span ! class_ "para" $ rs),
	132	simpleTag "blockquote" blockquote,
	133	simpleTag "tt" code,
	134	simpleTag "code" (pre . code),
	135	simpleTag "ttcom" (\rs -> span ! class_ "comment" $ rs),
	136	simpleTag "ttkw" (\rs -> span ! class_ "keyword" $ rs),
	137	simpleTag "ttcn" (\rs -> span ! class_ "constr" $ rs),
	138	simpleTag "ttstr" (\rs -> span ! class_ "string" $ rs),
	139	listTag "ul" ul,
	140	listTag "ol" ol,
	141	mkTag "list" (\(Hs hs) -> ul $ mapM_ li hs),
	142	listTag "center" (\rs -> div ! class_ "center" $ rs),
	143	TagDescription "br" br,
	144	TagDescription "comment" ("" :: Html),
	145	TagDescription "link" (\(Str l) (H h) -> a ! href (toValue l) $ h),
	146	TagDescription "img" $ \(Str l) altText -> case altText of
	147	Just r -> img ! src (toValue l) ! alt (toValue (fromStr r))
144	148	Nothing -> img ! src (toValue l)
145	149	]
146	150

156	160	-- render a single paragraph
157	161	renderPara :: [TagDescription] -> Document -> Either String Html
158	162	renderPara taglist ds = fmap (p . sequence_) (mapM go ds)
159		where go (TextFrag ts) = Right (toMarkup ts)
160		go (TagFrag (Tag tx rs)) = exec tx rs taglist
161		exec name args (TagDescription tag func:_)
162		\| name == tag = case taExec func args go of
163		Nothing -> Left $ unwords
164		[ "Tag"
165		, T.unpack ('\\' `T.cons` name)
166		, "expects argument structure"
167		, T.unpack ('\\' `T.cons` name `T.append` argsFor func)
168		]
169		Just x -> x
170		exec name args (_:rs) = exec name args rs
171		exec name args [] = Left $
172		"Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)
	163	where
	164	go (TextFrag ts) = Right (toMarkup ts)
	165	go (TagFrag (Tag tx rs)) = exec tx rs taglist
	166	exec name args (TagDescription tag func : _)
	167	\| name == tag = case taExec func args go of
	168	Nothing ->
	169	Left $
	170	unwords
	171	[ "Tag",
	172	T.unpack ('\\' `T.cons` name),
	173	"expects argument structure",
	174	T.unpack ('\\' `T.cons` name `T.append` argsFor func)
	175	]
	176	Just x -> x
	177	exec name args (_ : rs) = exec name args rs
	178	exec name args [] =
	179	Left $
	180	"Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)

+25

-20

telml-markup/telml2html/Main.hs less more

1	1	module Main where
2	2
3		import Control.Monad ((>=>))
	3	import Control.Monad ((>=>))
4	4	import qualified Data.TeLML as TeLML
5	5	import qualified Data.TeLML.Markup as TeLML
	6	import qualified System.Console.GetOpt as Opt
	7	import qualified System.Environment as Env
	8	import qualified System.Exit as Sys
6	9	import qualified Text.Blaze.Renderer.String as B
7		import qualified System.Console.GetOpt as Opt
8		import qualified System.Exit as Sys
9		import qualified System.Environment as Env
10	10
11	11	data Options = Options
12		{ optInput :: Maybe FilePath
13		, optOutput :: Maybe FilePath
	12	{ optInput :: Maybe FilePath,
	13	optOutput :: Maybe FilePath
14	14	}
15	15
16	16	defaultOptions :: Options
17		defaultOptions = Options
18		{ optInput = Nothing
19		, optOutput = Nothing
20		}
	17	defaultOptions =
	18	Options
	19	{ optInput = Nothing,
	20	optOutput = Nothing
	21	}
21	22
22	23	options :: [Opt.OptDescr (Options -> Options)]
23	24	options =
24		[ Opt.Option ['i'] ["input"]
25		(Opt.ReqArg (\ path opt -> opt { optInput = Just path }) "file")
26		"Read input from this file"
27		, Opt.Option ['o'] ["output"]
28		(Opt.ReqArg (\ path opt -> opt { optOutput = Just path }) "file")
29		"Read input from this file"
	25	[ Opt.Option
	26	['i']
	27	["input"]
	28	(Opt.ReqArg (\path opt -> opt {optInput = Just path}) "file")
	29	"Read input from this file",
	30	Opt.Option
	31	['o']
	32	["output"]
	33	(Opt.ReqArg (\path opt -> opt {optOutput = Just path}) "file")
	34	"Read input from this file"
30	35	]
31	36
32	37	doRender :: String -> Either String String

36	41	runPipeline inF outF = do
37	42	cs <- case inF of
38	43	Nothing -> getContents
39		Just f -> readFile f
	44	Just f -> readFile f
40	45	case doRender cs of
41	46	Left err -> Sys.die err
42	47	Right rs -> case outF of
43	48	Nothing -> putStrLn rs
44		Just f -> writeFile f rs
	49	Just f -> writeFile f rs
45	50
46	51	main :: IO ()
47	52	main = do

49	54	case opts of
50	55	(fs, [], []) -> do
51	56	let Options
52		{ optInput = inF
53		, optOutput = outF
	57	{ optInput = inF,
	58	optOutput = outF
54	59	} = foldr id defaultOptions fs
55	60	runPipeline inF outF
56	61	(_, _, _) -> do

-4

telml-markup/test/Telml/MarkupSpec.hs less more

5	5	import Control.Monad ((>=>))
6	6	import Data.TeLML
7	7	import Data.TeLML.Markup
	8	import Test.Hspec
8	9	import Text.Blaze.Renderer.String (renderMarkup)
9
10		import Test.Hspec
11	10
12	11	main :: IO ()
13	12	main = hspec spec

23	22	it "should embolden" $ do
24	23	doRender "\\strong{foo}" `shouldBe` Right "<p><strong>foo</strong></p>"
25	24	it "should list" $ do
26		doRender "\\ul{\\li{one}\\li{two}}" `shouldBe`
27		Right "<p><ul><li>one</li><li>two</li></ul></p>"
	25	doRender "\\ul{\\li{one}\\li{two}}"
	26	`shouldBe` Right "<p><ul><li>one</li><li>two</li></ul></p>"

+35

-35

telml-parse/Data/TeLML/Parse.hs less more

1	1	{-# LANGUAGE RecordWildCards #-}
2	2
3	3	module Data.TeLML.Parse
4		( Fragment(..)
5		, Document
6		, Parse
7		, decode
8		, parse
9		, select
10		, field
11		, text
12		, document
13		, arg
14		, both
15		) where
	4	( Fragment (..),
	5	Document,
	6	Parse,
	7	decode,
	8	parse,
	9	select,
	10	field,
	11	text,
	12	document,
	13	arg,
	14	both,
	15	)
	16	where
16	17
	18	import Data.TeLML
17	19	import qualified Data.Text as T
18	20
19		import Data.TeLML
20
21		newtype Parse t a = Parse { ~~runParse :: t -> Either String a~~ }
	21	newtype Parse t a = Parse {runParse :: t -> Either String a}
22	22
23	23	decode :: String -> Parse Document r -> Either String r
24	24	decode str content = case parse str of
25	25	Left err -> Left err
26		Right x -> runParse content x
	26	Right x -> runParse content x
27	27
28	28	instance Functor (Parse t) where
29		fmap f (Parse g) = Parse (\ x -> fmap f (g x))
	29	fmap f (Parse g) = Parse (\x -> fmap f (g x))
30	30
31	31	instance Applicative (Parse t) where
32		pure x = Parse (\ _ -> Right x)
	32	pure x = Parse (\_ -> Right x)
33	33	f <*> x =
34		f >>= \ f' ->
35		x >>= \ x' ->
36		~~pure (f' x')~~
	34	f >>= \f' ->
	35	x >>= \x' ->
	36	pure (f' x')
37	37
38	38	instance Monad (Parse t) where
39		Parse x >>= f = Parse $ \ s ->
	39	Parse x >>= f = Parse $ \s ->
40	40	case x s of
41	41	Left err -> Left err
42	42	Right v -> runParse (f v) s
43	43
44	44	select :: T.Text -> Parse [Document] t -> Parse Document [t]
45		select name content = Parse $ \ s -> each s
	45	select name content = Parse $ \s -> each s
46	46	where
47	47	each [] = return []
48		each (TagFrag (Tag t doc):xs)
	48	each (TagFrag (Tag t doc) : xs)
49	49	\| t == name = (:) <$> runParse content doc <*> each xs
50		each (_:xs) = each xs
	50	each (_ : xs) = each xs
51	51
52	52	field :: T.Text -> (Parse [Document] t) -> Parse Document t
53		field name content = Parse $ \ s -> find s
	53	field name content = Parse $ \s -> find s
54	54	where
55	55	find [] = Left ("Unable to find tag \\" ++ T.unpack name)
56		find (TagFrag (Tag t doc):_)
	56	find (TagFrag (Tag t doc) : _)
57	57	\| t == name = runParse content doc
58		find (_:xs) = find xs
	58	find (_ : xs) = find xs
59	59
60	60	arg :: Parse Document t -> Parse [Document] t
61		arg f = Parse $ \ s ->
	61	arg f = Parse $ \s ->
62	62	case s of
63	63	[x] -> runParse f x
64	64	_ -> Left ("Wrong arity for `arg`: " ++ show (length s))
65	65
66
67	66	both :: Parse Document a -> Parse Document b -> Parse [Document] (a, b)
68		both l r = Parse $ \ s ->
	67	both l r = Parse $ \s ->
69	68	case s of
70	69	[a, b] -> (,) <$> runParse l a <*> runParse r b
71	70	_ -> Left ("Wrong arity for `both`: " ++ show (length s))
72	71
73	72	text :: Parse Document T.Text
74		text = Parse (\ s -> T.concat <$> traverse go s)
75		where go (TextFrag str) = Right str
76		~~go (TagFrag (Tag t _)) = Left ("Expected Text fragment, found \\" ++ T.unpack t~~)
	73	text = Parse (\s -> T.concat <$> traverse go s)
	74	where
	75	go (TextFrag str) = Right str
	76	go (TagFrag (Tag t _)) = Left ("Expected Text fragment, found \\" ++ T.unpack t)
77	77
78	78	document :: Parse Document Document
79		document = Parse (\ s -> Right s)
	79	document = Parse (\s -> Right s)