src/Symantic/Parser/Machine/Instructions.hs

   1 {-# LANGUAGE ConstraintKinds #-} -- For Machine
   2 {-# LANGUAGE DerivingStrategies #-} -- For Show (LetName a)
   3 -- | Semantic of the parsing instructions used
   4 -- to make the parsing control-flow explicit,
   5 -- in the convenient tagless-final encoding.
   6 module Symantic.Parser.Machine.Instructions where
   7
   8 import Data.Bool (Bool(..))
   9 import Data.Either (Either)
  10 import Data.Eq (Eq(..))
  11 import Data.Function ((.))
  12 import Data.Kind (Type)
  13 import GHC.TypeLits (KnownSymbol)
  14 import Text.Show (Show(..))
  15 import Data.Proxy (Proxy(..))
  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   , InstrLetable 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 ::
  51     TermInstr v ->
  52     repr inp (v ': vs) a ->
  53     repr inp vs a
  54   popValue ::
  55     repr inp vs a ->
  56     repr inp (v ': vs) a
  57   lift2Value ::
  58     TermInstr (x -> y -> z) ->
  59     repr inp (z ': vs) a ->
  60     repr inp (y ': x ': vs) a
  61   swapValue ::
  62     repr inp (x ': y ': vs) a ->
  63     repr inp (y ': x ': vs) a
  64   -- | @('mapValue' f k)@.
  65   mapValue ::
  66     TermInstr (x -> y) ->
  67     repr inp (y ': vs) a ->
  68     repr inp (x ': vs) a
  69   mapValue f = pushValue f . lift2Value (H.flip H..@ (H.$))
  70   -- | @('applyValue' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
  71   -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
  72   applyValue ::
  73     repr inp (y ': vs) a ->
  74     repr inp (x ': (x -> y) ': vs) a
  75   applyValue = lift2Value (H.$)
  76
  77 -- ** Class 'InstrExceptionable'
  78 class InstrExceptionable (repr::ReprInstr) where
  79   -- | @('raiseException' lbl es)@ raises labeled error from the 'failStack'.
  80   raiseException ::
  81     KnownSymbol lbl =>
  82     Proxy lbl ->
  83     [ErrorItem (InputToken inp)] ->
  84     repr inp vs a
  85   -- | Like using 'raiseException' with the @"fail"@ label.
  86   fail ::
  87     [ErrorItem (InputToken inp)] ->
  88     repr inp vs a
  89   fail = raiseException (Proxy @"fail")
  90   -- | @('popException' lbl k)@ removes a 'Catcher'
  91   -- from the @catchStackByLabel@ at given label,
  92   -- and continues with the next 'Instr'uction @(k)@.
  93   popException ::
  94     KnownSymbol lbl =>
  95     Proxy lbl ->
  96     repr inp vs a ->
  97     repr inp vs a
  98   -- | @('catchException' lbl l r)@ tries the @(l)@ 'Instr'uction
  99   -- in a new failure scope such that if @(l)@ raises a failure, it is caught,
 100   -- then the input is pushed as it was before trying @(l)@ on the 'valueStack',
 101   -- and the control flow goes on with the @(r)@ 'Instr'uction.
 102   catchException ::
 103     KnownSymbol lbl =>
 104     Proxy lbl ->
 105     repr inp vs ret ->
 106     repr inp (Cursor inp ': vs) ret ->
 107     repr inp vs ret
 108
 109 -- ** Class 'InstrBranchable'
 110 class InstrBranchable (repr::ReprInstr) where
 111   -- | @('caseBranch' l r)@.
 112   caseBranch ::
 113     repr inp (x ': vs) r ->
 114     repr inp (y ': vs) r ->
 115     repr inp (Either x y ': vs) r
 116   -- | @('choicesBranch' ps bs d)@.
 117   choicesBranch ::
 118     [TermInstr (v -> Bool)] ->
 119     [repr inp vs a] ->
 120     repr inp vs a ->
 121     repr inp (v ': vs) a
 122   -- | @('ifBranch' ok ko)@ pops a 'Bool' from the 'valueStack'
 123   -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
 124   -- or @(ko)@ otherwise.
 125   ifBranch ::
 126     repr inp vs a ->
 127     repr inp vs a ->
 128     repr inp (Bool ': vs) a
 129   ifBranch ok ko = choicesBranch [H.id] [ok] ko
 130
 131 -- ** Class 'InstrLetable'
 132 class InstrLetable (repr::ReprInstr) where
 133   -- | @('defLet' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,
 134   -- 'Call's @(n)@ and
 135   -- continues with the next 'Instr'uction @(k)@.
 136   defLet ::
 137     LetName v -> repr inp '[] v ->
 138     repr inp vs a ->
 139     repr inp vs a
 140   -- | @('call' n k)@ pass the control-flow to the 'DefLet' named @(n)@,
 141   -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
 142   call ::
 143     LetName v -> repr inp (v ': vs) a ->
 144     repr inp vs a
 145   -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
 146   ret ::
 147     repr inp '[a] a
 148   -- | @('jump' n k)@ pass the control-flow to the 'DefLet' named @(n)@.
 149   jump ::
 150     LetName a ->
 151     repr inp '[] a
 152
 153 -- ** Class 'InstrJoinable'
 154 class InstrJoinable (repr::ReprInstr) where
 155   defJoin ::
 156     LetName v -> repr inp (v ': vs) a ->
 157     repr inp vs a ->
 158     repr inp vs a
 159   refJoin ::
 160     LetName v ->
 161     repr inp (v ': vs) a
 162
 163 -- ** Class 'InstrInputable'
 164 class InstrInputable (repr::ReprInstr) where
 165   -- | @('loadInput' k)@ removes the input from the 'valueStack'
 166   -- and continues with the next 'Instr'uction @(k)@ using that input.
 167   loadInput ::
 168     repr inp vs a ->
 169     repr inp (Cursor inp ': vs) a
 170   -- | @('pushInput' k)@ pushes the input @(inp)@ on the 'valueStack'
 171   -- and continues with the next 'Instr'uction @(k)@.
 172   pushInput ::
 173     repr inp (Cursor inp ': vs) a ->
 174     repr inp vs a
 175
 176 -- ** Class 'InstrReadable'
 177 class InstrReadable (tok::Type) (repr::ReprInstr) where
 178   -- | @('read' expected p k)@ reads a 'Char' @(c)@ from the 'inp'ut,
 179   -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@ on,
 180   -- otherwise 'RaiseException'.
 181   read ::
 182     tok ~ InputToken inp =>
 183     [ErrorItem tok] ->
 184     TermInstr (tok -> Bool) ->
 185     repr inp (tok ': vs) a ->
 186     repr inp vs a