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 {-# LANGUAGE DeriveAnyClass #-} -- For NFData
   5 {-# LANGUAGE DeriveGeneric #-} -- For Generic
   6 {-# LANGUAGE TemplateHaskell #-} -- For TH.Lift
   7 -- | Semantic of the parsing instructions used
   8 -- to make the parsing control-flow explicit,
   9 -- in the convenient tagless-final encoding.
  10 module Symantic.Parser.Machine.Instructions where
  11
  12 import Control.DeepSeq (NFData(..))
  13 import Data.Bool (Bool(..))
  14 import Data.Either (Either)
  15 import Data.Eq (Eq(..))
  16 import Data.Function ((.))
  17 import Data.Int (Int)
  18 import Data.Kind (Type)
  19 import Data.Ord (Ord(..))
  20 import Data.String (String)
  21 import Text.Show (Show(..), showParen, showString, shows)
  22
  23 import Symantic.Parser.Grammar
  24 import Symantic.Parser.Machine.Input
  25 import qualified Symantic.Syntaxes.Classes as Prod
  26 import qualified Symantic.Semantics.Data as Sym
  27 import qualified Language.Haskell.TH as TH
  28
  29 -- * Type 'Splice'
  30 type Splice = Sym.SomeData TH.CodeQ
  31
  32 -- | Lift a 'TH.CodeQ' into an opaque 'Sym.SomeData'.
  33 splice :: TH.CodeQ a -> Splice a
  34 splice x = Sym.SomeData (Sym.Var x)
  35
  36 -- ** Type 'ReprInstr'
  37 type ReprInstr = {-input-}Type -> {-valueStack-}[Type] -> {-a-}Type -> Type
  38
  39 -- ** Type 'LetName'
  40 -- | 'TH.Name' of a 'defLet' or 'defJoin'
  41 -- indexed by the return type of the factorized 'Instr'uctions.
  42 -- This helps type-inferencing.
  43 newtype LetName a = LetName { unLetName :: TH.Name }
  44   deriving Eq
  45   deriving newtype Show
  46
  47 -- ** Class 'InstrComment'
  48 class InstrComment (repr::ReprInstr) where
  49   comment :: String -> repr inp vs a -> repr inp vs a
  50
  51 -- ** Class 'InstrValuable'
  52 class InstrValuable (repr::ReprInstr) where
  53   -- | @('pushValue' x k)@ pushes @(x)@ on the 'valueStack'
  54   -- and continues with the next 'Instr'uction @(k)@.
  55   pushValue ::
  56     Splice v ->
  57     repr inp (v ': vs) a ->
  58     repr inp vs a
  59   -- | @('popValue' k)@ pushes @(x)@ on the 'valueStack'.
  60   popValue ::
  61     repr inp vs a ->
  62     repr inp (v ': vs) a
  63   -- | @('lift2Value' f k)@ pops two values from the 'valueStack',
  64   -- and pushes the result of @(f)@ applied to them.
  65   lift2Value ::
  66     Splice (x -> y -> z) ->
  67     repr inp (z ': vs) a ->
  68     repr inp (y ': x ': vs) a
  69   -- | @('swapValue' k)@ pops two values on the 'valueStack',
  70   -- pushes the first popped-out, then the second,
  71   -- and continues with the next 'Instr'uction @(k)@.
  72   swapValue ::
  73     repr inp (x ': y ': vs) a ->
  74     repr inp (y ': x ': vs) a
  75   -- | @('mapValue' f k)@.
  76   mapValue ::
  77     Splice (x -> y) ->
  78     repr inp (y ': vs) a ->
  79     repr inp (x ': vs) a
  80   mapValue f = pushValue f . lift2Value (Prod.flip Prod..@ (Prod.$))
  81   -- | @('applyValue' k)@ pops @(x)@ and @(x2y)@ from the 'valueStack',
  82   -- pushes @(x2y x)@ and continues with the next 'Instr'uction @(k)@.
  83   applyValue ::
  84     repr inp (y ': vs) a ->
  85     repr inp (x ': (x -> y) ': vs) a
  86   applyValue = lift2Value (Prod.$)
  87
  88 -- ** Type 'FailMode'
  89 data FailMode
  90    = FailModePreserve
  91     -- ^ Fail preserving any current farthest error.
  92     -- Useful in 'alt' or 'try'.
  93    | FailModeNewFailure (TH.CodeQ SomeFailure)
  94     -- ^ Fail preserving, merging or replacing any current farthest error,
  95     -- depending on its input position and the current input position.
  96
  97 data SomeFailure
  98   = forall a. SomeFailure (WriteGrammar 'True a)
  99   | SomeFailureHorizon Int
 100 instance NFData SomeFailure where
 101   rnf (SomeFailure x) = rnf x
 102   rnf (SomeFailureHorizon x) = rnf x
 103 instance Show SomeFailure where
 104   showsPrec p (SomeFailure x) = showsPrec p x
 105   showsPrec p (SomeFailureHorizon x) = showParen (p > 10) (showString "SomeFailureHorizon " . shows x)
 106 --instance TH.Lift SomeFailure where
 107 --  liftTyped (SomeFailure x) = [|| SomeFailure $$(TH.liftTyped x) ||]
 108 --instance Semigroup SomeFailure where
 109 --  x <> y = SomeFailure (FailureOr x y)
 110
 111 -- ** Class 'InstrExceptionable'
 112 class InstrExceptionable (repr::ReprInstr) where
 113   -- | @('raise' exn)@ raises 'ExceptionLabel' @(exn)@.
 114   raise :: ExceptionLabel -> repr inp vs a
 115   -- | @('fail' fs)@ raises 'ExceptionFailure'.
 116   -- As a special case, giving 'Left'
 117   fail :: FailMode -> repr inp vs a
 118   -- | @('commit' exn k)@ removes the 'OnException'
 119   -- from the 'onExceptionStackByLabel' for the given 'Exception' @(exn)@,
 120   -- and continues with the next 'Instr'uction @(k)@.
 121   commit :: Exception -> repr inp vs a -> repr inp vs a
 122   -- | @('catch' exn l r)@ tries the @(l)@ 'Instr'uction
 123   -- in a new failure scope such that if @(l)@ raises an exception within @(exn)@, it is caught,
 124   -- then the input (and its 'Horizon') is pushed
 125   -- as it was before trying @(l)@ on the 'valueStack' (resp. on the 'horizonStack'),
 126   -- and the control flow goes on with the @(r)@ 'Instr'uction.
 127   catch ::
 128     Exception ->
 129     {-scope-}repr inp vs ret ->
 130     {-onException-}repr inp (InputPosition inp ': vs) ret ->
 131     repr inp vs ret
 132
 133 -- ** Class 'InstrBranchable'
 134 class InstrBranchable (repr::ReprInstr) where
 135   -- | @('caseBranch' l r)@.
 136   caseBranch ::
 137     repr inp (x ': vs) r ->
 138     repr inp (y ': vs) r ->
 139     repr inp (Either x y ': vs) r
 140   -- | @('choicesBranch' ps bs d)@.
 141   choicesBranch ::
 142     [(Splice (v -> Bool), repr inp vs a)] ->
 143     repr inp vs a ->
 144     repr inp (v ': vs) a
 145   -- | @('ifBranch' ok ko)@ pops a 'Bool' from the 'valueStack'
 146   -- and continues either with the 'Instr'uction @(ok)@ if it is 'True'
 147   -- or @(ko)@ otherwise.
 148   ifBranch ::
 149     repr inp vs a ->
 150     repr inp vs a ->
 151     repr inp (Bool ': vs) a
 152   ifBranch ok = choicesBranch [(Prod.id, ok)]
 153
 154 -- ** Class 'InstrCallable'
 155 class InstrCallable (repr::ReprInstr) where
 156   -- | @('defLet' n v k)@ binds the 'LetName' @(n)@ to the 'Instr'uction's @(v)@,
 157   -- 'Call's @(n)@ and
 158   -- continues with the next 'Instr'uction @(k)@.
 159   defLet ::
 160     LetBindings TH.Name (repr inp '[]) ->
 161     repr inp vs a ->
 162     repr inp vs a
 163   -- | @('call' isRec n k)@ pass the control-flow to the 'DefLet' named @(n)@,
 164   -- and when it 'Ret'urns, continues with the next 'Instr'uction @(k)@.
 165   call ::
 166     Bool ->
 167     LetName v -> repr inp (v ': vs) a ->
 168     repr inp vs a
 169   -- | @('ret')@ returns the value stored in a singleton 'valueStack'.
 170   ret ::
 171     repr inp '[a] a
 172   -- | @('jump' isRec n k)@ pass the control-flow to the 'DefLet' named @(n)@.
 173   jump ::
 174     Bool ->
 175     LetName a ->
 176     repr inp '[] a
 177
 178 -- ** Class 'InstrJoinable'
 179 class InstrJoinable (repr::ReprInstr) where
 180   defJoin ::
 181     LetName v -> repr inp (v ': vs) a ->
 182     repr inp vs a ->
 183     repr inp vs a
 184   refJoin ::
 185     LetName v ->
 186     repr inp (v ': vs) a
 187
 188 -- ** Class 'InstrInputable'
 189 class InstrInputable (repr::ReprInstr) where
 190   -- | @('saveInput' k)@ pushes the input @(inp)@ on the 'valueStackHead'
 191   -- and continues with the next 'Instr'uction @(k)@.
 192   saveInput ::
 193     repr inp (InputPosition inp ': vs) a ->
 194     repr inp vs a
 195   -- | @('loadInput' k)@ removes the input from the 'valueStackHead'
 196   -- and continues with the next 'Instr'uction @(k)@ using that input.
 197   loadInput ::
 198     repr inp vs a ->
 199     repr inp (InputPosition inp ': vs) a
 200
 201 -- ** Class 'InstrReadable'
 202 class InstrReadable (tok::Type) (repr::ReprInstr) where
 203   -- | @('read' fs p k)@ reads a 'Char' @(c)@ from the input,
 204   -- if @(p c)@ is 'True' then continues with the next 'Instr'uction @(k)@,
 205   -- otherwise 'fail'.
 206   read ::
 207     tok ~ InputToken inp =>
 208     Splice (tok -> Bool) ->
 209     repr inp (tok ': vs) a ->
 210     repr inp vs a
 211
 212 -- ** Class 'InstrIterable'
 213 class InstrIterable (repr::ReprInstr) where
 214   -- | @('iter' loop done)@.
 215   iter ::
 216     LetName a ->
 217     repr inp '[] a ->
 218     repr inp (InputPosition inp ': vs) a ->
 219     repr inp vs a
 220
 221 -- ** Class 'InstrRegisterable'
 222 class InstrRegisterable (repr::ReprInstr) where
 223   newRegister ::
 224     UnscopedRegister v ->
 225     repr inp vs a ->
 226     repr inp (v : vs) a
 227   readRegister ::
 228     UnscopedRegister v ->
 229     repr inp (v : vs) a ->
 230     repr inp vs a
 231   writeRegister ::
 232     UnscopedRegister v ->
 233     repr inp vs a ->
 234     repr inp (v : vs) a
 235
 236 -- | @('modifyRegister' reg k)@
 237 -- modifies the content of register @(reg)@
 238 -- with the function at the 'valueStackHead',
 239 -- then continues with @(k)@.
 240 modifyRegister ::
 241   InstrRegisterable repr =>
 242   InstrValuable repr =>
 243   UnscopedRegister v -> repr inp vs a -> repr inp ((v -> v) : vs) a
 244 modifyRegister r = readRegister r . applyValue . writeRegister r