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.Base.Univariant
  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 instance Show (Haskell a) where
  91   showsPrec p = \case
  92    Haskell{} -> showString "Haskell"
  93    (:.) -> showString "(.)"
  94    (:$) -> showString "($)"
  95    (:@) f x ->
  96     showParen (p > 0)
  97     Fun.$ showString "(@) "
  98     Fun.. showsPrec 10 f
  99     Fun.. showString " "
 100     Fun.. showsPrec 10 x
 101    Const -> showString "const"
 102    Flip -> showString "flip"
 103    Id -> showString "id"
 104 type instance Unlift Haskell = ValueCode
 105 instance Liftable Haskell where
 106   lift = Haskell
 107 instance Unliftable Haskell where
 108   unlift = \case
 109    Haskell x -> haskell x
 110    (:.) -> (.)
 111    (:$) -> ($)
 112    (:@) f x -> (.@) (unlift f) (unlift x)
 113    Const -> const
 114    Flip -> flip
 115    Id -> id
 116 infixr 0 $, :$
 117 infixr 9 ., :.
 118 infixl 9 .@, :@
 119
 120 instance Haskellable Haskell where
 121   haskell = Haskell
 122   (.)     = (:.)
 123   ($)     = (:$)
 124   (.@)    = (:@)
 125   const   = Const
 126   flip    = Flip
 127   id      = Id
 128   bool b  = Haskell (bool b)
 129   char c  = Haskell (char c)
 130   eq x    = Haskell (eq (unlift x))
 131   cons    = Haskell cons
 132   nil     = Haskell nil
 133   unit    = Haskell unit
 134   left    = Haskell left
 135   right   = Haskell right
 136   nothing = Haskell nothing
 137   just    = Haskell just
 138 instance Haskellable ValueCode where
 139   haskell  = Function.id
 140   (.)      = ValueCode (.) (.)
 141   ($)      = ValueCode ($) ($)
 142   (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
 143   bool b   = ValueCode (bool b) (bool b)
 144   char c   = ValueCode (char c) (char c)
 145   cons     = ValueCode cons cons
 146   const    = ValueCode const const
 147   eq x     = ValueCode (eq (value x)) (eq (code x))
 148   flip     = ValueCode flip flip
 149   id       = ValueCode id id
 150   nil      = ValueCode nil nil
 151   unit     = ValueCode unit unit
 152   left     = ValueCode left left
 153   right    = ValueCode right right
 154   nothing  = ValueCode nothing nothing
 155   just     = ValueCode just just
 156 instance Haskellable Value where
 157   haskell  = lift
 158   (.)      = Value (Function..)
 159   ($)      = Value (Function.$)
 160   (.@) f x = Value (unValue f (unValue x))
 161   bool     = Value
 162   char     = Value
 163   cons     = Value (:)
 164   const    = Value Function.const
 165   eq x     = Value (unValue x Eq.==)
 166   flip     = Value Function.flip
 167   id       = Value Function.id
 168   nil      = Value []
 169   unit     = Value ()
 170   left     = Value Left
 171   right    = Value Right
 172   nothing  = Value Nothing
 173   just     = Value Just
 174 instance Haskellable Code where
 175   haskell  = lift
 176   (.)      = Code [|| \f g x -> f (g x) ||]
 177   ($)      = Code [|| \f x -> f x ||]
 178   (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
 179   bool b   = Code [|| b ||]
 180   char c   = Code [|| c ||]
 181   cons     = Code [|| \x xs -> x : xs ||]
 182   const    = Code [|| \x _ -> x ||]
 183   eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
 184   flip     = Code [|| \f x y -> f y x ||]
 185   id       = Code [|| \x -> x ||]
 186   nil      = Code [|| [] ||]
 187   unit     = Code [|| () ||]
 188   left     = Code [|| Left ||]
 189   right    = Code [|| Right ||]
 190   nothing  = Code [|| Nothing ||]
 191   just     = Code [|| Just ||]