gdritter repos telml / 6448f18
Trying out typeclass approach instead Getty Ritter 7 years ago
1 changed file(s) with 113 addition(s) and 0 deletion(s). Collapse all Expand all
+113
-0
telml-markup/Data/TeLML/Markup.hs less more
11 {-# LANGUAGE LambdaCase #-}
22 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE ScopedTypeVariables #-}
34 {-# LANGUAGE ExistentialQuantification #-}
45 {-# LANGUAGE TypeOperators #-}
56 {-# LANGUAGE OverloadedStrings #-}
7 {-# LANGUAGE FlexibleInstances #-}
68
79 module Data.TeLML.Markup where
810
4951
5052 infixr 5 :=>
5153 data a :=> b = a :=> b deriving (Eq, Show)
54
55 class TagArguments t where
56 toType :: t -> [T.Text]
57 taExec :: t -> [Document] -> (Fragment -> HtmlE) -> Maybe HtmlE
58
59 instance (s ~ String, h ~ Html, m ~ Either s h) => TagArguments (() -> m) where
60 toType _ = []
61 taExec r [] go = Just (r ())
62 taExec r _ _ = Nothing
63
64 instance TagArguments r => TagArguments (Str -> r) where
65 toType _ = "_" : toType (undefined :: r)
66 taExec f ([TextFrag t]:rs) go = taExec (f (Str t)) rs go
67 taExec _ _ _ = Nothing
68
69 instance TagArguments r => TagArguments (Doc -> r) where
70 toType _ = "string" : toType (undefined :: r)
71 taExec f (doc:rs) go = taExec (f (Doc doc)) rs go
72 taExec _ [] _ = Nothing
73
74 instance TagArguments r => TagArguments (H -> r) where
75 toType _ = "_" : toType (undefined :: r)
76 taExec f (doc:rs) go =
77 let h = fmap sequence_ (mapM go doc)
78 in case h of
79 Left err -> return (Left err)
80 Right h' -> taExec (f (H h')) rs go
81 taExec _ [] _ = Nothing
82
83 instance (s ~ String, h ~ Html, m ~ Either s h) => TagArguments (Hs -> m) where
84 toType _ = ["..."]
85 taExec f docs go =
86 let h = fmap sequence_ (mapM go (concat docs))
87 in case h of
88 Left err -> return (Left err)
89 Right h' -> return (f (Hs h'))
90 taExec _ [] _ = Nothing
91
92 data Tag' = forall t. TagArguments t => Tag'
93 { tgName :: T.Text
94 , tgFunc :: t
95 }
96
97 newtype Str = Str T.Text deriving (Eq, Show)
98 newtype Doc = Doc Document deriving (Eq, Show)
99 newtype H = H Html
100 newtype Hs = Hs Html
101 newtype Docs = Docs [Document] deriving (Eq, Show)
102
103 exec :: T.Text -> [Document] -> [Tag'] -> Either String Html
104 exec name args (Tag' tag func:_)
105 | name == tag = case taExec func args undefined of
106 Nothing -> Left $ unwords [ "Tag"
107 , T.unpack ('\\' `T.cons` name)
108 , "expects argument structure"
109 , T.unpack ('\\' `T.cons` name `T.append`
110 T.intercalate "|" (toType func))
111 ]
112 Just x -> x
113 exec name args (_:rs) = exec name args rs
114 exec name args [] = Left $
115 "Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)
52116
53117 data Args t where
54118 EndArg :: Args ()
146210 exec name args (_:tags) = exec name args tags
147211 exec name args [] = Left $
148212 "Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)
213
214 -- The built-in set of tags (subject to change)
215 basicTags' :: [Tag']
216 basicTags' =
217 [ simpleTag' "em" em
218 , simpleTag' "strong" strong
219 , simpleTag' "li" li
220 , simpleTag' "h1" h1
221 , simpleTag' "h2" h2
222 , simpleTag' "p" (\ rs -> span ! class_ "para" $ rs)
223 , simpleTag' "blockquote" blockquote
224 , simpleTag' "tt" code
225 , simpleTag' "code" (pre . code)
226 , simpleTag' "ttcom" (\ rs -> span ! class_ "comment" $ rs)
227 , simpleTag' "ttkw" (\ rs -> span ! class_ "keyword" $ rs)
228 , simpleTag' "ttcn" (\ rs -> span ! class_ "constr" $ rs)
229 , simpleTag' "ttstr" (\ rs -> span ! class_ "string" $ rs)
230
231 , listTag' "ul" ul
232 , listTag' "ol" ol
233 , listTag' "center" (\ rs -> div ! class_ "center" $ rs)
234
235 , Tag' "br" (\ () -> return br)
236 , Tag' "comment" (\ () -> return "")
237 , Tag' "link" (\ (Str l) (H h) () ->
238 let go h = a ! href (toValue l) $ h
239 in return (go h))
240 , Tag' "img" (\ (Str l) (Str r) () ->
241 return (img ! src (toValue l) ! alt (toValue r)))
242 ]
243
244 simpleTag' :: T.Text -> (Markup -> Html) -> Tag'
245 simpleTag' name tag = Tag'
246 { tgName = name
247 , tgFunc = \ (H h) () ->
248 return (tag h)
249 }
250
251 listTag' :: T.Text -> (Markup -> Html) -> Tag'
252 listTag' name tag = Tag'
253 { tgName = name
254 , tgFunc = \ (Hs hs) -> return (tag hs)
255 }
256
257 -- render a single paragraph
258 renderPara' :: [Tag'] -> Document -> Either String Html
259 renderPara' taglist ds = fmap (p . sequence_) (mapM go ds)
260 where go (TextFrag ts) = Right (toMarkup ts)
261 go (TagFrag (Tag tx rs)) = exec tx rs taglist