src/Symantic/Parser/Machine/Instructions.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-} -- For SuccThrowAll uses
   2 {-# LANGUAGE ConstraintKinds #-} -- For Machine
   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 GHC.TypeLits (KnownSymbol)
  15 import Text.Show (Show(..))
  16 import Data.Proxy (Proxy(..))
  17 import qualified Language.Haskell.TH as TH
  18 import qualified Symantic.Parser.Haskell as H
  19
  20 import Symantic.Parser.Grammar
  21 import Symantic.Parser.Machine.Input
  22
  23 -- * Type 'TermInstr'
  24 type TermInstr = H.Term TH.CodeQ
  25
  26 -- * Class 'Machine'
  27 -- | All the 'Instr'uctions.
  28 type Machine tok repr =
  29   ( Branchable repr
  30   , Raisable repr
  31   , Inputable repr
  32   , Joinable repr
  33   , Routinable repr
  34   , Stackable repr
  35   , Readable tok repr
  36   )
  37
  38 -- ** Type 'ReprInstr'
  39 type ReprInstr = Type -> [Type] -> Type -> Type
  40
  41 -- ** Type 'LetName'
  42 -- | 'TH.Name' of a 'subroutine' or 'defJoin'
  43 -- indexed by the return type of the factorized 'Instr'uctions.
  44 -- This helps type-inferencing.
  45 newtype LetName a = LetName { unLetName :: TH.Name }
  46   deriving Eq
  47   deriving newtype Show
  48
  49 -- ** Class 'Stackable'
  50 class Stackable (repr::ReprInstr) where
  51   push ::
  52     TermInstr v ->
  53     repr inp (v ': vs) a ->
  54     repr inp vs a
  55   pop ::
  56     repr inp vs a ->
  57     repr inp (v ': vs) a
  58   liftI2 ::
  59     TermInstr (x -> y -> z) ->
  60     repr inp (z ': vs) a ->
  61     repr inp (y ': x ': vs) a
  62   swap ::
  63     repr inp (x ': y ': vs) a ->
  64     repr inp (y ': x ': vs) a
  65   -- | @('mapI' f k)@.
  66   mapI ::
  67     TermInstr (x -> y) ->
  68     repr inp (y ': vs) a ->
  69     repr inp (x ': vs) a
  70   mapI f = push f . liftI2 (H.flip H..@ (H.$))
  71   -- | @('appI' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
  72   -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
  73   appI ::
  74     repr inp (y ': vs) a ->
  75     repr inp (x ': (x -> y) ': vs) a
  76   appI = liftI2 (H.$)
  77
  78 -- ** Class 'Routinable'
  79 class Routinable (repr::ReprInstr) where
  80   subroutine ::
  81     LetName v -> repr inp '[] v ->
  82     repr inp vs a ->
  83     repr inp vs a
  84   call ::
  85     LetName v -> repr inp (v ': vs) a ->
  86     repr inp vs a
  87   ret ::
  88     repr inp '[a] a
  89   jump ::
  90     LetName a ->
  91     repr inp '[] a
  92
  93 -- ** Class 'Branchable'
  94 class Branchable (repr::ReprInstr) where
  95   caseI ::
  96     repr inp (x ': vs) r ->
  97     repr inp (y ': vs) r ->
  98     repr inp (Either x y ': vs) r
  99   choices ::
 100     [TermInstr (v -> Bool)] ->
 101     [repr inp vs a] ->
 102     repr inp vs a ->
 103     repr inp (v ': vs) a
 104   -- | @('ifI' ok ko)@ pops a 'Bool' from the 'valueStack'
 105   -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
 106   -- or @(ko)@ otherwise.
 107   ifI ::
 108     repr inp vs a ->
 109     repr inp vs a ->
 110     repr inp (Bool ': vs) a
 111   ifI ok ko = choices [H.id] [ok] ko
 112
 113 -- ** Class 'Raisable'
 114 class Raisable (repr::ReprInstr) where
 115   --type ThrowableConstraint repr (lbl::Symbol) (fs::[(Symbol, Peano)]) :: Constraint
 116   raise ::
 117     --ThrowableConstraint repr lbl =>
 118     KnownSymbol lbl =>
 119     Proxy lbl ->
 120     [ErrorItem (InputToken inp)] ->
 121     repr inp vs a
 122   fail ::
 123     --ThrowableConstraint repr "fail" =>
 124     [ErrorItem (InputToken inp)] ->
 125     repr inp vs a
 126   fail = raise (Proxy @"fail")
 127   popThrow ::
 128     --ThrowableConstraint repr lbl =>
 129     KnownSymbol lbl =>
 130     Proxy lbl ->
 131     repr inp vs a ->
 132     repr inp vs a
 133   catchThrow ::
 134     --ThrowableConstraint repr lbl =>
 135     KnownSymbol lbl =>
 136     Proxy lbl ->
 137     repr inp vs ret ->
 138     repr inp (Cursor inp ': vs) ret ->
 139     repr inp vs ret
 140
 141 -- ** Class 'Inputable'
 142 class Inputable (repr::ReprInstr) where
 143   loadInput ::
 144     repr inp vs a ->
 145     repr inp (Cursor inp ': vs) a
 146   pushInput ::
 147     repr inp (Cursor inp ': vs) a ->
 148     repr inp vs a
 149
 150 -- ** Class 'Joinable'
 151 class Joinable (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 'Readable'
 161 class Readable (tok::Type) (repr::ReprInstr) where
 162   read ::
 163     tok ~ InputToken inp =>
 164     [ErrorItem tok] ->
 165     TermInstr (tok -> Bool) ->
 166     repr inp (tok ': vs) a ->
 167     repr inp vs a