gdritter repos telml / 4a9e61e
Drop GADT in favor of simpler typeclasses Getty Ritter 7 years ago
1 changed file(s) with 42 addition(s) and 141 deletion(s). Collapse all Expand all
+42
-141
telml-markup/Data/TeLML/Markup.hs less more
4444 splitString :: T.Text -> [T.Text]
4545 splitString = T.splitOn "\n\n"
4646
47 -- This is just to make type signatures shorter
48 type HtmlE = Either String Html
4947
50 type Renderer = (Fragment -> HtmlE, [Document]) -> HtmlE
51
52 infixr 5 :=>
53 data a :=> b = a :=> b deriving (Eq, Show)
54
48 -- | The 'TagArguments' class allow us to define a new tag with a name
49 -- and a simple function, and cuts out a lot of the boilerplate.
5550 class TagArguments t where
5651 toType :: t -> [T.Text]
57 taExec :: t -> [Document] -> (Fragment -> HtmlE) -> Maybe HtmlE
52 taExec :: t
53 -> [Document]
54 -> (Fragment -> Either String Html)
55 -> Maybe (Either String Html)
5856
59 instance (s ~ String, h ~ Html, m ~ Either s h) => TagArguments (() -> m) where
57 instance TagArguments Html where
6058 toType _ = []
61 taExec r [] go = Just (r ())
62 taExec r _ _ = Nothing
59 taExec h [] _ = Just (Right h)
60 taExec _ _ _ = Nothing
6361
6462 instance TagArguments r => TagArguments (Str -> r) where
6563 toType _ = "_" : toType (undefined :: r)
6664 taExec f ([TextFrag t]:rs) go = taExec (f (Str t)) rs go
6765 taExec _ _ _ = Nothing
6866
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
67 instance TagArguments r => TagArguments (Maybe Str -> r) where
68 toType _ = "_" : toType (undefined :: r)
69 taExec f ([TextFrag t]:rs) go = taExec (f (Just (Str t))) rs go
70 taExec f [] go = taExec (f Nothing) [] go
71 taExec _ _ _ = Nothing
7372
7473 instance TagArguments r => TagArguments (H -> r) where
7574 toType _ = "_" : toType (undefined :: r)
8079 Right h' -> taExec (f (H h')) rs go
8180 taExec _ [] _ = Nothing
8281
83 instance (s ~ String, h ~ Html, m ~ Either s h) => TagArguments (Hs -> m) where
82 instance (h ~ Html) => TagArguments (Hs -> h) where
8483 toType _ = ["..."]
8584 taExec f docs go =
8685 let h = fmap sequence_ (mapM go (concat docs))
8786 in case h of
8887 Left err -> return (Left err)
89 Right h' -> return (f (Hs h'))
90 taExec _ [] _ = Nothing
88 Right h' -> return (Right (f (Hs h')))
9189
92 data Tag' = forall t. TagArguments t => Tag'
90 data TagDescription = forall t. TagArguments t => TagDescription
9391 { tgName :: T.Text
9492 , tgFunc :: t
9593 }
9694
97 newtype Str = Str T.Text deriving (Eq, Show)
98 newtype Doc = Doc Document deriving (Eq, Show)
95 -- | The 'Str' newtype will match a literal chunk of non-formatted,
96 -- non-structured text.
97 newtype Str = Str { fromStr :: T.Text } deriving (Eq, Show)
98
99 -- | The 'H' newtype will match a single, pre-rendered argument
99100 newtype H = H Html
101
102 -- | The 'Hs' newtype will match a concatenated set of pre-rendered
103 -- arguments
100104 newtype Hs = Hs Html
101 newtype Docs = Docs [Document] deriving (Eq, Show)
102105
103 exec :: T.Text -> [Document] -> [Tag'] -> Either String Html
104 exec name args (Tag' tag func:_)
106 mkTag :: TagArguments t => T.Text -> t -> TagDescription
107 mkTag = TagDescription
108
109 exec :: T.Text -> [Document] -> [TagDescription] -> Either String Html
110 exec name args (TagDescription tag func:_)
105111 | name == tag = case taExec func args undefined of
106112 Nothing -> Left $ unwords [ "Tag"
107113 , T.unpack ('\\' `T.cons` name)
113119 exec name args (_:rs) = exec name args rs
114120 exec name args [] = Left $
115121 "Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)
116
117 data Args t where
118 EndArg :: Args ()
119 ListArg :: Args [Document]
120 FragmentArg :: Args rest -> Args (Document :=> rest)
121 TextArg :: Args rest -> Args (T.Text :=> rest)
122
123 matchArguments :: Args t -> [Document] -> Maybe t
124 matchArguments EndArg [] = return ()
125 matchArguments EndArg _ = Nothing
126 matchArguments ListArg ds = return ds
127 matchArguments (FragmentArg rs) (d:ds) =
128 (d :=>) `fmap` matchArguments rs ds
129 matchArguments (FragmentArg EndArg) [] = return ([TextFrag ""] :=> ())
130 matchArguments (FragmentArg _) [] = Nothing
131 matchArguments (TextArg rs) ([TextFrag t]:ds) =
132 (t :=>) `fmap` matchArguments rs ds
133 matchArguments (TextArg _) _ = Nothing
134
135 argType :: Args t -> T.Text
136 argType t = "{" `T.append` T.intercalate "|" (toType t) `T.append` "}"
137 where
138 toType :: Args t -> [T.Text]
139 toType EndArg = []
140 toType ListArg = ["..."]
141 toType (FragmentArg rs) = "_" : toType rs
142 toType (TextArg rs) = "string" : toType rs
143
144 data TagDescription = forall t. TagDescription
145 { tdName :: T.Text
146 , tdArgs :: Args t
147 , tdAction :: t -> (Fragment -> HtmlE) -> HtmlE
148 }
149
150 simpleTag :: T.Text -> (Markup -> Html) -> TagDescription
151 simpleTag name tag = TagDescription
152 { tdName = name
153 , tdArgs = FragmentArg EndArg
154 , tdAction = \ (fragment :=> ()) f ->
155 fmap (tag . sequence_) (mapM f fragment)
156 }
157
158 listTag :: T.Text -> (Markup -> Html) -> TagDescription
159 listTag name tag = TagDescription
160 { tdName = name
161 , tdArgs = ListArg
162 , tdAction = \ rs f ->
163 fmap (tag . sequence_) (mapM f (concat rs))
164 }
165
166122
167123 -- The built-in set of tags (subject to change)
168124 basicTags :: [TagDescription]
185141 , listTag "ol" ol
186142 , listTag "center" (\ rs -> div ! class_ "center" $ rs)
187143
188 , TagDescription "br" EndArg (\ () _ -> return br)
189 , TagDescription "comment" ListArg (\ _ _ -> return "")
190 , TagDescription "link" (TextArg (FragmentArg EndArg)) $ \ (l :=> r :=> ()) f ->
191 let go h = a ! href (toValue l) $ h
192 in fmap (go . sequence_) (mapM f r)
193 , TagDescription "img" (TextArg (TextArg EndArg)) $ \ (l :=> r :=> ()) _ ->
194 return (img ! src (toValue l) ! alt (toValue r))
144 , TagDescription "br" br
145 , TagDescription "comment" ("" :: Html)
146 , TagDescription "link" (\ (Str l) (H h) -> a ! href (toValue l) $ h)
147 , TagDescription "img" $ \ (Str l) altText -> case altText of
148 Just (Str r) -> img ! src (toValue l) ! alt (toValue r)
149 Nothing -> img ! src (toValue l)
195150 ]
151
152 simpleTag :: T.Text -> (Markup -> Html) -> TagDescription
153 simpleTag name tag = mkTag name (\ (H h) -> tag h)
154
155 listTag :: T.Text -> (Markup -> Html) -> TagDescription
156 listTag name tag = mkTag name (\ (Hs hs) -> tag hs)
196157
197158 -- render a single paragraph
198159 renderPara :: [TagDescription] -> Document -> Either String Html
199160 renderPara taglist ds = fmap (p . sequence_) (mapM go ds)
200161 where go (TextFrag ts) = Right (toMarkup ts)
201162 go (TagFrag (Tag tx rs)) = exec tx rs taglist
202 exec name args (TagDescription tag rg func:_)
203 | name == tag = case matchArguments rg args of
204 Nothing -> Left $ unwords [ "Tag"
205 , T.unpack ('\\' `T.cons` name)
206 , "expects argument structure"
207 , T.unpack ('\\' `T.cons` name `T.append` argType rg)
208 ]
209 Just x -> func x go
210 exec name args (_:tags) = exec name args tags
211 exec name args [] = Left $
212 "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