src/Symantic/Parser/Machine/Instructions.hs

   1 {-# LANGUAGE ConstraintKinds #-} -- For Machine
   2 {-# LANGUAGE DeriveLift #-} -- For TH.Lift (Failure tok)
   3 {-# LANGUAGE DerivingStrategies #-} -- For Show (LetName a)
   4 -- | Semantic of the parsing instructions used
   5 -- to make the parsing control-flow explicit,
   6 -- in the convenient tagless-final encoding.
   7 module Symantic.Parser.Machine.Instructions where
   8
   9 import Data.Bool (Bool(..))
  10 import Data.Either (Either)
  11 import Data.Eq (Eq(..))
  12 import Data.Function ((.))
  13 import Data.Kind (Type)
  14 import Data.Set (Set)
  15 import Text.Show (Show(..))
  16 import qualified Language.Haskell.TH as TH
  17
  18 import Symantic.Parser.Grammar
  19 import Symantic.Parser.Machine.Input
  20 import qualified Symantic.Typed.Lang as Prod
  21 import qualified Symantic.Typed.Data as Sym
  22
  23 -- * Type 'Splice'
  24 type Splice = Sym.SomeData TH.CodeQ
  25
  26 splice :: TH.CodeQ a -> Splice a
  27 splice x = Sym.SomeData (Sym.Var x)
  28
  29 -- ** Type 'ReprInstr'
  30 type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
  31
  32 -- ** Type 'LetName'
  33 -- | 'TH.Name' of a 'defLet' or 'defJoin'
  34 -- indexed by the return type of the factorized 'Instr'uctions.
  35 -- This helps type-inferencing.
  36 newtype LetName a = LetName { unLetName :: TH.Name }
  37   deriving Eq
  38   deriving newtype Show
  39
  40 -- ** Class 'InstrValuable'
  41 class InstrValuable (repr::ReprInstr) where
  42   -- | @('pushValue' x k)@ pushes @(x)@ on the 'valueStack'
  43   -- and continues with the next 'Instr'uction @(k)@.
  44   pushValue ::
  45     Splice v ->
  46     repr inp (v ': vs) a ->
  47     repr inp vs a
  48   -- | @('popValue' k)@ pushes @(x)@ on the 'valueStack'.
  49   popValue ::
  50     repr inp vs a ->
  51     repr inp (v ': vs) a
  52   -- | @('lift2Value' f k)@ pops two values from the 'valueStack',
  53   -- and pushes the result of @(f)@ applied to them.
  54   lift2Value ::
  55     Splice (x -> y -> z) ->
  56     repr inp (z ': vs) a ->
  57     repr inp (y ': x ': vs) a
  58   -- | @('swapValue' k)@ pops two values on the 'valueStack',
  59   -- pushes the first popped-out, then the second,
  60   -- and continues with the next 'Instr'uction @(k)@.
  61   swapValue ::
  62     repr inp (x ': y ': vs) a ->
  63     repr inp (y ': x ': vs) a
  64   -- | @('mapValue' f k)@.
  65   mapValue ::
  66     Splice (x -> y) ->
  67     repr inp (y ': vs) a ->
  68     repr inp (x ': vs) a
  69   mapValue f = pushValue f . lift2Value (Prod.flip Prod..@ (Prod.$))
  70   -- | @('applyValue' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
  71   -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
  72   applyValue ::
  73     repr inp (y ': vs) a ->
  74     repr inp (x ': (x -> y) ': vs) a
  75   applyValue = lift2Value (Prod.$)
  76
  77 -- ** Class 'InstrExceptionable'
  78 class InstrExceptionable (repr::ReprInstr) where
  79   -- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
  80   raise :: ExceptionLabel -> repr inp vs a
  81   -- | @('fail' fs)@ raises 'ExceptionFailure' @(exn)@.
  82   -- As a special case, giving an empty 'Set' of failures
  83   -- raises 'ExceptionFailure' without using the current position
  84   -- to update the farthest error.
  85   fail :: Set SomeFailure -> repr inp vs a
  86   -- | @('commit' exn k)@ removes the 'Catcher'
  87   -- from the 'catchStackByLabel' for the given 'Exception' @(exn)@,
  88   -- and continues with the next 'Instr'uction @(k)@.
  89   commit :: Exception -> repr inp vs a -> repr inp vs a
  90   -- | @('catch' exn l r)@ tries the @(l)@ 'Instr'uction
  91   -- in a new failure scope such that if @(l)@ raises an exception within @(exn)@, it is caught,
  92   -- then the input (and its 'Horizon') is pushed as it was before trying @(l)@ on the 'valueStack',
  93   -- and the control flow goes on with the @(r)@ 'Instr'uction.
  94   catch ::
  95     Exception ->
  96     {-scope-}repr inp vs ret ->
  97     {-catcher-}repr inp (Cursor inp ': vs) ret ->
  98     repr inp vs ret
  99
 100 -- ** Class 'InstrBranchable'
 101 class InstrBranchable (repr::ReprInstr) where
 102   -- | @('caseBranch' l r)@.
 103   caseBranch ::
 104     repr inp (x ': vs) r ->
 105     repr inp (y ': vs) r ->
 106     repr inp (Either x y ': vs) r
 107   -- | @('choicesBranch' ps bs d)@.
 108   choicesBranch ::
 109     [Splice (v -> Bool)] ->
 110     [repr inp vs a] ->
 111     repr inp vs a ->
 112     repr inp (v ': vs) a
 113   -- | @('ifBranch' ok ko)@ pops a 'Bool' from the 'valueStack'
 114   -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
 115   -- or @(ko)@ otherwise.
 116   ifBranch ::
 117     repr inp vs a ->
 118     repr inp vs a ->
 119     repr inp (Bool ': vs) a
 120   ifBranch ok ko = choicesBranch [Prod.id] [ok] ko
 121
 122 -- ** Class 'InstrCallable'
 123 class InstrCallable (repr::ReprInstr) where
 124   -- | @('defLet' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,
 125   -- 'Call's @(n)@ and
 126   -- continues with the next 'Instr'uction @(k)@.
 127   defLet ::
 128     LetBindings TH.Name (repr inp '[]) ->
 129     repr inp vs a ->
 130     repr inp vs a
 131   -- | @('call' n k)@ pass the control-flow to the 'DefLet' named @(n)@,
 132   -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
 133   call ::
 134     LetName v -> repr inp (v ': vs) a ->
 135     repr inp vs a
 136   -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
 137   ret ::
 138     repr inp '[a] a
 139   -- | @('jump' n k)@ pass the control-flow to the 'DefLet' named @(n)@.
 140   jump ::
 141     LetName a ->
 142     repr inp '[] a
 143
 144 -- ** Class 'InstrJoinable'
 145 class InstrJoinable (repr::ReprInstr) where
 146   defJoin ::
 147     LetName v -> repr inp (v ': vs) a ->
 148     repr inp vs a ->
 149     repr inp vs a
 150   refJoin ::
 151     LetName v ->
 152     repr inp (v ': vs) a
 153
 154 -- ** Class 'InstrInputable'
 155 class InstrInputable (repr::ReprInstr) where
 156   -- | @('pushInput' k)@ pushes the input @(inp)@ on the 'valueStack'
 157   -- and continues with the next 'Instr'uction @(k)@.
 158   pushInput ::
 159     repr inp (Cursor inp ': vs) a ->
 160     repr inp vs a
 161   -- | @('loadInput' k)@ removes the input from the 'valueStack'
 162   -- and continues with the next 'Instr'uction @(k)@ using that input.
 163   loadInput ::
 164     repr inp vs a ->
 165     repr inp (Cursor inp ': vs) a
 166
 167 -- ** Class 'InstrReadable'
 168 class InstrReadable (tok::Type) (repr::ReprInstr) where
 169   -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
 170   -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
 171   -- otherwise 'fail'.
 172   read ::
 173     tok ~ InputToken inp =>
 174     Set SomeFailure ->
 175     Splice (tok -> Bool) ->
 176     repr inp (tok ': vs) a ->
 177     repr inp vs a