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   , 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   -- | @('raiseException' lbl es)@ raises labeled error from the 'failStack'.
  88   raiseException ::
  89     KnownSymbol lbl =>
  90     Proxy lbl ->
  91     [ErrorItem (InputToken inp)] ->
  92     repr inp vs a
  93   -- | Like using 'raiseException' with the @"fail"@ label.
  94   fail ::
  95     [ErrorItem (InputToken inp)] ->
  96     repr inp vs a
  97   fail = raiseException (Proxy @"fail")
  98   -- | @('popException' lbl k)@ removes a 'Catcher'
  99   -- from the @catchStackByLabel@ at given label,
 100   -- and continues with the next 'Instr'uction @(k)@.
 101   popException ::
 102     KnownSymbol lbl =>
 103     Proxy lbl ->
 104     repr inp vs a ->
 105     repr inp vs a
 106   -- | @('catchException' lbl l r)@ tries the @(l)@ 'Instr'uction
 107   -- in a new failure scope such that if @(l)@ raises a failure, it is caught,
 108   -- then the input (and its 'Horizon') is pushed as it was before trying @(l)@ on the 'valueStack',
 109   -- and the control flow goes on with the @(r)@ 'Instr'uction.
 110   catchException ::
 111     KnownSymbol lbl =>
 112     Proxy lbl ->
 113     repr inp vs ret ->
 114     repr inp (Cursor inp ': vs) ret ->
 115     repr inp vs ret
 116
 117 -- ** Class 'InstrBranchable'
 118 class InstrBranchable (repr::ReprInstr) where
 119   -- | @('caseBranch' l r)@.
 120   caseBranch ::
 121     repr inp (x ': vs) r ->
 122     repr inp (y ': vs) r ->
 123     repr inp (Either x y ': vs) r
 124   -- | @('choicesBranch' ps bs d)@.
 125   choicesBranch ::
 126     [TermInstr (v -> Bool)] ->
 127     [repr inp vs a] ->
 128     repr inp vs a ->
 129     repr inp (v ': vs) a
 130   -- | @('ifBranch' ok ko)@ pops a 'Bool' from the 'valueStack'
 131   -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
 132   -- or @(ko)@ otherwise.
 133   ifBranch ::
 134     repr inp vs a ->
 135     repr inp vs a ->
 136     repr inp (Bool ': vs) a
 137   ifBranch ok ko = choicesBranch [H.id] [ok] ko
 138
 139 -- ** Class 'InstrCallable'
 140 class InstrCallable (repr::ReprInstr) where
 141   -- | @('defLet' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,
 142   -- 'Call's @(n)@ and
 143   -- continues with the next 'Instr'uction @(k)@.
 144   defLet ::
 145     LetBindings TH.Name (repr inp '[]) ->
 146     repr inp vs a ->
 147     repr inp vs a
 148   -- | @('call' n k)@ pass the control-flow to the 'DefLet' named @(n)@,
 149   -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
 150   call ::
 151     LetName v -> repr inp (v ': vs) a ->
 152     repr inp vs a
 153   -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
 154   ret ::
 155     repr inp '[a] a
 156   -- | @('jump' n k)@ pass the control-flow to the 'DefLet' named @(n)@.
 157   jump ::
 158     LetName a ->
 159     repr inp '[] a
 160
 161 -- ** Class 'InstrJoinable'
 162 class InstrJoinable (repr::ReprInstr) where
 163   defJoin ::
 164     LetName v -> repr inp (v ': vs) a ->
 165     repr inp vs a ->
 166     repr inp vs a
 167   refJoin ::
 168     LetName v ->
 169     repr inp (v ': vs) a
 170
 171 -- ** Class 'InstrInputable'
 172 class InstrInputable (repr::ReprInstr) where
 173   -- | @('pushInput' k)@ pushes the input @(inp)@ on the 'valueStack'
 174   -- and continues with the next 'Instr'uction @(k)@.
 175   pushInput ::
 176     repr inp (Cursor inp ': vs) a ->
 177     repr inp vs a
 178   -- | @('loadInput' k)@ removes the input from the 'valueStack'
 179   -- and continues with the next 'Instr'uction @(k)@ using that input.
 180   loadInput ::
 181     repr inp vs a ->
 182     repr inp (Cursor inp ': vs) a
 183
 184 -- ** Class 'InstrReadable'
 185 class InstrReadable (tok::Type) (repr::ReprInstr) where
 186   -- | @('read' expected p k)@ reads a 'Char' @(c)@ from the 'inp'ut,
 187   -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@ on,
 188   -- otherwise 'RaiseException'.
 189   read ::
 190     tok ~ InputToken inp =>
 191     [ErrorItem tok] ->
 192     TermInstr (tok -> Bool) ->
 193     repr inp (tok ': vs) a ->
 194     repr inp vs a