src/Symantic/Parser/Automaton/Instructions.hs

   1 {-# LANGUAGE PatternSynonyms #-}
   2 {-# LANGUAGE NoPolyKinds #-}
   3 {-# LANGUAGE ViewPatterns #-}
   4 module Symantic.Parser.Automaton.Instructions where
   5
   6 import Data.Function (($))
   7 import Symantic.Univariant.Trans
   8 import Symantic.Parser.Grammar
   9 import qualified Symantic.Parser.Staging as Hask
  10
  11 {-
  12 class Automatable repr where
  13   ret :: repr inp '[r] n r a
  14   push :: x -> repr inp (x ': xs) n r a -> repr inp xs n r a
  15   pop :: repr inp xs n r a -> repr inp (x ': xs) n r a
  16 -}
  17
  18 data Instr inp xs n r a where
  19   Ret :: Instr inp '[r] n r a
  20   Push :: Hask.Haskell x -> Instr inp (x ': xs) n r a -> Instr inp xs n r a
  21   Pop :: Instr inp xs n r a -> Instr inp (x ': xs) n r a
  22   Lift2 :: Hask.Haskell (x -> y -> z) -> Instr inp (z : xs) n r a -> Instr inp (y : x : xs) n r a
  23
  24 pattern App :: Instr inp (y : xs) n r a -> Instr inp (x : (x -> y) : xs) n r a
  25 pattern App k = Lift2 (Hask.:$) k
  26
  27
  28 data Automaton inp a x = Automaton { unAutomaton ::
  29   forall xs n r.
  30   Instr inp (x ': xs) n r a ->
  31   Instr inp xs n r a
  32   }
  33
  34 instance Trans (Grammar) (Automaton inp a) where
  35   trans g =
  36     case g of
  37       Pure x -> Automaton $ \k -> Push x k
  38       (trans -> Automaton f) :<*> (trans -> Automaton x) ->
  39         Automaton $ \k -> f (x (App k))