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