gdritter repos telml / 4a5bada
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
11 {-# LANGUAGE LambdaCase #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE ExistentialQuantification #-}
4 {-# LANGUAGE TypeOperators #-}
25 {-# LANGUAGE OverloadedStrings #-}
36
47 module Data.TeLML.Markup where
1316 import Prelude hiding (div, span)
1417
1518 -- | 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
1720 renderWith rs =
1821 fmap (void . sequence) . mapM (renderPara (basicTags ++ rs)) . gatherPara
1922
4447
4548 type Renderer = (Fragment -> HtmlE, [Document]) -> HtmlE
4649
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
47103 -- The built-in set of tags (subject to change)
48 basicTags :: [(T.Text, Renderer)]
104 basicTags :: [TagDescription]
49105 basicTags =
50106 [ simpleTag "em" em
51107 , simpleTag "strong" strong
60116 , simpleTag "ttkw" (\ rs -> span ! class_ "keyword" $ rs)
61117 , simpleTag "ttcn" (\ rs -> span ! class_ "constr" $ rs)
62118 , simpleTag "ttstr" (\ rs -> span ! class_ "string" $ rs)
119
63120 , listTag "ul" ul
64121 , listTag "ol" ol
65122 , 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))
79131 ]
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 )
90132
91133 -- render a single paragraph
92 renderPara :: [(T.Text, Renderer)] -> Document -> Either String Html
134 renderPara :: [TagDescription] -> Document -> Either String Html
93135 renderPara taglist ds = fmap (p . sequence_) (mapM go ds)
94136 where go (TextFrag ts) = Right (toMarkup ts)
95137 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
100146 exec name args (_:tags) = exec name args tags
101147 exec name args [] = Left $
102148 "Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)