]> Git — Sourcephile - doclang.git/blob - Language/TCT/Read/Elem.hs
Simplify Token parsing.
[doclang.git] / Language / TCT / Read / Elem.hs
1 {-# LANGUAGE FlexibleContexts #-}
2 {-# LANGUAGE OverloadedStrings #-}
3 {-# LANGUAGE Rank2Types #-}
4 {-# LANGUAGE TypeFamilies #-}
5 module Language.TCT.Read.Elem where
6
7 import Control.Applicative (Applicative(..), Alternative(..))
8 import Control.Monad ((>>))
9 import Data.Bool
10 import Data.Char (Char)
11 import Data.Eq (Eq(..))
12 import Data.Function (($))
13 import Data.Functor ((<$>))
14 import Data.Semigroup (Semigroup(..))
15 import Data.String (String)
16 import Data.Text (Text)
17 import Text.Show (Show(..))
18 import qualified Data.Char as Char
19 import qualified Data.Text as Text
20 import qualified Text.Megaparsec as P
21
22 import Language.TCT.Elem
23
24 -- * Type 'Parser'
25 -- | Convenient alias.
26 type Parser e s a =
27 ( P.ErrorComponent e
28 , P.ShowErrorComponent e
29 , P.Stream s
30 , P.Token s ~ Char
31 ) => P.Parsec e s a
32
33 pdbg :: ( Show a
34 , P.ErrorComponent e
35 , P.ShowErrorComponent e
36 , P.Stream s
37 , P.Token s ~ Char
38 , P.ShowToken (P.Token s)
39 , P.Stream s
40 ) => String -> P.ParsecT e s m a -> P.ParsecT e s m a
41 -- pdbg m p = P.dbg m p
42 pdbg _m p = p
43 {-# INLINE pdbg #-}
44
45 p_Attrs :: Parser e s [(Text,Attr)]
46 p_Attrs = P.many $ P.try $ (,) <$> p_Spaces <*> p_Attr
47 p_Attr :: Parser e s Attr
48 p_Attr = P.try p_Attr_Eq <|> p_Attr_Word
49 p_Spaces :: Parser e s Text
50 p_Spaces = Text.pack <$> P.some (P.satisfy Char.isSpace)
51 p_Attr_Eq :: Parser e s Attr
52 p_Attr_Eq =
53 (\n (o,v,c) -> Attr n ("="<>o) v c)
54 <$> p_Word
55 <* P.char '='
56 <*> p_Attr_Value
57 p_Attr_Word :: Parser e s Attr
58 p_Attr_Word =
59 (\(o,v,c) -> Attr "" o v c)
60 <$> p_Attr_Value_Word
61 p_Attr_Value :: Parser e s (Text,Text,Text)
62 p_Attr_Value =
63 p_Attr_Value_Quote '\'' <|>
64 p_Attr_Value_Quote '"' <|>
65 p_Attr_Value_Word
66 p_Attr_Value_Quote :: Char -> Parser e s (Text,Text,Text)
67 p_Attr_Value_Quote q =
68 (\o v c -> (Text.singleton o, Text.pack v, Text.singleton c))
69 <$> P.char q
70 <*> P.many (
71 P.notFollowedBy (P.string "/>") >>
72 P.satisfy (\c -> Char.isPrint c && c /= '>' && c/=q))
73 <*> P.char q
74 p_Attr_Value_Word :: Parser e s (Text,Text,Text)
75 p_Attr_Value_Word =
76 (\v -> ("", Text.pack v, ""))
77 <$> P.many (P.satisfy Char.isAlphaNum)
78
79 p_Word :: Parser e s Text
80 p_Word = pdbg "Word" $
81 (<>)
82 <$> p_plain
83 <*> P.option "" (p_plain <|> p_link)
84 where
85 p_link = P.try $
86 (<>)
87 <$> (Text.pack <$> P.some (P.satisfy (\c -> c=='_' || c=='-')))
88 <*> p_plain
89 p_plain =
90 Text.pack
91 <$> P.some (P.satisfy $ \c ->
92 Char.isLetter c ||
93 Char.isNumber c
94 )