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.Typed.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