]> Git — Sourcephile - haskell/symantic-parser.git/blob - src/Symantic/Parser/Machine/Optimize.hs
remove useless benchmarks
[haskell/symantic-parser.git] / src / Symantic / Parser / Machine / Optimize.hs
1 {-# LANGUAGE PatternSynonyms #-} -- For Instr
2 {-# LANGUAGE ViewPatterns #-} -- For unSomeInstr
3 -- | Initial encoding with bottom-up optimizations of 'Instr'uctions,
4 -- re-optimizing downward as needed after each optimization.
5 -- There is only one optimization (for 'pushValue') so far,
6 -- but the introspection enabled by the 'Instr' data-type
7 -- is also useful to optimize with more context in the 'Machine'.
8 module Symantic.Parser.Machine.Optimize where
9
10 import Data.Bool (Bool(..))
11 import Data.Either (Either)
12 import Data.Function ((.))
13 import Data.Kind (Constraint)
14 import Data.Maybe (Maybe(..))
15 import Data.Set (Set)
16 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
17 import qualified Data.Functor as Functor
18 import qualified Language.Haskell.TH as TH
19
20 import Symantic.Parser.Grammar
21 import Symantic.Parser.Machine.Input
22 import Symantic.Parser.Machine.Instructions
23 import Symantic.Univariant.Trans
24
25 -- * Data family 'Instr'
26 -- | 'Instr'uctions of the 'Machine'.
27 -- This is an extensible data-type.
28 data family Instr
29 (instr :: ReprInstr -> Constraint)
30 :: ReprInstr -> ReprInstr
31
32 -- | Convenient utility to pattern-match a 'SomeInstr'.
33 pattern Instr :: Typeable comb =>
34 Instr comb repr inp vs a ->
35 SomeInstr repr inp vs a
36 pattern Instr x <- (unSomeInstr -> Just x)
37
38 -- ** Type 'SomeInstr'
39 -- | Some 'Instr'uction existentialized over the actual instruction symantic class.
40 -- Useful to handle a list of 'Instr'uctions
41 -- without requiring impredicative quantification.
42 -- Must be used by pattern-matching
43 -- on the 'SomeInstr' data-constructor,
44 -- to bring the constraints in scope.
45 --
46 -- As in 'SomeComb', a first pass of optimizations
47 -- is directly applied in it
48 -- to avoid introducing an extra newtype,
49 -- this also give a more undestandable code.
50 data SomeInstr repr inp vs a =
51 forall instr.
52 ( Trans (Instr instr repr inp vs) (repr inp vs)
53 , Typeable instr
54 ) =>
55 SomeInstr (Instr instr repr inp vs a)
56
57 instance Trans (SomeInstr repr inp vs) (repr inp vs) where
58 trans (SomeInstr x) = trans x
59
60 -- | @(unSomeInstr i :: 'Maybe' ('Instr' comb repr inp vs a))@
61 -- extract the data-constructor from the given 'SomeInstr'
62 -- iif. it belongs to the @('Instr' comb repr a)@ data-instance.
63 unSomeInstr ::
64 forall instr repr inp vs a.
65 Typeable instr =>
66 SomeInstr repr inp vs a ->
67 Maybe (Instr instr repr inp vs a)
68 unSomeInstr (SomeInstr (i::Instr i repr inp vs a)) =
69 case typeRep @instr `eqTypeRep` typeRep @i of
70 Just HRefl -> Just i
71 Nothing -> Nothing
72
73 -- InstrValuable
74 data instance Instr InstrValuable repr inp vs a where
75 PushValue ::
76 Splice v ->
77 SomeInstr repr inp (v ': vs) a ->
78 Instr InstrValuable repr inp vs a
79 PopValue ::
80 SomeInstr repr inp vs a ->
81 Instr InstrValuable repr inp (v ': vs) a
82 Lift2Value ::
83 Splice (x -> y -> z) ->
84 SomeInstr repr inp (z : vs) a ->
85 Instr InstrValuable repr inp (y : x : vs) a
86 SwapValue ::
87 SomeInstr repr inp (x ': y ': vs) a ->
88 Instr InstrValuable repr inp (y ': x ': vs) a
89 instance InstrValuable repr => Trans (Instr InstrValuable repr inp vs) (repr inp vs) where
90 trans = \case
91 PushValue x k -> pushValue x (trans k)
92 PopValue k -> popValue (trans k)
93 Lift2Value f k -> lift2Value f (trans k)
94 SwapValue k -> swapValue (trans k)
95 instance InstrValuable repr => InstrValuable (SomeInstr repr) where
96 pushValue _v (Instr (PopValue i)) = i
97 pushValue v i = SomeInstr (PushValue v i)
98 popValue = SomeInstr . PopValue
99 lift2Value f = SomeInstr . Lift2Value f
100 swapValue = SomeInstr . SwapValue
101
102 -- InstrExceptionable
103 data instance Instr InstrExceptionable repr inp vs a where
104 Raise ::
105 ExceptionLabel ->
106 Instr InstrExceptionable repr inp vs a
107 Fail ::
108 Set SomeFailure ->
109 Instr InstrExceptionable repr inp vs a
110 Commit ::
111 Exception ->
112 SomeInstr repr inp vs ret ->
113 Instr InstrExceptionable repr inp vs ret
114 Catch ::
115 Exception ->
116 SomeInstr repr inp vs ret ->
117 SomeInstr repr inp (Cursor inp ': vs) ret ->
118 Instr InstrExceptionable repr inp vs ret
119 instance InstrExceptionable repr => Trans (Instr InstrExceptionable repr inp vs) (repr inp vs) where
120 trans = \case
121 Raise exn -> raise exn
122 Fail fs -> fail fs
123 Commit exn k -> commit exn (trans k)
124 Catch exn l r -> catch exn (trans l) (trans r)
125 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
126 raise = SomeInstr . Raise
127 fail = SomeInstr . Fail
128 commit exn = SomeInstr . Commit exn
129 catch exn x = SomeInstr . Catch exn x
130
131 -- InstrBranchable
132 data instance Instr InstrBranchable repr inp vs a where
133 CaseBranch ::
134 SomeInstr repr inp (x ': vs) a ->
135 SomeInstr repr inp (y ': vs) a ->
136 Instr InstrBranchable repr inp (Either x y ': vs) a
137 ChoicesBranch ::
138 [Splice (v -> Bool)] ->
139 [SomeInstr repr inp vs a] ->
140 SomeInstr repr inp vs a ->
141 Instr InstrBranchable repr inp (v ': vs) a
142 instance InstrBranchable repr => Trans (Instr InstrBranchable repr inp vs) (repr inp vs) where
143 trans = \case
144 CaseBranch l r -> caseBranch (trans l) (trans r)
145 ChoicesBranch ps bs d -> choicesBranch ps (trans Functor.<$> bs) (trans d)
146 instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
147 caseBranch l = SomeInstr . CaseBranch l
148 choicesBranch ps bs = SomeInstr . ChoicesBranch ps bs
149
150 -- InstrCallable
151 data instance Instr InstrCallable repr inp vs a where
152 DefLet ::
153 LetBindings TH.Name (SomeInstr repr inp '[]) ->
154 SomeInstr repr inp vs a ->
155 Instr InstrCallable repr inp vs a
156 Call ::
157 LetName v ->
158 SomeInstr repr inp (v ': vs) a ->
159 Instr InstrCallable repr inp vs a
160 Ret ::
161 Instr InstrCallable repr inp '[a] a
162 Jump ::
163 LetName a ->
164 Instr InstrCallable repr inp '[] a
165 instance InstrCallable repr => Trans (Instr InstrCallable repr inp vs) (repr inp vs) where
166 trans = \case
167 DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (trans sub)) Functor.<$> subs) (trans k)
168 Jump n -> jump n
169 Call n k -> call n (trans k)
170 Ret -> ret
171 instance InstrCallable repr => InstrCallable (SomeInstr repr) where
172 defLet subs = SomeInstr . DefLet subs
173 jump = SomeInstr . Jump
174 call n = SomeInstr . Call n
175 ret = SomeInstr Ret
176
177 -- InstrJoinable
178 data instance Instr InstrJoinable repr inp vs a where
179 DefJoin ::
180 LetName v ->
181 SomeInstr repr inp (v ': vs) a ->
182 SomeInstr repr inp vs a ->
183 Instr InstrJoinable repr inp vs a
184 RefJoin ::
185 LetName v ->
186 Instr InstrJoinable repr inp (v ': vs) a
187 instance InstrJoinable repr => Trans (Instr InstrJoinable repr inp vs) (repr inp vs) where
188 trans = \case
189 DefJoin n sub k -> defJoin n (trans sub) (trans k)
190 RefJoin n -> refJoin n
191 instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
192 defJoin n sub = SomeInstr . DefJoin n sub
193 refJoin = SomeInstr . RefJoin
194
195 -- InstrInputable
196 data instance Instr InstrInputable repr inp vs a where
197 PushInput ::
198 SomeInstr repr inp (Cursor inp ': vs) a ->
199 Instr InstrInputable repr inp vs a
200 LoadInput ::
201 SomeInstr repr inp vs a ->
202 Instr InstrInputable repr inp (Cursor inp ': vs) a
203 instance InstrInputable repr => Trans (Instr InstrInputable repr inp vs) (repr inp vs) where
204 trans = \case
205 PushInput k -> pushInput (trans k)
206 LoadInput k -> loadInput (trans k)
207 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
208 pushInput = SomeInstr . PushInput
209 loadInput = SomeInstr . LoadInput
210
211 -- InstrReadable
212 data instance Instr (InstrReadable tok) repr inp vs a where
213 Read ::
214 Set SomeFailure ->
215 Splice (InputToken inp -> Bool) ->
216 SomeInstr repr inp (InputToken inp ': vs) a ->
217 Instr (InstrReadable tok) repr inp vs a
218 instance
219 ( InstrReadable tok repr, tok ~ InputToken inp ) =>
220 Trans (Instr (InstrReadable tok) repr inp vs) (repr inp vs) where
221 trans = \case
222 Read fs p k -> read fs p (trans k)
223 instance
224 ( InstrReadable tok repr, Typeable tok ) =>
225 InstrReadable tok (SomeInstr repr) where
226 read fs p = SomeInstr . Read fs p