@@ -0,0 +1,206 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+ out, many, optional, match, lit, choice, abort, choices,
10+import Control.Monad.Extra
11+import Control.Monad.Trans.Writer
21+run :: Parser o () -> String -> ([(Int, o)], (Int, String), Maybe String)
22+run p = runC (toC $ toP p)
24+compile :: Show o => Parser o () -> [String]
25+compile = prettyC . optimiseC . toC . toP
27+---------------------------------------------------------------------
28+-- THE UNDERLYING PARSER TYPE
40+instance Monoid (P o) where
44+newtype Parser o a = Parser (Writer (P o) a)
45+ deriving (Functor, Applicative, Monad)
47+toP :: Parser o a -> P o
48+toP (Parser p) = execWriter p
50+out :: o -> Parser o ()
51+out o = Parser $ tell $ Out o
53+abort :: String -> Parser o ()
54+abort x = Parser $ tell $ Panic x
56+many :: Parser o () -> Parser o ()
57+many x = Parser $ tell $ Many $ toP x
59+match :: (Char -> Bool) -> Parser o ()
60+match f = Parser $ tell $ Match $ CharSet f
62+lit :: String -> Parser o ()
63+lit xs = forM_ xs $ \x -> match (== x)
65+choice :: Parser o () -> Parser o () -> Parser o ()
66+choice a b = Parser $ tell $ Choice (toP a) (toP b)
68+choices :: [Parser o ()] -> Parser o ()
69+choices = foldr1 choice
71+optional :: Parser o () -> Parser o ()
72+optional x = choice x $ return ()
75+---------------------------------------------------------------------
78+chars = ['\1'..'\xff']
80+newtype CharSet = CharSet {fromCharSet :: Char -> Bool}
82+instance Eq CharSet where
83+ CharSet f1 == CharSet f2 = all (\x -> f1 x == f2 x) chars
85+instance Monoid CharSet where
86+ mempty = CharSet $ const False
87+ mappend (CharSet f1) (CharSet f2) = CharSet $ f1 ||^ f2
89+instance Show CharSet where
90+ show (CharSet p) = "[" ++ f chars ++ "]"
92+ showChar x | x `elem` "[]-" = ['\\',x]
93+ | otherwise = init $ tail $ show x
94+ f xs = case dropWhile (not . p) xs of
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
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
105+charSetC :: [CharSet] -> ([String], CharSet -> String)
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)
110+ showBit x = "0x" ++ showHex (x :: Int) ""
111+ disp c = showBit $ foldr (.|.) 0 [bit i | (i, h) <- zip [0..] hard, fromCharSet h c]
113+ hard = nub $ filter (isNothing . simple) sets
115+ simple x | x == CharSet (const True) = Just "*p"
116+ | [x] <- filter (fromCharSet x) chars = Just $ "*p == " ++ show x
117+ | otherwise = Nothing
119+---------------------------------------------------------------------
120+-- THE UNDERLYING C TYPE
123+ = While CharSet [C o]
126+ | If CharSet [C o] [C o]
130+-- Can you leave this statement successfully having consumed no characters?
133+empty (Choice a b) = empty b
136+empty Match{} = False
137+empty Panic{} = False
138+empty (Seq a b) = empty a && empty b
140+-- What characters can come next and you commit
141+peek :: P o -> CharSet
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)
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
159+runC :: [C o] -> String -> ([(Int, o)], (Int, String), Maybe String)
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
173+prettyC :: Show o => [C o] -> [String]
176+ ["const char* parser(const char* p ARGUMENTS){"] ++
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
186+ fi = map (" "++) . concatMap f
187+ f (Abort x) = ["abort(" ++ show x ++ ");"]
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 ++ ["}"]
196+optimiseC :: [C o] -> [C o]
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