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 Data.Either (Either(..))
   8 import Data.Eq (Eq)
   9 import Data.Maybe (Maybe(..))
  10 import Data.Ord (Ord(..))
  11 import Language.Haskell.TH (TExpQ)
  12 import Text.Show (Show(..), showParen, showString)
  13 import qualified Data.Eq as Eq
  14 import qualified Data.Function as Fun
  15 import qualified Data.Function as Function
  16
  17 import Symantic.Univariant.Trans
  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
  30 -- ** Type 'Value'
  31 newtype Value a = Value { unValue :: a }
  32
  33 -- ** Type 'Code'
  34 newtype Code a = Code { unCode :: TExpQ a }
  35
  36 -- * Class 'Haskellable'
  37 -- | Final encoding of some Haskellable functions
  38 -- useful for some optimizations in 'optGram'.
  39 class Haskellable (repr :: * -> *) where
  40   (.) :: repr ((b->c) -> (a->b) -> a -> c)
  41   ($) :: repr ((a->b) -> a -> b)
  42   (.@) :: repr (a->b) -> repr a -> repr b
  43   bool :: Bool -> repr Bool
  44   char :: Char -> repr Char
  45   cons :: repr (a -> [a] -> [a])
  46   const :: repr (a -> b -> a)
  47   eq :: Eq a => repr a -> repr (a -> Bool)
  48   flip :: repr ((a -> b -> c) -> b -> a -> c)
  49   id :: repr (a->a)
  50   nil :: repr [a]
  51   unit :: repr ()
  52   left :: repr (l -> Either l r)
  53   right :: repr (r -> Either l r)
  54   nothing :: repr (Maybe a)
  55   just :: repr (a -> Maybe a)
  56 -- instance Haskellable Identity
  57
  58 -- ** Type 'Haskellable'
  59 -- | Initial encoding of 'Haskellable'
  60 data Haskell a where
  61   Haskell :: ValueCode a -> Haskell a
  62   (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
  63   (:$) :: Haskell ((a->b) -> a -> b)
  64   (:@) :: Haskell (a->b) -> Haskell a -> Haskell b
  65   Const :: Haskell (a -> b -> a)
  66   Flip :: Haskell ((a -> b -> c) -> b -> a -> c)
  67   Id :: Haskell (a->a)
  68   Unit :: Haskell ()
  69 infixr 0 $, :$
  70 infixr 9 ., :.
  71 infixl 9 .@, :@
  72 instance Show (Haskell a) where
  73   showsPrec p = \case
  74    Haskell{} -> showString "Haskell"
  75    (:.) -> showString "(.)"
  76    (:$) -> showString "($)"
  77    (:@) f x ->
  78     showParen (p > 0)
  79     Fun.$ showString "(@) "
  80     Fun.. showsPrec 10 f
  81     Fun.. showString " "
  82     Fun.. showsPrec 10 x
  83    Const -> showString "const"
  84    Flip -> showString "flip"
  85    Id -> showString "id"
  86    Unit -> showString "()"
  87 instance Trans Haskell ValueCode where
  88   trans = \case
  89    Haskell x -> x
  90    (:.) -> (.)
  91    (:$) -> ($)
  92    (:@) f x -> (.@) (trans f) (trans x)
  93    Const -> const
  94    Flip -> flip
  95    Id -> id
  96    Unit -> unit
  97 instance Trans ValueCode Haskell where
  98   trans = Haskell
  99 type instance Output Haskell = ValueCode
 100
 101 instance Haskellable Haskell where
 102   (.)     = (:.)
 103   ($)     = (:$)
 104   (.@)    = (:@)
 105   const   = Const
 106   flip    = Flip
 107   id      = Id
 108   unit    = Unit
 109   bool b  = Haskell (bool b)
 110   char c  = Haskell (char c)
 111   eq x    = Haskell (eq (trans x))
 112   cons    = Haskell cons
 113   nil     = Haskell nil
 114   left    = Haskell left
 115   right   = Haskell right
 116   nothing = Haskell nothing
 117   just    = Haskell just
 118 instance Haskellable ValueCode where
 119   (.)      = ValueCode (.) (.)
 120   ($)      = ValueCode ($) ($)
 121   (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
 122   bool b   = ValueCode (bool b) (bool b)
 123   char c   = ValueCode (char c) (char c)
 124   cons     = ValueCode cons cons
 125   const    = ValueCode const const
 126   eq x     = ValueCode (eq (value x)) (eq (code x))
 127   flip     = ValueCode flip flip
 128   id       = ValueCode id id
 129   nil      = ValueCode nil nil
 130   unit     = ValueCode unit unit
 131   left     = ValueCode left left
 132   right    = ValueCode right right
 133   nothing  = ValueCode nothing nothing
 134   just     = ValueCode just just
 135 instance Haskellable Value where
 136   (.)      = Value (Function..)
 137   ($)      = Value (Function.$)
 138   (.@) f x = Value (unValue f (unValue x))
 139   bool     = Value
 140   char     = Value
 141   cons     = Value (:)
 142   const    = Value Function.const
 143   eq x     = Value (unValue x Eq.==)
 144   flip     = Value Function.flip
 145   id       = Value Function.id
 146   nil      = Value []
 147   unit     = Value ()
 148   left     = Value Left
 149   right    = Value Right
 150   nothing  = Value Nothing
 151   just     = Value Just
 152 instance Haskellable Code where
 153   (.)      = Code [|| \f g x -> f (g x) ||]
 154   ($)      = Code [|| \f x -> f x ||]
 155   (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
 156   bool b   = Code [|| b ||]
 157   char c   = Code [|| c ||]
 158   cons     = Code [|| \x xs -> x : xs ||]
 159   const    = Code [|| \x _ -> x ||]
 160   eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
 161   flip     = Code [|| \f x y -> f y x ||]
 162   id       = Code [|| \x -> x ||]
 163   nil      = Code [|| [] ||]
 164   unit     = Code [|| () ||]
 165   left     = Code [|| Left ||]
 166   right    = Code [|| Right ||]
 167   nothing  = Code [|| Nothing ||]
 168   just     = Code [|| Just ||]