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 'Haskellable'
  54 -- | Final encoding of some Haskellable functions
  55 -- useful for some optimizations in 'optGram'.
  56 class Haskellable (app :: * -> *) where
  57   runtime :: Unlift app a -> app a
  58   (.) :: app ((b->c) -> (a->b) -> a -> c)
  59   ($) :: app ((a->b) -> a -> b)
  60   (.@) :: app (a->b) -> app a -> app b
  61   bool :: Bool -> app Bool
  62   char :: Char -> app Char
  63   cons :: app (a -> [a] -> [a])
  64   const :: app (a -> b -> a)
  65   eq :: Eq a => app a -> app (a -> Bool)
  66   flip :: app ((a -> b -> c) -> b -> a -> c)
  67   id :: app (a->a)
  68   nil :: app [a]
  69   unit :: app ()
  70 -- instance Haskellable Identity
  71
  72 -- ** Type 'Haskellable'
  73 -- | Initial encoding of 'Haskellable'
  74 data Haskell (app:: * -> *) a where
  75   Haskell :: app a -> Haskell app a
  76   (:.) :: Haskell app ((b->c) -> (a->b) -> a -> c)
  77   (:$) :: Haskell app ((a->b) -> a -> b)
  78   (:@) :: Haskell app (a->b) -> Haskell app a -> Haskell app b
  79   Const :: Haskell app (a -> b -> a)
  80   Flip :: Haskell app ((a -> b -> c) -> b -> a -> c)
  81   Id :: Haskell app (a->a)
  82 type instance Unlift (Haskell app) = app
  83 instance (Liftable app, Unliftable app, Haskellable app) => Liftable (Haskell app) where
  84   lift = Haskell
  85 instance (Unliftable app, Haskellable app) => Unliftable (Haskell app) where
  86   unlift = \case
  87    Haskell x -> runtime (unlift x)
  88    (:.) -> (.)
  89    (:$) -> ($)
  90    (:@) f x -> (.@) (unlift f) (unlift x)
  91    Const -> const
  92    Flip -> flip
  93    Id -> id
  94 infixr 0 $, :$
  95 infixr 9 ., :.
  96 infixl 9 .@, :@
  97
  98 instance Haskellable (Haskell app) where
  99   runtime = Haskell
 100   (.)   = (:.)
 101   ($)   = (:$)
 102   (.@)  = (:@)
 103   const = Const
 104   flip  = Flip
 105   id    = Id
 106 instance Haskellable Runtime where
 107   runtime  = Function.id
 108   (.)      = Runtime (.) (.)
 109   ($)      = Runtime ($) ($)
 110   (.@) f x = Runtime ((.@) (eval f) (eval x)) ((.@) (code f) (code x))
 111   bool b   = Runtime (bool b) (bool b)
 112   char c   = Runtime (char c) (char c)
 113   cons     = Runtime cons cons
 114   const    = Runtime const const
 115   eq x     = Runtime (eq (eval x)) (eq (code x))
 116   flip     = Runtime flip flip
 117   id       = Runtime id id
 118   nil      = Runtime nil nil
 119   unit     = Runtime unit unit
 120 instance Haskellable Eval where
 121   runtime  = lift
 122   (.)      = Eval (Function..)
 123   ($)      = Eval (Function.$)
 124   (.@) f x = Eval (unEval f (unEval x))
 125   bool     = Eval
 126   char     = Eval
 127   cons     = Eval (:)
 128   const    = Eval Function.const
 129   eq x     = Eval (unEval x Eq.==)
 130   flip     = Eval Function.flip
 131   id       = Eval Function.id
 132   nil      = Eval []
 133   unit     = Eval ()
 134 instance Haskellable Code where
 135   runtime  = lift
 136   (.)      = Code [|| \f g x -> f (g x) ||]
 137   ($)      = Code [|| \f x -> f x ||]
 138   (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
 139   bool b   = Code [|| b ||]
 140   char c   = Code [|| c ||]
 141   cons     = Code [|| \x xs -> x : xs ||]
 142   const    = Code [|| \x _ -> x ||]
 143   eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
 144   flip     = Code [|| \f x y -> f y x ||]
 145   id       = Code [|| \x -> x ||]
 146   nil      = Code [|| [] ||]
 147   unit     = Code [|| () ||]