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