src/Symantic/Parser/Staging.hs

   1 {-# LANGUAGE TemplateHaskell #-}
   2 module Symantic.Parser.Staging where
   3
   4 import Data.Bool (Bool)
   5 import Data.Char (Char)
   6 import Data.Eq (Eq)
   7 import Data.Functor.Identity (Identity(..))
   8 import Language.Haskell.TH (TExpQ)
   9 import qualified Data.Eq as Eq
  10 import qualified Data.Function as Function
  11
  12 import Symantic.Base.Univariant
  13
  14 -- * Type 'Runtime'
  15 data Runtime a = Runtime
  16  { eval :: Eval a
  17    -- ^ The value of the runtime code,
  18    -- kept along to be made available to the optimizer.
  19  , code :: Code a
  20    -- ^ An AST of a runtime value.
  21  }
  22 getEval :: Runtime a -> a
  23 getEval = unEval Function.. eval
  24 getCode :: Runtime a -> TExpQ a
  25 getCode = unCode Function.. code
  26 type instance Unlift Runtime = Runtime
  27 instance Liftable Runtime where
  28   lift = Function.id
  29   {-# INLINE lift #-}
  30 instance Unliftable Runtime where
  31   unlift = Function.id
  32   {-# INLINE unlift #-}
  33
  34 -- ** Type 'Eval'
  35 newtype Eval a = Eval { unEval :: a }
  36 type instance Unlift Eval = Eval
  37 instance Liftable Eval where
  38   lift = Function.id
  39   {-# INLINE lift #-}
  40 instance Unliftable Eval where
  41   unlift = Function.id
  42   {-# INLINE unlift #-}
  43
  44 -- ** Type 'Code'
  45 newtype Code a = Code { unCode :: TExpQ a }
  46 type instance Unlift Code = Code
  47 instance Liftable Code where
  48   lift = Function.id
  49   {-# INLINE lift #-}
  50 instance Unliftable Code where
  51   unlift = Function.id
  52   {-# INLINE unlift #-}
  53
  54 -- * Class 'Runtimeable'
  55 -- | Final encoding of some Runtimeable functions
  56 -- useful for some optimizations in 'optGram'.
  57 class Runtimeable (app :: * -> *) where
  58   runtime :: Unlift app a -> app a
  59   (.)   :: app ((b->c) -> (a->b) -> a -> c)
  60   ($)   :: app ((a->b) -> a -> b)
  61   (.@)  :: app (a->b) -> app a -> app b
  62   bool  :: Bool -> app Bool
  63   char  :: Char -> app Char
  64   cons  :: app (a -> [a] -> [a])
  65   const :: app (a -> b -> a)
  66   eq    :: Eq a => app a -> app (a -> Bool)
  67   flip  :: app ((a -> b -> c) -> b -> a -> c)
  68   id    :: app (a->a)
  69   nil   :: app [a]
  70   unit  :: app ()
  71 instance Runtimeable Identity
  72
  73 -- ** Type 'Runtimeable'
  74 -- | Initial encoding of 'Runtimeable'
  75 data OptRuntime (app:: * -> *) a where
  76   OptRuntime :: app a -> OptRuntime app a
  77   (:.)  :: OptRuntime app ((b->c) -> (a->b) -> a -> c)
  78   (:$)  :: OptRuntime app ((a->b) -> a -> b)
  79   (:@)  :: OptRuntime app (a->b) -> OptRuntime app a -> OptRuntime app b
  80   Const :: OptRuntime app (a -> b -> a)
  81   Flip  :: OptRuntime app ((a -> b -> c) -> b -> a -> c)
  82   Id    :: OptRuntime app (a->a)
  83 type instance Unlift (OptRuntime app) = app
  84 instance (Liftable app, Unliftable app, Runtimeable app) => Liftable (OptRuntime app) where
  85   lift = OptRuntime
  86 instance (Unliftable app, Runtimeable app) => Unliftable (OptRuntime app) where
  87   unlift = \case
  88    OptRuntime x -> runtime (unlift x)
  89    (:.)     -> (.)
  90    (:$)     -> ($)
  91    (:@) f x -> (.@) (unlift f) (unlift x)
  92    Const    -> const
  93    Flip     -> flip
  94    Id       -> id
  95 infixr 0 $, :$
  96 infixr 9 ., :.
  97 infixl 9 .@, :@
  98
  99 instance Runtimeable (OptRuntime app) where
 100   runtime = OptRuntime
 101   (.)   = (:.)
 102   ($)   = (:$)
 103   (.@)  = (:@)
 104   const = Const
 105   flip  = Flip
 106   id    = Id
 107 instance Runtimeable Runtime where
 108   runtime  = Function.id
 109   (.)      = Runtime (.) (.)
 110   ($)      = Runtime ($) ($)
 111   (.@) f x = Runtime ((.@) (eval f) (eval x)) ((.@) (code f) (code x))
 112   bool b   = Runtime (bool b) (bool b)
 113   char c   = Runtime (char c) (char c)
 114   cons     = Runtime cons cons
 115   const    = Runtime const const
 116   eq x     = Runtime (eq (eval x)) (eq (code x))
 117   flip     = Runtime flip flip
 118   id       = Runtime id id
 119   nil      = Runtime nil nil
 120   unit     = Runtime unit unit
 121 instance Runtimeable Eval where
 122   runtime  = lift
 123   (.)      = Eval (Function..)
 124   ($)      = Eval (Function.$)
 125   (.@) f x = Eval ((unEval f) (unEval x))
 126   bool     = Eval
 127   char     = Eval
 128   cons     = Eval (:)
 129   const    = Eval Function.const
 130   eq x     = Eval (unEval x Eq.==)
 131   flip     = Eval Function.flip
 132   id       = Eval Function.id
 133   nil      = Eval []
 134   unit     = Eval ()
 135 instance Runtimeable Code where
 136   runtime  = lift
 137   (.)      = Code [|| \f g x -> f (g x) ||]
 138   ($)      = Code [|| \f x -> f x ||]
 139   (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
 140   bool b   = Code [|| b ||]
 141   char c   = Code [|| c ||]
 142   cons     = Code [|| \x xs -> x : xs ||]
 143   const    = Code [|| \x _ -> x ||]
 144   eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
 145   flip     = Code [|| \f x y -> f y x ||]
 146   id       = Code [|| \x -> x ||]
 147   nil      = Code [|| [] ||]
 148   unit     = Code [|| () ||]