gdritter repos telml / b51f95b
Update data format + use Text Getty Ritter 6 years ago
9 changed file(s) with 64 addition(s) and 47 deletion(s). Collapse all Expand all
+5
-3
telml/Data/TeLML/Parser.hs less more
11 {-# LANGUAGE LambdaCase #-}
22
3 module Data.TeLML.Parser (Fragment(..), Document, parse) where
3 module Data.TeLML.Parser (Fragment(..), Tag(..), Document, parse) where
44
55 import Data.Char (isAlpha, isAlphaNum, isSpace)
66 import Data.TeLML.Type
7
8 import qualified Data.Text as T
79
810 type Result a = Either String (String, a)
911 type Parse a = String -> Result a
4244 -- Parse a text fragment, handling escapes. This will end as soon as it
4345 -- sees any non-escaped special character.
4446 pText :: Parse Fragment
45 pText = over Text . go
47 pText = over (TextFrag . T.pack) . go
4648 where go ('\\':x:xs)
4749 | isSpecial x = (x:) `over` go xs
4850 go i@(x:xs)
7880 pTag i =
7981 bind (pTagName i) $ \ (i', name) ->
8082 bind (skipSpace i') $ \case
81 ('{':i'', ()) -> Tag name `over` pArgs i''
83 ('{':i'', ()) -> TagFrag `over` (Tag (T.pack name) `over` pArgs i'')
8284 ("",_) -> throw "unexpected end-of-document while parsing tag"
8385 _ -> throw "expected start of block"
8486
+19
-10
telml/Data/TeLML/Type.hs less more
11 {-# LANGUAGE DeriveDataTypeable #-}
22
3 module Data.TeLML.Type (Document, Fragment(..)) where
3 module Data.TeLML.Type (Document, Fragment(..), Tag(..)) where
44
5 import Control.DeepSeq (NFData(..))
6 import Data.Data (Data)
7 import Data.Typeable (Typeable)
8 import Data.String (IsString(..))
5 import Control.DeepSeq (NFData(..))
6 import Data.Data (Data)
7 import qualified Data.Text as T
8 import Data.Typeable (Typeable)
9 import Data.String (IsString(..))
910
1011 -- | A 'Document' is zero or more 'Fragment's.
1112 type Document = [Fragment]
1516 -- constructor). The former is a raw string, and the latter consists
1617 -- of a name followed by zero or more 'Document's.
1718 data Fragment
18 = Text String
19 | Tag String [Document]
19 = TextFrag T.Text
20 | TagFrag Tag
2021 deriving (Eq, Show, Typeable, Data)
2122
23 data Tag = Tag
24 { tagName :: T.Text
25 , tagPayload :: [Document]
26 } deriving (Eq, Show, Typeable, Data)
27
2228 instance IsString Fragment where
23 fromString = Text
29 fromString = TextFrag . fromString
2430
2531 instance NFData Fragment where
26 rnf (Text s) = rnf s
27 rnf (Tag s l) = rnf s `seq` rnf l
32 rnf (TextFrag s) = rnf s
33 rnf (TagFrag t) = rnf t
34
35 instance NFData Tag where
36 rnf (Tag n l) = rnf n `seq` rnf l
+1
-1
telml/Data/TeLML.hs less more
1 module Data.TeLML(parse, Document, Fragment(..)) where
1 module Data.TeLML(parse, Document, Fragment(..), Tag(..)) where
22
33 import Data.TeLML.Parser
+2
-1
telml/telml.cabal less more
1616 ghc-options: -Wall
1717 other-modules: Data.TeLML.Parser, Data.TeLML.Type
1818 build-depends: base >=4.7 && <5,
19 deepseq >=1.4 && <2
19 deepseq >=1.4 && <2,
20 text
2021 default-language: Haskell2010
2122
2223 source-repository head
+18
-20
telml-markup/Data/TeLML/Markup.hs less more
55
66 import Control.Monad (void)
77 import Data.TeLML
8 import qualified Data.Text as T
89 import Text.Blaze.Html
910 import Text.Blaze.Html5 hiding (map, head, html)
1011 import Text.Blaze.Html5.Attributes hiding (name, span)
1213 import Prelude hiding (div, span)
1314
1415 -- | Render a TeLML document with an extra set of possible tags.
15 renderWith :: [(String, Renderer)] -> Document -> Either String Html
16 renderWith :: [(T.Text, Renderer)] -> Document -> Either String Html
1617 renderWith rs =
1718 fmap (void . sequence) . mapM (renderPara (basicTags ++ rs)) . gatherPara
1819
2627 gatherPara :: Document -> [Document]
2728 gatherPara = reverse . map reverse . go [[]]
2829 where go rs [] = rs
29 go (r:rs) (t@Tag {}:ts) = go ((t:r):rs) ts
30 go (r:rs) (Text s:ts) = case splitString s of
30 go (r:rs) (t@TagFrag {}:ts) = go ((t:r):rs) ts
31 go (r:rs) (TextFrag s:ts) = case splitString s of
3132 [] -> go (r:rs) ts
32 [x] -> go ((Text x:r):rs) ts
33 xs -> go (map ((:[]) . Text) (tail xs) ++
34 ((Text (head xs):r) : rs)) ts
33 [x] -> go ((TextFrag x:r):rs) ts
34 xs -> go (map ((:[]) . TextFrag) (tail xs) ++
35 ((TextFrag (head xs):r) : rs)) ts
3536 go _ _ = error "[unreachable]"
3637
3738 -- Split a string at double-newlines.
38 splitString :: String -> [String]
39 splitString = filter (/= "") . go
40 where go ('\n':'\n':xs) = "\n":go xs
41 go (x:xs) = let r:rs = go xs in ((x:r):rs)
42 go "" = [""]
39 splitString :: T.Text -> [T.Text]
40 splitString = T.splitOn "\n\n"
4341
4442 -- This is just to make type signatures shorter
4543 type HtmlE = Either String Html
4745 type Renderer = (Fragment -> HtmlE, [Document]) -> HtmlE
4846
4947 -- The built-in set of tags (subject to change)
50 basicTags :: [(String, Renderer)]
48 basicTags :: [(T.Text, Renderer)]
5149 basicTags =
5250 [ simpleTag "em" em
5351 , simpleTag "strong" strong
6866 , ("br", \_ -> return br)
6967 , ("comment", \_ -> return "")
7068 , ("link"
71 , \case (f,[[Text l],r]) -> let go h = a ! href (stringValue l) $ h
69 , \case (f,[[TextFrag l],r]) -> let go h = a ! href (toValue l) $ h
7270 in fmap (go . sequence_) (mapM f r)
7371 (_,[_,_]) -> Left "link target should be string"
7472 _ -> Left "wrong arity for link/1"
7573 )
7674 , ("img"
77 , \case (_, [[Text l]]) -> return (img ! src (stringValue l))
75 , \case (_, [[TextFrag l]]) -> return (img ! src (toValue l))
7876 (_,[_]) -> Left "image target should be string"
7977 _ -> Left "wrong arity for img/1"
8078 )
8179 ]
82 where simpleTag :: String -> (Html -> Html) -> (String, Renderer)
80 where simpleTag :: T.Text -> (Html -> Html) -> (T.Text, Renderer)
8381 simpleTag name tag =
8482 ( name
8583 , \case (f,[rs]) -> fmap (tag . sequence_) (mapM f rs)
86 _ -> Left ("wrong arity for " ++ name ++ "/1")
84 _ -> Left ("wrong arity for " ++ T.unpack name ++ "/1")
8785 )
8886 listTag name tag =
8987 ( name
9189 )
9290
9391 -- render a single paragraph
94 renderPara :: [(String, Renderer)] -> Document -> Either String Html
92 renderPara :: [(T.Text, Renderer)] -> Document -> Either String Html
9593 renderPara taglist ds = fmap (p . sequence_) (mapM go ds)
96 where go (Text ts) = Right (toMarkup ts)
97 go (Tag tx rs) = exec tx rs taglist
94 where go (TextFrag ts) = Right (toMarkup ts)
95 go (TagFrag (Tag tx rs)) = exec tx rs taglist
9896 exec name args ((tag, func):tags)
9997 | name == tag = case func (go, args) of
10098 Right html -> Right html
10199 Left {} -> exec name args tags
102100 exec name args (_:tags) = exec name args tags
103101 exec name args [] = Left $
104 "Error: no match for tag " ++ name ++ "/" ++ show (length args)
102 "Error: no match for tag " ++ T.unpack name ++ "/" ++ show (length args)
+5
-1
telml-markup/telml-markup.cabal less more
2020 telml,
2121 blaze-markup,
2222 blaze-html,
23 mtl
23 mtl,
24 text
2425
2526 test-suite spec
27 default-language: Haskell2010
2628 type: exitcode-stdio-1.0
2729 ghc-options: -Wall
2830 hs-source-dirs: test
2931 main-is: Spec.hs
32 other-modules: Telml.MarkupSpec
3033 build-depends: base == 4.*
3134 , telml
3235 , telml-markup
3336 , hspec == 2.*
3437 , blaze-markup
38 build-tools: hspec-discover
3539
3640 source-repository head
3741 type: git
+1
-1
telml-markup/test/Telml/MarkupSpec.hs less more
2222 doRender "\\em{foo}" `shouldBe` Right "<p><em>foo</em></p>"
2323 it "should embolden" $ do
2424 doRender "\\strong{foo}" `shouldBe` Right "<p><strong>foo</strong></p>"
25 it "should lis" $ do
25 it "should list" $ do
2626 doRender "\\ul{\\li{one}\\li{two}}" `shouldBe`
2727 Right "<p><ul><li>one</li><li>two</li></ul></p>"
+11
-9
telml-parse/Data/TeLML/Parse.hs less more
1313 , arg
1414 , both
1515 ) where
16
17 import qualified Data.Text as T
1618
1719 import Data.TeLML
1820
3941 Left err -> Left err
4042 Right v -> runParse (f v) s
4143
42 select :: String -> Parse [Document] t -> Parse Document [t]
44 select :: T.Text -> Parse [Document] t -> Parse Document [t]
4345 select name content = Parse $ \ s -> each s
4446 where
4547 each [] = return []
46 each (Tag t doc:xs)
48 each (TagFrag (Tag t doc):xs)
4749 | t == name = (:) <$> runParse content doc <*> each xs
4850 each (_:xs) = each xs
4951
50 field :: String -> (Parse [Document] t) -> Parse Document t
52 field :: T.Text -> (Parse [Document] t) -> Parse Document t
5153 field name content = Parse $ \ s -> find s
5254 where
53 find [] = Left ("Unable to find tag \\" ++ name)
54 find (Tag t doc:_)
55 find [] = Left ("Unable to find tag \\" ++ T.unpack name)
56 find (TagFrag (Tag t doc):_)
5557 | t == name = runParse content doc
5658 find (_:xs) = find xs
5759
6870 [a, b] -> (,) <$> runParse l a <*> runParse r b
6971 _ -> Left ("Wrong arity for `both`: " ++ show (length s))
7072
71 text :: Parse Document String
72 text = Parse (\ s -> concat <$> traverse go s)
73 where go (Text str) = Right str
74 go (Tag t _) = Left ("Expected Text fragment, found \\" ++ show t)
73 text :: Parse Document T.Text
74 text = Parse (\ s -> T.concat <$> traverse go s)
75 where go (TextFrag str) = Right str
76 go (TagFrag (Tag t _)) = Left ("Expected Text fragment, found \\" ++ T.unpack t)
7577
7678 document :: Parse Document Document
7779 document = Parse (\ s -> Right s)
+2
-1
telml-parse/telml-parse.cabal less more
1515 exposed-modules: Data.TeLML.Parse
1616 ghc-options: -Wall
1717 build-depends: base >=4.7 && <5,
18 telml ==0.1.0.0
18 telml ==0.1.0.0,
19 text
1920 default-language: Haskell2010
2021
2122 source-repository head