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