Trying out typeclass approach instead
Getty Ritter
6 years ago
| 1 | 1 | {-# LANGUAGE LambdaCase #-} |
| 2 | 2 | {-# LANGUAGE GADTs #-} |
| 3 | {-# LANGUAGE ScopedTypeVariables #-} | |
| 3 | 4 | {-# LANGUAGE ExistentialQuantification #-} |
| 4 | 5 | {-# LANGUAGE TypeOperators #-} |
| 5 | 6 | {-# LANGUAGE OverloadedStrings #-} |
| 7 | {-# LANGUAGE FlexibleInstances #-} | |
| 6 | 8 | |
| 7 | 9 | module Data.TeLML.Markup where |
| 8 | 10 | |
| 49 | 51 | |
| 50 | 52 | infixr 5 :=> |
| 51 | 53 | 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) | |
| 52 | 116 | |
| 53 | 117 | data Args t where |
| 54 | 118 | EndArg :: Args () |
| 146 | 210 | exec name args (_:tags) = exec name args tags |
| 147 | 211 | exec name args [] = Left $ |
| 148 | 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 | |