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.Derive
  21 import Symantic.Parser.Grammar
  22 import Symantic.Parser.Machine.Input
  23 import Symantic.Parser.Machine.Instructions
  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 type instance Derived (Instr instr repr inp vs) = repr inp vs
  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 gives a more undestandable code.
  51 data SomeInstr repr inp vs a =
  52   forall instr.
  53   ( Derivable (Instr instr repr inp vs)
  54   , Typeable instr
  55   ) =>
  56   SomeInstr (Instr instr repr inp vs a)
  57
  58 type instance Derived (SomeInstr repr inp vs) = repr inp vs
  59 instance Derivable (SomeInstr repr inp vs) where
  60   derive (SomeInstr x) = derive 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     Splice 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     Splice (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 => Derivable (Instr InstrValuable repr inp vs) where
  92   derive = \case
  93     PushValue x k -> pushValue x (derive k)
  94     PopValue k -> popValue (derive k)
  95     Lift2Value f k -> lift2Value f (derive k)
  96     SwapValue k -> swapValue (derive k)
  97 instance InstrValuable repr => InstrValuable (SomeInstr repr) where
  98   -- 'PopValue' after a 'PushValue' is a no-op.
  99   pushValue _v (Instr (PopValue i)) = i
 100   pushValue v i = SomeInstr (PushValue v i)
 101   popValue = SomeInstr . PopValue
 102   lift2Value f = SomeInstr . Lift2Value f
 103   swapValue = SomeInstr . SwapValue
 104
 105 -- InstrExceptionable
 106 data instance Instr InstrExceptionable repr inp vs a where
 107   Raise ::
 108     ExceptionLabel ->
 109     Instr InstrExceptionable repr inp vs a
 110   Fail ::
 111     Set SomeFailure ->
 112     Instr InstrExceptionable repr inp vs a
 113   Commit ::
 114     Exception ->
 115     SomeInstr repr inp vs ret ->
 116     Instr InstrExceptionable repr inp vs ret
 117   Catch ::
 118     Exception ->
 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 => Derivable (Instr InstrExceptionable repr inp vs) where
 123   derive = \case
 124     Raise exn -> raise exn
 125     Fail fs -> fail fs
 126     Commit exn k -> commit exn (derive k)
 127     Catch exn l r -> catch exn (derive l) (derive r)
 128 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
 129   raise = SomeInstr . Raise
 130   fail = SomeInstr . Fail
 131   commit exn = SomeInstr . Commit exn
 132   catch exn x = SomeInstr . Catch exn x
 133
 134 -- InstrBranchable
 135 data instance Instr InstrBranchable repr inp vs a where
 136   CaseBranch ::
 137     SomeInstr repr inp (x ': vs) a ->
 138     SomeInstr repr inp (y ': vs) a ->
 139     Instr InstrBranchable repr inp (Either x y ': vs) a
 140   ChoicesBranch ::
 141     [Splice (v -> Bool)] ->
 142     [SomeInstr repr inp vs a] ->
 143     SomeInstr repr inp vs a ->
 144     Instr InstrBranchable repr inp (v ': vs) a
 145 instance InstrBranchable repr => Derivable (Instr InstrBranchable repr inp vs) where
 146   derive = \case
 147     CaseBranch l r -> caseBranch (derive l) (derive r)
 148     ChoicesBranch ps bs d -> choicesBranch ps (derive Functor.<$> bs) (derive d)
 149 instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
 150   caseBranch l = SomeInstr . CaseBranch l
 151   choicesBranch ps bs = SomeInstr . ChoicesBranch ps bs
 152
 153 -- InstrCallable
 154 data instance Instr InstrCallable repr inp vs a where
 155   DefLet ::
 156     LetBindings TH.Name (SomeInstr repr inp '[]) ->
 157     SomeInstr repr inp vs a ->
 158     Instr InstrCallable repr inp vs a
 159   Call ::
 160     LetName v ->
 161     SomeInstr repr inp (v ': vs) a ->
 162     Instr InstrCallable repr inp vs a
 163   Ret ::
 164     Instr InstrCallable repr inp '[a] a
 165   Jump ::
 166     LetName a ->
 167     Instr InstrCallable repr inp '[] a
 168 instance InstrCallable repr => Derivable (Instr InstrCallable repr inp vs) where
 169   derive = \case
 170     DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (derive sub)) Functor.<$> subs) (derive k)
 171     Jump n -> jump n
 172     Call n k -> call n (derive k)
 173     Ret -> ret
 174 instance InstrCallable repr => InstrCallable (SomeInstr repr) where
 175   defLet subs = SomeInstr . DefLet subs
 176   jump = SomeInstr . Jump
 177   call n = SomeInstr . Call n
 178   ret = SomeInstr Ret
 179
 180 -- InstrJoinable
 181 data instance Instr InstrJoinable repr inp vs a where
 182   DefJoin ::
 183     LetName v ->
 184     SomeInstr repr inp (v ': vs) a ->
 185     SomeInstr repr inp vs a ->
 186     Instr InstrJoinable repr inp vs a
 187   RefJoin ::
 188     LetName v ->
 189     Instr InstrJoinable repr inp (v ': vs) a
 190 instance InstrJoinable repr => Derivable (Instr InstrJoinable repr inp vs) where
 191   derive = \case
 192     DefJoin n sub k -> defJoin n (derive sub) (derive k)
 193     RefJoin n -> refJoin n
 194 instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
 195   defJoin n sub = SomeInstr . DefJoin n sub
 196   refJoin = SomeInstr . RefJoin
 197
 198 -- InstrInputable
 199 data instance Instr InstrInputable repr inp vs a where
 200   PushInput ::
 201     SomeInstr repr inp (Cursor inp ': vs) a ->
 202     Instr InstrInputable repr inp vs a
 203   LoadInput ::
 204     SomeInstr repr inp vs a ->
 205     Instr InstrInputable repr inp (Cursor inp ': vs) a
 206 instance InstrInputable repr => Derivable (Instr InstrInputable repr inp vs) where
 207   derive = \case
 208     PushInput k -> pushInput (derive k)
 209     LoadInput k -> loadInput (derive k)
 210 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
 211   pushInput = SomeInstr . PushInput
 212   loadInput = SomeInstr . LoadInput
 213
 214 -- InstrReadable
 215 data instance Instr (InstrReadable tok) repr inp vs a where
 216   Read ::
 217     Set SomeFailure ->
 218     Splice (InputToken inp -> Bool) ->
 219     SomeInstr repr inp (InputToken inp ': vs) a ->
 220     Instr (InstrReadable tok) repr inp vs a
 221 instance
 222   ( InstrReadable tok repr, tok ~ InputToken inp ) =>
 223   Derivable (Instr (InstrReadable tok) repr inp vs) where
 224   derive = \case
 225     Read fs p k -> read fs p (derive k)
 226 instance
 227   ( InstrReadable tok repr, Typeable tok ) =>
 228   InstrReadable tok (SomeInstr repr) where
 229   read fs p = SomeInstr . Read fs p