Commit 4a5bada1c5cdc8fe0df694370edc4fec02d864e3 - telml

Replace old partial approach with GADT callbacks Getty Ritter 6 years ago

1 changed file(s) with 76 addition(s) and 30 deletion(s). Collapse all Expand all

+76

-30

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

1	1	{-# LANGUAGE LambdaCase #-}
	2	{-# LANGUAGE GADTs #-}
	3	{-# LANGUAGE ExistentialQuantification #-}
	4	{-# LANGUAGE TypeOperators #-}
2	5	{-# LANGUAGE OverloadedStrings #-}
3	6
4	7	module Data.TeLML.Markup where

13	16	import Prelude hiding (div, span)
14	17
15	18	-- \| Render a TeLML document with an extra set of possible tags.
16		renderWith :: [~~(T.Text, Renderer)~~] -> Document -> Either String Html
	19	renderWith :: [TagDescription] -> Document -> Either String Html
17	20	renderWith rs =
18	21	fmap (void . sequence) . mapM (renderPara (basicTags ++ rs)) . gatherPara
19	22

44	47
45	48	type Renderer = (Fragment -> HtmlE, [Document]) -> HtmlE
46	49
	50	infixr 5 :=>
	51	data a :=> b = a :=> b deriving (Eq, Show)
	52
	53	data Args t where
	54	EndArg :: Args ()
	55	ListArg :: Args [Document]
	56	FragmentArg :: Args rest -> Args (Document :=> rest)
	57	TextArg :: Args rest -> Args (T.Text :=> rest)
	58
	59	matchArguments :: Args t -> [Document] -> Maybe t
	60	matchArguments EndArg [] = return ()
	61	matchArguments EndArg _ = Nothing
	62	matchArguments ListArg ds = return ds
	63	matchArguments (FragmentArg rs) (d:ds) =
	64	(d :=>) `fmap` matchArguments rs ds
	65	matchArguments (FragmentArg EndArg) [] = return ([TextFrag ""] :=> ())
	66	matchArguments (FragmentArg _) [] = Nothing
	67	matchArguments (TextArg rs) ([TextFrag t]:ds) =
	68	(t :=>) `fmap` matchArguments rs ds
	69	matchArguments (TextArg _) _ = Nothing
	70
	71	argType :: Args t -> T.Text
	72	argType t = "{" `T.append` T.intercalate "\|" (toType t) `T.append` "}"
	73	where
	74	toType :: Args t -> [T.Text]
	75	toType EndArg = []
	76	toType ListArg = ["..."]
	77	toType (FragmentArg rs) = "_" : toType rs
	78	toType (TextArg rs) = "string" : toType rs
	79
	80	data TagDescription = forall t. TagDescription
	81	{ tdName :: T.Text
	82	, tdArgs :: Args t
	83	, tdAction :: t -> (Fragment -> HtmlE) -> HtmlE
	84	}
	85
	86	simpleTag :: T.Text -> (Markup -> Html) -> TagDescription
	87	simpleTag name tag = TagDescription
	88	{ tdName = name
	89	, tdArgs = FragmentArg EndArg
	90	, tdAction = \ (fragment :=> ()) f ->
	91	fmap (tag . sequence_) (mapM f fragment)
	92	}
	93
	94	listTag :: T.Text -> (Markup -> Html) -> TagDescription
	95	listTag name tag = TagDescription
	96	{ tdName = name
	97	, tdArgs = ListArg
	98	, tdAction = \ rs f ->
	99	fmap (tag . sequence_) (mapM f (concat rs))
	100	}
	101
	102
47	103	-- The built-in set of tags (subject to change)
48		basicTags :: [~~(T.Text, Renderer)~~]
	104	basicTags :: [TagDescription]
49	105	basicTags =
50	106	[ simpleTag "em" em
51	107	, simpleTag "strong" strong

60	116	, simpleTag "ttkw" (\ rs -> span ! class_ "keyword" $ rs)
61	117	, simpleTag "ttcn" (\ rs -> span ! class_ "constr" $ rs)
62	118	, simpleTag "ttstr" (\ rs -> span ! class_ "string" $ rs)
	119
63	120	, listTag "ul" ul
64	121	, listTag "ol" ol
65	122	, listTag "center" (\ rs -> div ! class_ "center" $ rs)
66		, ("br", \_ -> return br)
67		, ("comment", \_ -> return "")
68		, ("link"
69		, \case (f,[[TextFrag l],r]) -> let go h = a ! href (toValue l) $ h
70		in fmap (go . sequence_) (mapM f r)
71		(_,[_,_]) -> Left "link target should be string"
72		_ -> Left "wrong arity for link/1"
73		)
74		, ("img"
75		, \case (_, [[TextFrag l]]) -> return (img ! src (toValue l))
76		(_,[_]) -> Left "image target should be string"
77		_ -> Left "wrong arity for img/1"
78		)
	123
	124	, TagDescription "br" EndArg (\ () _ -> return br)
	125	, TagDescription "comment" ListArg (\ _ _ -> return "")
	126	, TagDescription "link" (TextArg (FragmentArg EndArg)) $ \ (l :=> r :=> ()) f ->
	127	let go h = a ! href (toValue l) $ h
	128	in fmap (go . sequence_) (mapM f r)
	129	, TagDescription "img" (TextArg (TextArg EndArg)) $ \ (l :=> r :=> ()) _ ->
	130	return (img ! src (toValue l) ! alt (toValue r))
79	131	]
80		where simpleTag :: T.Text -> (Html -> Html) -> (T.Text, Renderer)
81		simpleTag name tag =
82		( name
83		, \case (f,[rs]) -> fmap (tag . sequence_) (mapM f rs)
84		_ -> Left ("wrong arity for " ++ T.unpack name ++ "/1")
85		)
86		listTag name tag =
87		( name
88		, \case (f,rs) -> fmap (tag . sequence_) (mapM f (concat rs))
89		)
90	132
91	133	-- render a single paragraph
92		renderPara :: [~~(T.Text, Renderer)~~] -> Document -> Either String Html
	134	renderPara :: [TagDescription] -> Document -> Either String Html
93	135	renderPara taglist ds = fmap (p . sequence_) (mapM go ds)
94	136	where go (TextFrag ts) = Right (toMarkup ts)
95	137	go (TagFrag (Tag tx rs)) = exec tx rs taglist
96		exec name args ((tag, func):tags)
97		\| name == tag = case func (go, args) of
98		Right html -> Right html
99		Left {} -> exec name args tags
	138	exec name args (TagDescription tag rg func:_)
	139	\| name == tag = case matchArguments rg args of
	140	Nothing -> Left $ unwords [ "Tag"
	141	, T.unpack ('\\' `T.cons` name)
	142	, "expects argument structure"
	143	, T.unpack ('\\' `T.cons` name `T.append` argType rg)
	144	]
	145	Just x -> func x go
100	146	exec name args (_:tags) = exec name args tags
101	147	exec name args [] = Left $
102	148	"Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)