src/Symantic/Parser/Machine/Optimize.hs

   1 {-# LANGUAGE PatternSynonyms #-} -- For Instr
   2 {-# LANGUAGE ViewPatterns #-} -- For unSomeInstr
   3 {-# LANGUAGE UndecidableInstances #-}
   4 -- | Initial encoding with bottom-up optimizations of 'Instr'uctions,
   5 -- re-optimizing downward as needed after each optimization.
   6 -- There is only one optimization (for 'pushValue') so far,
   7 -- but the introspection enabled by the 'Instr' data-type
   8 -- is also useful to optimize with more context in the 'Machine'.
   9 module Symantic.Parser.Machine.Optimize where
  10
  11 import Data.Bool (Bool(..))
  12 import Data.Either (Either)
  13 import Data.Maybe (Maybe(..))
  14 import Data.Function ((.))
  15 import Data.Kind (Constraint)
  16 import Data.Proxy (Proxy(..))
  17 import GHC.TypeLits (KnownSymbol)
  18 import Type.Reflection (Typeable, typeRep, eqTypeRep, (:~~:)(..))
  19 import qualified Data.Functor as Functor
  20 import qualified Language.Haskell.TH as TH
  21
  22 import Symantic.Parser.Grammar
  23 import Symantic.Parser.Machine.Input
  24 import Symantic.Parser.Machine.Instructions
  25 import Symantic.Univariant.Trans
  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   (repr :: ReprInstr)
  33   :: ReprInstr
  34
  35 -- | Convenient utility to pattern-match a 'SomeInstr'.
  36 pattern Instr :: Typeable comb =>
  37   Instr comb repr inp vs a ->
  38   SomeInstr repr inp vs a
  39 pattern Instr x <- (unSomeInstr -> Just x)
  40
  41 -- ** Type 'SomeInstr'
  42 -- | Some 'Instr'uction existentialized over the actual instruction symantic class.
  43 -- Useful to handle a list of 'Instr'uctions
  44 -- without requiring impredicative quantification.
  45 -- Must be used by pattern-matching
  46 -- on the 'SomeInstr' data-constructor,
  47 -- to bring the constraints in scope.
  48 --
  49 -- As in 'SomeComb', a first pass of optimizations
  50 -- is directly applied in it
  51 -- to avoid introducing an extra newtype,
  52 -- this also give a more comprehensible code.
  53 data SomeInstr repr inp vs a =
  54   forall instr.
  55   (Trans (Instr instr repr inp vs) (repr inp vs), Typeable instr) =>
  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   RaiseException ::
 106     KnownSymbol lbl =>
 107     Proxy lbl ->
 108     [ErrorItem (InputToken inp)] ->
 109     Instr InstrExceptionable repr inp vs a
 110   PopException ::
 111     KnownSymbol lbl =>
 112     Proxy lbl ->
 113     SomeInstr repr inp vs ret ->
 114     Instr InstrExceptionable repr inp vs ret
 115   CatchException ::
 116     KnownSymbol lbl =>
 117     Proxy lbl ->
 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     RaiseException lbl err -> raiseException lbl err
 124     PopException lbl k -> popException lbl (trans k)
 125     CatchException lbl l r -> catchException lbl (trans l) (trans r)
 126 instance InstrExceptionable repr => InstrExceptionable (SomeInstr repr) where
 127   raiseException lbl = SomeInstr . RaiseException lbl
 128   popException lbl = SomeInstr . PopException lbl
 129   catchException lbl x = SomeInstr . CatchException lbl 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     [TermInstr (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     [ErrorItem (InputToken inp)] ->
 215     TermInstr (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 es p k -> read es p (trans k)
 223 instance
 224   ( InstrReadable tok repr, Typeable tok ) =>
 225   InstrReadable tok (SomeInstr repr) where
 226   read es p = SomeInstr . Read es p