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   (repr :: ReprInstr)
  31   :: ReprInstr
  32
  33 -- | Convenient utility to pattern-match a 'SomeInstr'.
  34 pattern Instr :: Typeable comb =>
  35   Instr comb repr inp vs a ->
  36   SomeInstr repr inp vs a
  37 pattern Instr x <- (unSomeInstr -> Just x)
  38
  39 -- ** Type 'SomeInstr'
  40 -- | Some 'Instr'uction existentialized over the actual instruction symantic class.
  41 -- Useful to handle a list of 'Instr'uctions
  42 -- without requiring impredicative quantification.
  43 -- Must be used by pattern-matching
  44 -- on the 'SomeInstr' data-constructor,
  45 -- to bring the constraints in scope.
  46 --
  47 -- As in 'SomeComb', a first pass of optimizations
  48 -- is directly applied in it
  49 -- to avoid introducing an extra newtype,
  50 -- this also give a more undestandable code.
  51 data SomeInstr repr inp vs a =
  52   forall instr.
  53   ( Trans (Instr instr repr inp vs) (repr inp vs)
  54   , Typeable instr
  55   ) =>
  56   SomeInstr (Instr instr repr inp vs a)
  57
  58 instance Trans (SomeInstr repr inp vs) (repr inp vs) where
  59   trans (SomeInstr x) = trans x
  60
  61 -- | @(unSomeInstr i :: 'Maybe' ('Instr' comb repr inp vs a))@
  62 -- extract the data-constructor from the given 'SomeInstr'
  63 -- iif. it belongs to the @('Instr' comb repr a)@ data-instance.
  64 unSomeInstr ::
  65   forall instr repr inp vs a.
  66   Typeable instr =>
  67   SomeInstr repr inp vs a ->
  68   Maybe (Instr instr repr inp vs a)
  69 unSomeInstr (SomeInstr (i::Instr i repr inp vs a)) =
  70   case typeRep @instr `eqTypeRep` typeRep @i of
  71     Just HRefl -> Just i
  72     Nothing -> Nothing
  73
  74 -- InstrValuable
  75 data instance Instr InstrValuable repr inp vs a where
  76   PushValue ::
  77     TermInstr v ->
  78     SomeInstr repr inp (v ': vs) a ->
  79     Instr InstrValuable repr inp vs a
  80   PopValue ::
  81     SomeInstr repr inp vs a ->
  82     Instr InstrValuable repr inp (v ': vs) a
  83   Lift2Value ::
  84     TermInstr (x -> y -> z) ->
  85     SomeInstr repr inp (z : vs) a ->
  86     Instr InstrValuable repr inp (y : x : vs) a
  87   SwapValue ::
  88     SomeInstr repr inp (x ': y ': vs) a ->
  89     Instr InstrValuable repr inp (y ': x ': vs) a
  90 instance InstrValuable repr => Trans (Instr InstrValuable repr inp vs) (repr inp vs) where
  91   trans = \case
  92     PushValue x k -> pushValue x (trans k)
  93     PopValue k -> popValue (trans k)
  94     Lift2Value f k -> lift2Value f (trans k)
  95     SwapValue k -> swapValue (trans k)
  96 instance InstrValuable repr => InstrValuable (SomeInstr repr) where
  97   pushValue _v (Instr (PopValue i)) = i
  98   pushValue v i = SomeInstr (PushValue v i)
  99   popValue = SomeInstr . PopValue
 100   lift2Value f = SomeInstr . Lift2Value f
 101   swapValue = SomeInstr . SwapValue
 102
 103 -- InstrExceptionable
 104 data instance Instr InstrExceptionable repr inp vs a where
 105   Raise ::
 106     ExceptionLabel ->
 107     Instr InstrExceptionable repr inp vs a
 108   Fail ::
 109     Set SomeFailure ->
 110     Instr InstrExceptionable repr inp vs a
 111   Commit ::
 112     Exception ->
 113     SomeInstr repr inp vs ret ->
 114     Instr InstrExceptionable repr inp vs ret
 115   Catch ::
 116     Exception ->
 117     SomeInstr repr inp vs ret ->
 118     SomeInstr repr inp (Cursor inp ': vs) ret ->
 119     Instr InstrExceptionable repr inp vs ret
 120 instance InstrExceptionable repr => Trans (Instr InstrExceptionable repr inp vs) (repr inp vs) where
 121   trans = \case
 122     Raise exn -> raise exn
 123     Fail fs -> fail fs
 124     Commit exn k -> commit exn (trans k)
 125     Catch exn l r -> catch exn (trans l) (trans r)
 126 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
 127   raise = SomeInstr . Raise
 128   fail = SomeInstr . Fail
 129   commit exn = SomeInstr . Commit exn
 130   catch exn x = SomeInstr . Catch exn 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     Set SomeFailure ->
 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 fs p k -> read fs p (trans k)
 224 instance
 225   ( InstrReadable tok repr, Typeable tok ) =>
 226   InstrReadable tok (SomeInstr repr) where
 227   read fs p = SomeInstr . Read fs p