src/Symantic/Parser/Staging.hs

   1 {-# LANGUAGE MagicHash #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 module Symantic.Parser.Staging where
   4
   5 import Data.Bool (Bool)
   6 import Data.Char (Char)
   7 import qualified Data.Function as Fun
   8 import Data.Either (Either(..))
   9 import Data.Eq (Eq)
  10 import Data.Ord (Ord(..))
  11 import Data.Maybe (Maybe(..))
  12 import Language.Haskell.TH (TExpQ)
  13 import Text.Show (Show(..), showParen, showString)
  14 import qualified Data.Eq as Eq
  15 import qualified Data.Function as Function
  16
  17 import Symantic.Univariant.Liftable
  18
  19 -- * Type 'ValueCode'
  20 -- | Compile-time 'value' and corresponding 'code' (that can produce that value at runtime).
  21 data ValueCode a = ValueCode
  22  { value :: Value a
  23  , code :: Code a
  24  }
  25 getValue :: ValueCode a -> a
  26 getValue = unValue Function.. value
  27 getCode :: ValueCode a -> TExpQ a
  28 getCode = unCode Function.. code
  29 type instance Unlift ValueCode = ValueCode
  30 instance Liftable ValueCode where
  31   lift = Function.id
  32   {-# INLINE lift #-}
  33 instance Unliftable ValueCode where
  34   unlift = Function.id
  35   {-# INLINE unlift #-}
  36
  37 -- ** Type 'Value'
  38 newtype Value a = Value { unValue :: a }
  39 type instance Unlift Value = Value
  40 instance Liftable Value where
  41   lift = Function.id
  42   {-# INLINE lift #-}
  43 instance Unliftable Value where
  44   unlift = Function.id
  45   {-# INLINE unlift #-}
  46
  47 -- ** Type 'Code'
  48 newtype Code a = Code { unCode :: TExpQ a }
  49 type instance Unlift Code = Code
  50 instance Liftable Code where
  51   lift = Function.id
  52   {-# INLINE lift #-}
  53 instance Unliftable Code where
  54   unlift = Function.id
  55   {-# INLINE unlift #-}
  56
  57 -- * Class 'Haskellable'
  58 -- | Final encoding of some Haskellable functions
  59 -- useful for some optimizations in 'optGram'.
  60 class Haskellable (repr :: * -> *) where
  61   haskell :: Unlift repr a -> repr a
  62   (.) :: repr ((b->c) -> (a->b) -> a -> c)
  63   ($) :: repr ((a->b) -> a -> b)
  64   (.@) :: repr (a->b) -> repr a -> repr b
  65   bool :: Bool -> repr Bool
  66   char :: Char -> repr Char
  67   cons :: repr (a -> [a] -> [a])
  68   const :: repr (a -> b -> a)
  69   eq :: Eq a => repr a -> repr (a -> Bool)
  70   flip :: repr ((a -> b -> c) -> b -> a -> c)
  71   id :: repr (a->a)
  72   nil :: repr [a]
  73   unit :: repr ()
  74   left :: repr (l -> Either l r)
  75   right :: repr (r -> Either l r)
  76   nothing :: repr (Maybe a)
  77   just :: repr (a -> Maybe a)
  78 -- instance Haskellable Identity
  79
  80 -- ** Type 'Haskellable'
  81 -- | Initial encoding of 'Haskellable'
  82 data Haskell a where
  83   Haskell :: ValueCode a -> Haskell a
  84   (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
  85   (:$) :: Haskell ((a->b) -> a -> b)
  86   (:@) :: Haskell (a->b) -> Haskell a -> Haskell b
  87   Const :: Haskell (a -> b -> a)
  88   Flip :: Haskell ((a -> b -> c) -> b -> a -> c)
  89   Id :: Haskell (a->a)
  90   Unit :: Haskell ()
  91 instance Show (Haskell a) where
  92   showsPrec p = \case
  93    Haskell{} -> showString "Haskell"
  94    (:.) -> showString "(.)"
  95    (:$) -> showString "($)"
  96    (:@) f x ->
  97     showParen (p > 0)
  98     Fun.$ showString "(@) "
  99     Fun.. showsPrec 10 f
 100     Fun.. showString " "
 101     Fun.. showsPrec 10 x
 102    Const -> showString "const"
 103    Flip -> showString "flip"
 104    Id -> showString "id"
 105    Unit -> showString "()"
 106 type instance Unlift Haskell = ValueCode
 107 instance Liftable Haskell where
 108   lift = Haskell
 109 instance Unliftable Haskell where
 110   unlift = \case
 111    Haskell x -> haskell x
 112    (:.) -> (.)
 113    (:$) -> ($)
 114    (:@) f x -> (.@) (unlift f) (unlift x)
 115    Const -> const
 116    Flip -> flip
 117    Id -> id
 118    Unit -> unit
 119 infixr 0 $, :$
 120 infixr 9 ., :.
 121 infixl 9 .@, :@
 122
 123 instance Haskellable Haskell where
 124   haskell = Haskell
 125   (.)     = (:.)
 126   ($)     = (:$)
 127   (.@)    = (:@)
 128   const   = Const
 129   flip    = Flip
 130   id      = Id
 131   unit    = Unit
 132   bool b  = Haskell (bool b)
 133   char c  = Haskell (char c)
 134   eq x    = Haskell (eq (unlift x))
 135   cons    = Haskell cons
 136   nil     = Haskell nil
 137   left    = Haskell left
 138   right   = Haskell right
 139   nothing = Haskell nothing
 140   just    = Haskell just
 141 instance Haskellable ValueCode where
 142   haskell  = Function.id
 143   (.)      = ValueCode (.) (.)
 144   ($)      = ValueCode ($) ($)
 145   (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
 146   bool b   = ValueCode (bool b) (bool b)
 147   char c   = ValueCode (char c) (char c)
 148   cons     = ValueCode cons cons
 149   const    = ValueCode const const
 150   eq x     = ValueCode (eq (value x)) (eq (code x))
 151   flip     = ValueCode flip flip
 152   id       = ValueCode id id
 153   nil      = ValueCode nil nil
 154   unit     = ValueCode unit unit
 155   left     = ValueCode left left
 156   right    = ValueCode right right
 157   nothing  = ValueCode nothing nothing
 158   just     = ValueCode just just
 159 instance Haskellable Value where
 160   haskell  = lift
 161   (.)      = Value (Function..)
 162   ($)      = Value (Function.$)
 163   (.@) f x = Value (unValue f (unValue x))
 164   bool     = Value
 165   char     = Value
 166   cons     = Value (:)
 167   const    = Value Function.const
 168   eq x     = Value (unValue x Eq.==)
 169   flip     = Value Function.flip
 170   id       = Value Function.id
 171   nil      = Value []
 172   unit     = Value ()
 173   left     = Value Left
 174   right    = Value Right
 175   nothing  = Value Nothing
 176   just     = Value Just
 177 instance Haskellable Code where
 178   haskell  = lift
 179   (.)      = Code [|| \f g x -> f (g x) ||]
 180   ($)      = Code [|| \f x -> f x ||]
 181   (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
 182   bool b   = Code [|| b ||]
 183   char c   = Code [|| c ||]
 184   cons     = Code [|| \x xs -> x : xs ||]
 185   const    = Code [|| \x _ -> x ||]
 186   eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
 187   flip     = Code [|| \f x y -> f y x ||]
 188   id       = Code [|| \x -> x ||]
 189   nil      = Code [|| [] ||]
 190   unit     = Code [|| () ||]
 191   left     = Code [|| Left ||]
 192   right    = Code [|| Right ||]
 193   nothing  = Code [|| Nothing ||]
 194   just     = Code [|| Just ||]