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 import Debug.Trace
  26
  27 -- * Data family 'Instr'
  28 -- | 'Instr'uctions of the 'Machine'.
  29 -- This is an extensible data-type.
  30 data family Instr
  31   (instr :: ReprInstr -> Constraint)
  32   :: ReprInstr -> 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     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 => Trans (Instr InstrValuable repr inp vs) (repr inp vs) where
  92   trans = \case
  93     PushValue x k -> trace "trans.pushValue" (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   Raise ::
 107     ExceptionLabel ->
 108     Instr InstrExceptionable repr inp vs a
 109   Fail ::
 110     Set SomeFailure ->
 111     Instr InstrExceptionable repr inp vs a
 112   Commit ::
 113     Exception ->
 114     SomeInstr repr inp vs ret ->
 115     Instr InstrExceptionable repr inp vs ret
 116   Catch ::
 117     Exception ->
 118     SomeInstr repr inp vs ret ->
 119     SomeInstr repr inp (Cursor inp ': vs) ret ->
 120     Instr InstrExceptionable repr inp vs ret
 121 instance InstrExceptionable repr => Trans (Instr InstrExceptionable repr inp vs) (repr inp vs) where
 122   trans = \case
 123     Raise exn -> raise exn
 124     Fail fs -> fail fs
 125     Commit exn k -> commit exn (trans k)
 126     Catch exn l r -> catch exn (trans l) (trans r)
 127 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
 128   raise = SomeInstr . Raise
 129   fail = SomeInstr . Fail
 130   commit exn = SomeInstr . Commit exn
 131   catch exn x = SomeInstr . Catch exn x
 132
 133 -- InstrBranchable
 134 data instance Instr InstrBranchable repr inp vs a where
 135   CaseBranch ::
 136     SomeInstr repr inp (x ': vs) a ->
 137     SomeInstr repr inp (y ': vs) a ->
 138     Instr InstrBranchable repr inp (Either x y ': vs) a
 139   ChoicesBranch ::
 140     [Splice (v -> Bool)] ->
 141     [SomeInstr repr inp vs a] ->
 142     SomeInstr repr inp vs a ->
 143     Instr InstrBranchable repr inp (v ': vs) a
 144 instance InstrBranchable repr => Trans (Instr InstrBranchable repr inp vs) (repr inp vs) where
 145   trans = \case
 146     CaseBranch l r -> caseBranch (trans l) (trans r)
 147     ChoicesBranch ps bs d -> choicesBranch ps (trans Functor.<$> bs) (trans d)
 148 instance InstrBranchable repr => InstrBranchable (SomeInstr repr) where
 149   caseBranch l = SomeInstr . CaseBranch l
 150   choicesBranch ps bs = SomeInstr . ChoicesBranch ps bs
 151
 152 -- InstrCallable
 153 data instance Instr InstrCallable repr inp vs a where
 154   DefLet ::
 155     LetBindings TH.Name (SomeInstr repr inp '[]) ->
 156     SomeInstr repr inp vs a ->
 157     Instr InstrCallable repr inp vs a
 158   Call ::
 159     LetName v ->
 160     SomeInstr repr inp (v ': vs) a ->
 161     Instr InstrCallable repr inp vs a
 162   Ret ::
 163     Instr InstrCallable repr inp '[a] a
 164   Jump ::
 165     LetName a ->
 166     Instr InstrCallable repr inp '[] a
 167 instance InstrCallable repr => Trans (Instr InstrCallable repr inp vs) (repr inp vs) where
 168   trans = \case
 169     DefLet subs k -> defLet ((\(SomeLet sub) -> SomeLet (trans sub)) Functor.<$> subs) (trans k)
 170     Jump n -> jump n
 171     Call n k -> call n (trans k)
 172     Ret -> ret
 173 instance InstrCallable repr => InstrCallable (SomeInstr repr) where
 174   defLet subs = SomeInstr . DefLet subs
 175   jump = SomeInstr . Jump
 176   call n = SomeInstr . Call n
 177   ret = SomeInstr Ret
 178
 179 -- InstrJoinable
 180 data instance Instr InstrJoinable repr inp vs a where
 181   DefJoin ::
 182     LetName v ->
 183     SomeInstr repr inp (v ': vs) a ->
 184     SomeInstr repr inp vs a ->
 185     Instr InstrJoinable repr inp vs a
 186   RefJoin ::
 187     LetName v ->
 188     Instr InstrJoinable repr inp (v ': vs) a
 189 instance InstrJoinable repr => Trans (Instr InstrJoinable repr inp vs) (repr inp vs) where
 190   trans = \case
 191     DefJoin n sub k -> defJoin n (trans sub) (trans k)
 192     RefJoin n -> refJoin n
 193 instance InstrJoinable repr => InstrJoinable (SomeInstr repr) where
 194   defJoin n sub = SomeInstr . DefJoin n sub
 195   refJoin = SomeInstr . RefJoin
 196
 197 -- InstrInputable
 198 data instance Instr InstrInputable repr inp vs a where
 199   PushInput ::
 200     SomeInstr repr inp (Cursor inp ': vs) a ->
 201     Instr InstrInputable repr inp vs a
 202   LoadInput ::
 203     SomeInstr repr inp vs a ->
 204     Instr InstrInputable repr inp (Cursor inp ': vs) a
 205 instance InstrInputable repr => Trans (Instr InstrInputable repr inp vs) (repr inp vs) where
 206   trans = \case
 207     PushInput k -> pushInput (trans k)
 208     LoadInput k -> loadInput (trans k)
 209 instance InstrInputable repr => InstrInputable (SomeInstr repr) where
 210   pushInput = SomeInstr . PushInput
 211   loadInput = SomeInstr . LoadInput
 212
 213 -- InstrReadable
 214 data instance Instr (InstrReadable tok) repr inp vs a where
 215   Read ::
 216     Set SomeFailure ->
 217     Splice (InputToken inp -> Bool) ->
 218     SomeInstr repr inp (InputToken inp ': vs) a ->
 219     Instr (InstrReadable tok) repr inp vs a
 220 instance
 221   ( InstrReadable tok repr, tok ~ InputToken inp ) =>
 222   Trans (Instr (InstrReadable tok) repr inp vs) (repr inp vs) where
 223   trans = \case
 224     Read fs p k -> read fs p (trans k)
 225 instance
 226   ( InstrReadable tok repr, Typeable tok ) =>
 227   InstrReadable tok (SomeInstr repr) where
 228   read fs p = SomeInstr . Read fs p