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