@@ -0,0 +1,206 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+
3+module Lib(
4+ Parser,
5+ out, many, optional, match, lit, choice, abort, choices,
6+ run,
7+ compile
8+ ) where
9+
10+import Control.Monad.Extra
11+import Control.Monad.Trans.Writer
12+import Data.Char
13+import Data.Maybe
14+import Data.List
15+import Data.Data
16+import Data.Bits
17+import Data.Monoid
18+import Numeric
19+
20+
21+run :: Parser o () -> String -> ([(Int, o)], (Int, String), Maybe String)
22+run p = runC (toC $ toP p)
23+
24+compile :: Show o => Parser o () -> [String]
25+compile = prettyC . optimiseC . toC . toP
26+
27+---------------------------------------------------------------------
28+-- THE UNDERLYING PARSER TYPE
29+
30+data P o
31+ = Empty
32+ | Seq (P o) (P o)
33+ | Choice (P o) (P o)
34+ | Match CharSet
35+ | Many (P o)
36+ | Out o
37+ | Panic String
38+ deriving Show
39+
40+instance Monoid (P o) where
41+ mempty = Empty
42+ mappend = Seq
43+
44+newtype Parser o a = Parser (Writer (P o) a)
45+ deriving (Functor, Applicative, Monad)
46+
47+toP :: Parser o a -> P o
48+toP (Parser p) = execWriter p
49+
50+out :: o -> Parser o ()
51+out o = Parser $ tell $ Out o
52+
53+abort :: String -> Parser o ()
54+abort x = Parser $ tell $ Panic x
55+
56+many :: Parser o () -> Parser o ()
57+many x = Parser $ tell $ Many $ toP x
58+
59+match :: (Char -> Bool) -> Parser o ()
60+match f = Parser $ tell $ Match $ CharSet f
61+
62+lit :: String -> Parser o ()
63+lit xs = forM_ xs $ \x -> match (== x)
64+
65+choice :: Parser o () -> Parser o () -> Parser o ()
66+choice a b = Parser $ tell $ Choice (toP a) (toP b)
67+
68+choices :: [Parser o ()] -> Parser o ()
69+choices = foldr1 choice
70+
71+optional :: Parser o () -> Parser o ()
72+optional x = choice x $ return ()
73+
74+
75+---------------------------------------------------------------------
76+-- CHARSET
77+
78+chars = ['\1'..'\xff']
79+
80+newtype CharSet = CharSet {fromCharSet :: Char -> Bool}
81+
82+instance Eq CharSet where
83+ CharSet f1 == CharSet f2 = all (\x -> f1 x == f2 x) chars
84+
85+instance Monoid CharSet where
86+ mempty = CharSet $ const False
87+ mappend (CharSet f1) (CharSet f2) = CharSet $ f1 ||^ f2
88+
89+instance Show CharSet where
90+ show (CharSet p) = "[" ++ f chars ++ "]"
91+ where
92+ showChar x | x `elem` "[]-" = ['\\',x]
93+ | otherwise = init $ tail $ show x
94+ f xs = case dropWhile (not . p) xs of
95+ [] -> []
96+ x:xs -> case span p xs of
97+ ([], rest) -> showChar x ++ f rest :: String
98+ (ys, rest) -> showChar x ++ "-" ++ showChar (last ys) ++ f rest
99+
100+-- | Given we know the first argument are all true, can the second argument ever be False
101+implies :: [CharSet] -> CharSet -> Bool
102+implies known x = all (fromCharSet x) poss
103+ where poss = filter (\c -> all (\k -> fromCharSet k c) known) chars
104+
105+charSetC :: [CharSet] -> ([String], CharSet -> String)
106+charSetC sets =
107+ (["const char parse_table[256] = {" ++ intercalate "," ("0":map disp chars) ++ "};"]
108+ ,\x -> fromMaybe ("parse_table[*p] & " ++ showBit (bit $ fromJust $ elemIndex x hard)) $ simple x)
109+ where
110+ showBit x = "0x" ++ showHex (x :: Int) ""
111+ disp c = showBit $ foldr (.|.) 0 [bit i | (i, h) <- zip [0..] hard, fromCharSet h c]
112+
113+ hard = nub $ filter (isNothing . simple) sets
114+
115+ simple x | x == CharSet (const True) = Just "*p"
116+ | [x] <- filter (fromCharSet x) chars = Just $ "*p == " ++ show x
117+ | otherwise = Nothing
118+
119+---------------------------------------------------------------------
120+-- THE UNDERLYING C TYPE
121+
122+data C o
123+ = While CharSet [C o]
124+ | Stmt o
125+ | Next
126+ | If CharSet [C o] [C o]
127+ | Abort String
128+ deriving Show
129+
130+-- Can you leave this statement successfully having consumed no characters?
131+empty :: P o -> Bool
132+empty Empty = True
133+empty (Choice a b) = empty b
134+empty Many{} = True
135+empty Out{} = True
136+empty Match{} = False
137+empty Panic{} = False
138+empty (Seq a b) = empty a && empty b
139+
140+-- What characters can come next and you commit
141+peek :: P o -> CharSet
142+peek Empty = mempty
143+peek Out{} = mempty
144+peek (Match f) = f
145+peek Panic{} = CharSet $ const True
146+peek (Choice a b) = peek a <> peek b
147+peek (Many x) = peek x
148+peek (Seq a b) = peek a <> (if empty a then peek b else mempty)
149+
150+toC :: P o -> [C o]
151+toC Empty = []
152+toC (Choice a b) = [If (peek a) (toC a) (toC b)]
153+toC (Match f) = [If f [Next] [Abort "Failed to match"]]
154+toC (Many x) = [While (peek x) (toC x)]
155+toC (Out x) = [Stmt x]
156+toC (Panic x) = [Abort x]
157+toC (Seq a b) = toC a ++ toC b
158+
159+runC :: [C o] -> String -> ([(Int, o)], (Int, String), Maybe String)
160+runC = f 0
161+ where
162+ f i [] s = ([], (i, s), Nothing)
163+ f i (Abort x:_) s = ([], (i,s), Just x)
164+ f i (Next:_) [] = ([], (i, []), Just "Next off the end")
165+ f i (Next:r) (x:xs) = f (i+1) r xs
166+ f i (Stmt x:r) xs = let (v1,v2,v3) = f i r xs in ((i,x):v1, v2, v3)
167+ f i (If cond true false : r) xs
168+ | x:_ <- xs, fromCharSet cond x = f i (true ++ r) xs
169+ | otherwise = f i (false ++ r) xs
170+ f i (While cond x:r) xs = f i (If cond (x ++ [While cond x]) [] : r) xs
171+
172+
173+prettyC :: Show o => [C o] -> [String]
174+prettyC xs =
175+ prefix ++
176+ ["const char* parser(const char* p ARGUMENTS){"] ++
177+ fi xs ++
178+ [" return NULL;"
179+ ,"}"]
180+ where
181+ (prefix, cond) = charSetC $ concatMap charSets xs
182+ charSets (While c x) = c : concatMap charSets x
183+ charSets (If c t f) = c : concatMap charSets t ++ concatMap charSets f
184+ charSets _ = []
185+
186+ fi = map (" "++) . concatMap f
187+ f (Abort x) = ["abort(" ++ show x ++ ");"]
188+ f Next = ["p++;"]
189+ f (Stmt x) = [show x ++ ";"]
190+ f (If c true []) = ["if (" ++ cond c ++ "){"] ++ fi true ++ ["}"]
191+ f (If c true [false@If{}]) = ["if (" ++ cond c ++ "){"] ++ fi true ++ ["} else " ++ f1] ++ fs
192+ where f1:fs = f false
193+ f (If c true false) = ["if (" ++ cond c ++ "){"] ++ fi true ++ ["} else {"] ++ fi false ++ ["}"]
194+ f (While c x) = ["while (" ++ cond c ++ "){"] ++ fi x ++ ["}"]
195+
196+optimiseC :: [C o] -> [C o]
197+optimiseC = f []
198+ where
199+ f known [] = []
200+ f known (Abort x:_) = [Abort x]
201+ f known (Next:xs) = Next : f [] xs
202+ f known (Stmt x:xs) = Stmt x : f known xs
203+ f known (If cond true false : xs)
204+ | implies known cond = f known $ true ++ xs
205+ | otherwise = If cond (f (cond:known) true) (f known false) : f [] xs -- might be a Next in body
206+ f known (While cond x : xs) = While cond (f (cond:known) x) : f [] xs