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