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 Data.String (String)
  17 import qualified Language.Haskell.TH as TH
  18
  19 import Symantic.Parser.Grammar
  20 import Symantic.Parser.Machine.Input
  21 import qualified Symantic.Syntaxes.Classes as Prod
  22 import qualified Symantic.Semantics.Data as Sym
  23
  24 -- * Type 'Splice'
  25 type Splice = Sym.SomeData TH.CodeQ
  26
  27 -- | Lift a 'TH.CodeQ' into a 'Sym.SomeData'.
  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 'InstrComment'
  43 class InstrComment (repr::ReprInstr) where
  44   comment :: String -> repr inp vs a -> repr inp vs a
  45
  46 -- ** Class 'InstrValuable'
  47 class InstrValuable (repr::ReprInstr) where
  48   -- | @('pushValue' x k)@ pushes @(x)@ on the 'valueStack'
  49   -- and continues with the next 'Instr'uction @(k)@.
  50   pushValue ::
  51     Splice v ->
  52     repr inp (v ': vs) a ->
  53     repr inp vs a
  54   -- | @('popValue' k)@ pushes @(x)@ on the 'valueStack'.
  55   popValue ::
  56     repr inp vs a ->
  57     repr inp (v ': vs) a
  58   -- | @('lift2Value' f k)@ pops two values from the 'valueStack',
  59   -- and pushes the result of @(f)@ applied to them.
  60   lift2Value ::
  61     Splice (x -> y -> z) ->
  62     repr inp (z ': vs) a ->
  63     repr inp (y ': x ': vs) a
  64   -- | @('swapValue' k)@ pops two values on the 'valueStack',
  65   -- pushes the first popped-out, then the second,
  66   -- and continues with the next 'Instr'uction @(k)@.
  67   swapValue ::
  68     repr inp (x ': y ': vs) a ->
  69     repr inp (y ': x ': vs) a
  70   -- | @('mapValue' f k)@.
  71   mapValue ::
  72     Splice (x -> y) ->
  73     repr inp (y ': vs) a ->
  74     repr inp (x ': vs) a
  75   mapValue f = pushValue f . lift2Value (Prod.flip Prod..@ (Prod.$))
  76   -- | @('applyValue' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
  77   -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
  78   applyValue ::
  79     repr inp (y ': vs) a ->
  80     repr inp (x ': (x -> y) ': vs) a
  81   applyValue = lift2Value (Prod.$)
  82
  83 -- ** Class 'InstrExceptionable'
  84 class InstrExceptionable (repr::ReprInstr) where
  85   -- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
  86   raise :: ExceptionLabel -> repr inp vs a
  87   -- | @('fail' fs)@ raises 'ExceptionFailure' @(exn)@.
  88   -- As a special case, giving an empty 'Set' of failures
  89   -- raises 'ExceptionFailure' without using the current position
  90   -- to update the farthest error.
  91   fail :: Set SomeFailure -> repr inp vs a
  92   -- | @('commit' exn k)@ removes the 'OnException'
  93   -- from the 'onExceptionStackByLabel' for the given 'Exception' @(exn)@,
  94   -- and continues with the next 'Instr'uction @(k)@.
  95   commit :: Exception -> repr inp vs a -> repr inp vs a
  96   -- | @('catch' exn l r)@ tries the @(l)@ 'Instr'uction
  97   -- in a new failure scope such that if @(l)@ raises an exception within @(exn)@, it is caught,
  98   -- then the input (and its 'Horizon') is pushed
  99   -- as it was before trying @(l)@ on the 'valueStack' (resp. on the 'horizonStack'),
 100   -- and the control flow goes on with the @(r)@ 'Instr'uction.
 101   catch ::
 102     Exception ->
 103     {-scope-}repr inp vs ret ->
 104     {-onException-}repr inp (InputPosition inp ': vs) ret ->
 105     repr inp vs ret
 106
 107 -- ** Class 'InstrBranchable'
 108 class InstrBranchable (repr::ReprInstr) where
 109   -- | @('caseBranch' l r)@.
 110   caseBranch ::
 111     repr inp (x ': vs) r ->
 112     repr inp (y ': vs) r ->
 113     repr inp (Either x y ': vs) r
 114   -- | @('choicesBranch' ps bs d)@.
 115   choicesBranch ::
 116     [(Splice (v -> Bool), repr inp vs a)] ->
 117     repr inp vs a ->
 118     repr inp (v ': vs) a
 119   -- | @('ifBranch' ok ko)@ pops a 'Bool' from the 'valueStack'
 120   -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
 121   -- or @(ko)@ otherwise.
 122   ifBranch ::
 123     repr inp vs a ->
 124     repr inp vs a ->
 125     repr inp (Bool ': vs) a
 126   ifBranch ok = choicesBranch [(Prod.id, ok)]
 127
 128 -- ** Class 'InstrCallable'
 129 class InstrCallable (repr::ReprInstr) where
 130   -- | @('defLet' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,
 131   -- 'Call's @(n)@ and
 132   -- continues with the next 'Instr'uction @(k)@.
 133   defLet ::
 134     LetBindings TH.Name (repr inp '[]) ->
 135     repr inp vs a ->
 136     repr inp vs a
 137   -- | @('call' isRec n k)@ pass the control-flow to the 'DefLet' named @(n)@,
 138   -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
 139   call ::
 140     Bool ->
 141     LetName v -> repr inp (v ': vs) a ->
 142     repr inp vs a
 143   -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
 144   ret ::
 145     repr inp '[a] a
 146   -- | @('jump' isRec n k)@ pass the control-flow to the 'DefLet' named @(n)@.
 147   jump ::
 148     Bool ->
 149     LetName a ->
 150     repr inp '[] a
 151
 152 -- ** Class 'InstrJoinable'
 153 class InstrJoinable (repr::ReprInstr) where
 154   defJoin ::
 155     LetName v -> repr inp (v ': vs) a ->
 156     repr inp vs a ->
 157     repr inp vs a
 158   refJoin ::
 159     LetName v ->
 160     repr inp (v ': vs) a
 161
 162 -- ** Class 'InstrInputable'
 163 class InstrInputable (repr::ReprInstr) where
 164   -- | @('saveInput' k)@ pushes the input @(inp)@ on the 'valueStackHead'
 165   -- and continues with the next 'Instr'uction @(k)@.
 166   saveInput ::
 167     repr inp (InputPosition inp ': vs) a ->
 168     repr inp vs a
 169   -- | @('loadInput' k)@ removes the input from the 'valueStackHead'
 170   -- and continues with the next 'Instr'uction @(k)@ using that input.
 171   loadInput ::
 172     repr inp vs a ->
 173     repr inp (InputPosition inp ': vs) a
 174
 175 -- ** Class 'InstrReadable'
 176 class InstrReadable (tok::Type) (repr::ReprInstr) where
 177   -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
 178   -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
 179   -- otherwise 'fail'.
 180   read ::
 181     tok ~ InputToken inp =>
 182     Set SomeFailure ->
 183     Splice (tok -> Bool) ->
 184     repr inp (tok ': vs) a ->
 185     repr inp vs a
 186
 187 -- ** Class 'InstrIterable'
 188 class InstrIterable (repr::ReprInstr) where
 189   -- | @('iter' loop done)@.
 190   iter ::
 191     LetName a ->
 192     repr inp '[] a ->
 193     repr inp (InputPosition inp ': vs) a ->
 194     repr inp vs a
 195
 196 -- ** Class 'InstrRegisterable'
 197 class InstrRegisterable (repr::ReprInstr) where
 198   newRegister ::
 199     UnscopedRegister v ->
 200     repr inp vs a ->
 201     repr inp (v : vs) a
 202   readRegister ::
 203     UnscopedRegister v ->
 204     repr inp (v : vs) a ->
 205     repr inp vs a
 206   writeRegister ::
 207     UnscopedRegister v ->
 208     repr inp vs a ->
 209     repr inp (v : vs) a
 210
 211 -- | @('modifyRegister' reg k)@
 212 -- modifies the content of register @(reg)@
 213 -- with the function at the 'valueStackHead',
 214 -- then continues with @(k)@.
 215 modifyRegister ::
 216   InstrRegisterable repr =>
 217   InstrValuable repr =>
 218   UnscopedRegister v -> repr inp vs a -> repr inp ((v -> v) : vs) a
 219 modifyRegister r = readRegister r . applyValue . writeRegister r