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