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