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
  94   -- as it was before trying @(l)@ on the 'valueStack' (resp. on the 'horizonStack'),
  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), 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' isRec 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     Bool ->
 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' isRec n k)@ pass the control-flow to the 'DefLet' named @(n)@.
 142   jump ::
 143     Bool ->
 144     LetName a ->
 145     repr inp '[] a
 146
 147 -- ** Class 'InstrJoinable'
 148 class InstrJoinable (repr::ReprInstr) where
 149   defJoin ::
 150     LetName v -> repr inp (v ': vs) a ->
 151     repr inp vs a ->
 152     repr inp vs a
 153   refJoin ::
 154     LetName v ->
 155     repr inp (v ': vs) a
 156
 157 -- ** Class 'InstrInputable'
 158 class InstrInputable (repr::ReprInstr) where
 159   -- | @('pushInput' k)@ pushes the input @(inp)@ on the 'valueStack'
 160   -- and continues with the next 'Instr'uction @(k)@.
 161   pushInput ::
 162     repr inp (Cursor inp ': vs) a ->
 163     repr inp vs a
 164   -- | @('loadInput' k)@ removes the input from the 'valueStack'
 165   -- and continues with the next 'Instr'uction @(k)@ using that input.
 166   loadInput ::
 167     repr inp vs a ->
 168     repr inp (Cursor inp ': vs) a
 169
 170 -- ** Class 'InstrReadable'
 171 class InstrReadable (tok::Type) (repr::ReprInstr) where
 172   -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
 173   -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
 174   -- otherwise 'fail'.
 175   read ::
 176     tok ~ InputToken inp =>
 177     Set SomeFailure ->
 178     Splice (tok -> Bool) ->
 179     repr inp (tok ': vs) a ->
 180     repr inp vs a
 181
 182 -- ** Class 'InstrIterable'
 183 class InstrIterable (repr::ReprInstr) where
 184   -- | @('iter' loop done)@.
 185   iter ::
 186     LetName a ->
 187     repr inp '[] a ->
 188     repr inp (Cursor inp ': vs) a ->
 189     repr inp vs a
 190
 191 -- ** Class 'InstrRegisterable'
 192 class InstrRegisterable (repr::ReprInstr) where
 193   newRegister ::
 194     UnscopedRegister v ->
 195     repr inp vs a ->
 196     repr inp (v : vs) a
 197   readRegister ::
 198     UnscopedRegister v ->
 199     repr inp (v : vs) a ->
 200     repr inp vs a
 201   writeRegister ::
 202     UnscopedRegister v ->
 203     repr inp vs a ->
 204     repr inp (v : vs) a
 205
 206 -- | @('modifyRegister' reg k)@
 207 -- modifies the content of register @(reg)@
 208 -- with the function at the 'valueStackHead',
 209 -- then continues with @(k)@.
 210 modifyRegister ::
 211   InstrRegisterable repr =>
 212   InstrValuable repr =>
 213   UnscopedRegister v -> repr inp vs a -> repr inp ((v -> v) : vs) a
 214 modifyRegister r = readRegister r . applyValue . writeRegister r