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.Ord (Ord(..))
  15 import Data.Set (Set)
  16 import Text.Show (Show(..), showParen, showString)
  17 import qualified Language.Haskell.TH as TH
  18 import qualified Language.Haskell.TH.Show as TH
  19
  20 import Symantic.Parser.Grammar
  21 import Symantic.Parser.Machine.Input
  22 import qualified Symantic.Typed.Lang as Prod
  23 import qualified Symantic.Typed.Trans as Sym
  24 import qualified Symantic.Typed.Data as Sym
  25
  26 -- * Type 'Splice'
  27 type Splice = Sym.SomeData TH.CodeQ
  28
  29 instance Show (Splice a) where
  30   showsPrec p = showParen (p >= 0) . showString . TH.showCode . Sym.trans
  31
  32 splice :: TH.CodeQ a -> Splice a
  33 splice x = Sym.SomeData (Sym.Var x)
  34
  35 -- ** Type 'ReprInstr'
  36 type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
  37
  38 -- ** Type 'LetName'
  39 -- | 'TH.Name' of a 'defLet' or 'defJoin'
  40 -- indexed by the return type of the factorized 'Instr'uctions.
  41 -- This helps type-inferencing.
  42 newtype LetName a = LetName { unLetName :: TH.Name }
  43   deriving Eq
  44   deriving newtype Show
  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 'Catcher'
  93   -- from the 'catchStackByLabel' 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 as it was before trying @(l)@ on the 'valueStack',
  99   -- and the control flow goes on with the @(r)@ 'Instr'uction.
 100   catch ::
 101     Exception ->
 102     {-scope-}repr inp vs ret ->
 103     {-catcher-}repr inp (Cursor inp ': vs) ret ->
 104     repr inp vs ret
 105
 106 -- ** Class 'InstrBranchable'
 107 class InstrBranchable (repr::ReprInstr) where
 108   -- | @('caseBranch' l r)@.
 109   caseBranch ::
 110     repr inp (x ': vs) r ->
 111     repr inp (y ': vs) r ->
 112     repr inp (Either x y ': vs) r
 113   -- | @('choicesBranch' ps bs d)@.
 114   choicesBranch ::
 115     [Splice (v -> Bool)] ->
 116     [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 ko = choicesBranch [Prod.id] [ok] ko
 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' 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     LetName v -> repr inp (v ': vs) a ->
 141     repr inp vs a
 142   -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
 143   ret ::
 144     repr inp '[a] a
 145   -- | @('jump' n k)@ pass the control-flow to the 'DefLet' named @(n)@.
 146   jump ::
 147     LetName a ->
 148     repr inp '[] a
 149
 150 -- ** Class 'InstrJoinable'
 151 class InstrJoinable (repr::ReprInstr) where
 152   defJoin ::
 153     LetName v -> repr inp (v ': vs) a ->
 154     repr inp vs a ->
 155     repr inp vs a
 156   refJoin ::
 157     LetName v ->
 158     repr inp (v ': vs) a
 159
 160 -- ** Class 'InstrInputable'
 161 class InstrInputable (repr::ReprInstr) where
 162   -- | @('pushInput' k)@ pushes the input @(inp)@ on the 'valueStack'
 163   -- and continues with the next 'Instr'uction @(k)@.
 164   pushInput ::
 165     repr inp (Cursor inp ': vs) a ->
 166     repr inp vs a
 167   -- | @('loadInput' k)@ removes the input from the 'valueStack'
 168   -- and continues with the next 'Instr'uction @(k)@ using that input.
 169   loadInput ::
 170     repr inp vs a ->
 171     repr inp (Cursor inp ': vs) a
 172
 173 -- ** Class 'InstrReadable'
 174 class InstrReadable (tok::Type) (repr::ReprInstr) where
 175   -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
 176   -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
 177   -- otherwise 'fail'.
 178   read ::
 179     tok ~ InputToken inp =>
 180     Set SomeFailure ->
 181     Splice (tok -> Bool) ->
 182     repr inp (tok ': vs) a ->
 183     repr inp vs a