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