git.iko.soy/typeable/hexml
on master help sign in
typeable/hexml/gen/Parser.hs
76 lines 1.8 kB history raw
2module Parser(Out(..), html) where
4import Lib
6data Out
7 = NameStart | NameEnd
8 | QuoteStart | QuoteEnd
9 | AttribsStart | AttribsEnd
10 | Tag
11 | TagComment | TagOpen | TagClose | TagOpenClose
12 deriving Show
14is lower upper x = x >= lower && x <= upper
15isName1 x = x == ':' || x == '_' || is 'a' 'z' x || is 'A' 'Z' x
16isName x = isName1 x || x == '-' || x == '.' || is '0' '9' x
17isSpace x = x == ' ' || x == '\t' || x == '\r' || x == '\n'
19whitespace = many $ match isSpace
21name = do
22 out NameStart
23 match isName1
24 many $ match isName
25 out NameEnd
26 whitespace
28attrib = do
29 name
30 lit "=" `choice` abort "Expected = in attribute but missing"
31 whitespace
32 let quoted x = do
33 lit [x]
34 out QuoteStart
35 many $ match (/= x)
36 out QuoteEnd
37 lit [x] `choice` abort ("Couldn't find closing attribute quote (expected " ++ [x] ++ ")")
38 whitespace
39 choices
40 [quoted '\"'
41 ,quoted '\''
42 ,abort "Invalid attribute, expected quote (either ' or \")"]
44attribs = do
45 out AttribsStart
46 many attrib
47 out AttribsEnd
49tag = do
50 out Tag
51 lit "<"
52 let name_ = name `choice` abort "Missing tag name"
53 choices
54 [do lit "!--"
55 many $ match (/= '-')
56 -- FIXME: Not correct!!!
57 lit "-->"
58 out TagComment
59 ,do lit "?"
60 name_
61 attribs
62 lit "?>"
63 out TagOpenClose
64 ,do lit "/"
65 name_
66 lit ">"
67 out TagClose
68 ,do name_
69 attribs
70 choice
71 (lit "/>" >> out TagOpenClose)
72 (lit ">" >> out TagOpen)
73 ]
76html = many $ choice tag $ match $ const True