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   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 ||]