]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Program.hs
remove useless benchmarks
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Program.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE UndecidableInstances #-} -- For Cursorable (Cursor inp)
3 -- | Build the 'Instr'uction 'Program' of a 'Machine'
4 -- from the 'Comb'inators of a 'Grammar'.
5 -- 'Instr'uctions are kept introspectable
6 -- to enable more optimizations now possible because
7 -- of a broader knowledge of the 'Instr'uctions around
8 -- those generated (eg. by using 'joinNext').
9 module Symantic.Parser.Machine.Program where
10
11 import Control.Monad (Monad(..), (<=<), (=<<), liftM, liftM2, sequence)
12 import Data.Function (($))
13 import System.IO (IO)
14 import Type.Reflection (Typeable)
15 import Control.DeepSeq (NFData)
16 import Data.Bool (Bool(..))
17 import Data.Eq (Eq(..))
18 import Data.Function ((.))
19 import Text.Show (Show(..))
20 import qualified Data.Functor as Functor
21 import qualified Data.HashMap.Strict as HM
22 import qualified Data.Set as Set
23 import qualified Data.Traversable as Traversable
24 import qualified Language.Haskell.TH as TH
25 import qualified Language.Haskell.TH.Syntax as TH
26 import qualified Symantic.Univariant.Lang as H
27
28 import Symantic.Parser.Grammar
29 import Symantic.Parser.Machine.Input
30 import Symantic.Parser.Machine.Instructions
31 import Symantic.Parser.Machine.Optimize
32 import Symantic.Univariant.Trans
33
34 -- * Type 'Program'
35 -- | A 'Program' is a tree of 'Instr'uctions,
36 -- where each 'Instr'uction is built by a continuation
37 -- to be able to introspect, duplicate and/or change
38 -- the next 'Instr'uction.
39 data Program repr inp a = Program { unProgram ::
40 forall vs ret.
41 -- This is the next instruction
42 SomeInstr repr inp (a ': vs) ret ->
43 -- This is the current instruction
44 -- IO is needed for 'TH.newName' in 'joinNext'.
45 IO (SomeInstr repr inp vs ret)
46 }
47
48 -- | Build an interpreter of the 'Program' of the given 'Machinable'.
49 optimizeMachine ::
50 forall inp repr a.
51 Machinable (InputToken inp) repr =>
52 Program repr inp a ->
53 IO (repr inp '[] a)
54 optimizeMachine (Program f) = trans Functor.<$> f @'[] ret
55
56 -- * Class 'Machinable'
57 -- | All the 'Instr'uctions.
58 type Machinable tok repr =
59 ( InstrBranchable repr
60 , InstrExceptionable repr
61 , InstrInputable repr
62 , InstrJoinable repr
63 , InstrCallable repr
64 , InstrValuable repr
65 , InstrReadable tok repr
66 , Eq tok
67 , TH.Lift tok
68 , NFData tok
69 , Show tok
70 , Typeable tok
71 )
72
73 instance
74 ( Cursorable (Cursor inp)
75 , InstrBranchable repr
76 , InstrExceptionable repr
77 , InstrInputable repr
78 , InstrJoinable repr
79 , InstrValuable repr
80 , InstrReadable (InputToken inp) repr
81 , Typeable (InputToken inp)
82 ) =>
83 Trans (Comb CombAlternable (Program repr inp)) (Program repr inp) where
84 trans = \case
85 Alt ExceptionFailure
86 (Comb (SatisfyOrFail _fs p :: Comb (CombSatisfiable (InputToken inp)) (Program repr inp) a))
87 (Comb (Failure sf)) ->
88 Program $ return . read (Set.singleton sf) (prodCode p)
89 Alt exn x y -> alt exn (trans x) (trans y)
90 Empty -> empty
91 Failure sf -> failure sf
92 Throw exn -> throw exn
93 Try x -> try (trans x)
94
95 instance
96 ( Cursorable (Cursor inp)
97 , InstrBranchable repr
98 , InstrExceptionable repr
99 , InstrInputable repr
100 , InstrJoinable repr
101 , InstrValuable repr
102 ) => CombAlternable (Program repr inp) where
103 alt exn (Program l) (Program r) = joinNext $ Program $ \next ->
104 liftM2 (catch exn)
105 (l (commit exn next))
106 (failIfConsumed exn Functor.<$> r next)
107 throw exn = Program $ \_next -> return $ raise exn
108 failure flr = Program $ \_next -> return $ fail (Set.singleton flr)
109 empty = Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEmpty))
110 try (Program x) = Program $ \next ->
111 liftM2 (catch ExceptionFailure)
112 (x (commit ExceptionFailure next))
113 -- On exception, reset the input, and propagate the failure.
114 (return $ loadInput $ fail Set.empty)
115
116 -- | If no input has been consumed by the failing alternative
117 -- then continue with the given continuation.
118 -- Otherwise, propagate the failure.
119 failIfConsumed ::
120 Cursorable (Cursor inp) =>
121 InstrBranchable repr =>
122 InstrExceptionable repr =>
123 InstrInputable repr =>
124 InstrValuable repr =>
125 Exception ->
126 SomeInstr repr inp vs ret ->
127 SomeInstr repr inp (Cursor inp ': vs) ret
128 failIfConsumed exn k =
129 pushInput $
130 lift2Value (splice sameOffset) $
131 ifBranch k $
132 case exn of
133 ExceptionLabel lbl -> raise lbl
134 ExceptionFailure -> fail Set.empty
135
136 -- | @('joinNext' m)@ factorize the next 'Instr'uction
137 -- to be able to reuse it multiple times without duplication.
138 -- It does so by introducing a 'defJoin'
139 -- and passing the corresponding 'refJoin'
140 -- as next 'Instr'uction to @(m)@,
141 -- unless factorizing is useless because the next 'Instr'uction
142 -- is already a 'refJoin' or a 'ret'.
143 -- It should be used each time the next 'Instr'uction
144 -- is used multiple times.
145 joinNext ::
146 InstrJoinable repr =>
147 Program repr inp v ->
148 Program repr inp v
149 joinNext (Program m) = Program $ \case
150 -- Double refJoin Optimization:
151 -- If a join-node points directly to another join-node,
152 -- then reuse it
153 next@(Instr RefJoin{}) -> m next
154 -- Terminal refJoin Optimization:
155 -- If a join-node points directly to a terminal operation,
156 -- then it's useless to introduce a join-node.
157 next@(Instr Ret{}) -> m next
158 -- Introduce a join-node.
159 next -> do
160 !joinName <- TH.newName "join"
161 defJoin (LetName joinName) next
162 Functor.<$> m (refJoin (LetName joinName))
163
164 instance
165 InstrValuable repr =>
166 CombApplicable (Program repr inp) where
167 pure x = Program $ return . pushValue (prodCode x)
168 Program f <*> Program x = Program $ (f <=< x) . applyValue
169 liftA2 f (Program x) (Program y) = Program $ (x <=< y) . lift2Value (prodCode f)
170 Program x *> Program y = Program (x <=< return . popValue <=< y)
171 Program x <* Program y = Program (x <=< y <=< return . popValue)
172 instance
173 ( Cursorable (Cursor inp)
174 , InstrBranchable repr
175 , InstrExceptionable repr
176 , InstrInputable repr
177 , InstrJoinable repr
178 , InstrValuable repr
179 ) => CombFoldable (Program repr inp) where
180 {-
181 chainPre op p = go <*> p
182 where go = (H..) <$> op <*> go <|> pure H.id
183 chainPost p op = p <**> go
184 where go = (H..) <$> op <*> go <|> pure H.id
185 -}
186 instance
187 InstrCallable repr =>
188 Letable TH.Name (Program repr inp) where
189 shareable n (Program sub) = Program $ \next -> do
190 sub' <- sub ret
191 return $ defLet (HM.singleton n (SomeLet sub')) (call (LetName n) next)
192 ref _isRec n = Program $ \case
193 -- Returning just after a 'call' is useless:
194 -- using 'jump' lets the 'ret' of the 'defLet'
195 -- directly return where it would in two 'ret's.
196 Instr Ret{} -> return $ jump (LetName n)
197 next -> return $ call (LetName n) next
198 instance
199 InstrCallable repr =>
200 Letsable TH.Name (Program repr inp) where
201 lets defs (Program x) = Program $ \next -> do
202 defs' <- Traversable.traverse (\(SomeLet (Program val)) -> liftM SomeLet (val ret)) defs
203 liftM (defLet defs') (x next)
204 instance
205 ( Eq (InputToken inp)
206 , Cursorable (Cursor inp)
207 , InstrBranchable repr
208 , InstrExceptionable repr
209 , InstrInputable repr
210 , InstrJoinable repr
211 , InstrReadable (InputToken inp) repr
212 , Typeable (InputToken inp)
213 , InstrValuable repr
214 ) => CombLookable (Program repr inp) where
215 look (Program x) = Program $ \next ->
216 liftM pushInput (x (swapValue (loadInput next)))
217 eof = negLook (satisfy (H.lam1 (\_x -> H.bool True)))
218 -- This sets a better failure message
219 <|> (Program $ \_next -> return $ fail (Set.singleton (SomeFailure FailureEnd)))
220 negLook (Program x) = Program $ \next ->
221 liftM2 (catch ExceptionFailure)
222 -- On x success, discard the result,
223 -- and replace this 'Catcher' by a failure whose 'farthestExpecting' is negated,
224 -- then a failure is raised from the input
225 -- when entering 'negLook', to avoid odd cases:
226 -- - where the failure that made (negLook x)
227 -- succeed can get the blame for the overall
228 -- failure of the grammar.
229 -- - where the overall failure of
230 -- the grammar might be blamed on something in x
231 -- that, if corrected, still makes x succeed
232 -- and (negLook x) fail.
233 (liftM pushInput $ x $
234 popValue $ commit ExceptionFailure $
235 loadInput $ fail Set.empty)
236 -- On x failure, reset the input,
237 -- and go on with the next 'Instr'uctions.
238 (return $ loadInput $ pushValue H.unit next)
239 instance
240 ( InstrBranchable repr
241 , InstrJoinable repr
242 ) => CombMatchable (Program repr inp) where
243 conditional (Program a) ps bs (Program d) = joinNext $ Program $ \next -> do
244 bs' <- Control.Monad.sequence $ (\(Program b) -> b next) Functor.<$> bs
245 a =<< liftM (choicesBranch (prodCode Functor.<$> ps) bs') (d next)
246 instance
247 ( tok ~ InputToken inp
248 , InstrReadable tok repr
249 , Typeable tok
250 ) => CombSatisfiable tok (Program repr inp) where
251 satisfyOrFail fs p = Program $ return . read fs (prodCode p)
252 instance
253 ( InstrBranchable repr
254 , InstrJoinable repr
255 , InstrValuable repr
256 ) => CombSelectable (Program repr inp) where
257 branch (Program lr) (Program l) (Program r) = joinNext $ Program $ \next ->
258 lr =<< liftM2 caseBranch
259 (l (swapValue (applyValue next)))
260 (r (swapValue (applyValue next)))