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