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 Haskell functions
  38 -- useful for some optimizations in 'optimizeComb'.
  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
  57 -- ** Type 'Haskellable'
  58 -- | Initial encoding of 'Haskellable'.
  59 data Haskell a where
  60   Haskell :: ValueCode a -> Haskell a
  61   (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
  62   (:$) :: Haskell ((a->b) -> a -> b)
  63   (:@) :: Haskell (a->b) -> Haskell a -> Haskell b
  64   Const :: Haskell (a -> b -> a)
  65   Flip :: Haskell ((a -> b -> c) -> b -> a -> c)
  66   Id :: Haskell (a->a)
  67   Unit :: Haskell ()
  68 infixr 0 $, :$
  69 infixr 9 ., :.
  70 infixl 9 .@, :@
  71 instance Show (Haskell a) where
  72   showsPrec p = \case
  73     Haskell{} -> showString "Haskell"
  74     (:.) -> showString "(.)"
  75     (:$) -> showString "($)"
  76     (:@) ((:.) :@ f) g ->
  77       showParen (p >= 9)
  78       Fun.$ showsPrec 9 f
  79       Fun.. showString " . "
  80       Fun.. showsPrec 9 g
  81     (:@) f x ->
  82       showParen (p >= 10)
  83       Fun.$ showsPrec 10 f
  84       Fun.. showString " "
  85       Fun.. showsPrec 10 x
  86     Const -> showString "const"
  87     Flip -> showString "flip"
  88     Id -> showString "id"
  89     Unit -> showString "()"
  90 instance Trans Haskell ValueCode where
  91   trans = \case
  92     Haskell x -> x
  93     (:.) -> (.)
  94     (:$) -> ($)
  95     (:@) f x -> (.@) (trans f) (trans x)
  96     Const -> const
  97     Flip -> flip
  98     Id -> id
  99     Unit -> unit
 100 instance Trans ValueCode Haskell where
 101   trans = Haskell
 102 type instance Output Haskell = ValueCode
 103
 104 instance Haskellable Haskell where
 105   (.)     = (:.)
 106   ($)     = (:$)
 107   -- Small optimizations, mainly to reduce dump sizes.
 108   Id .@ x = x
 109   (Const :@ x) .@ _y = x
 110   ((Flip :@ Const) :@ _x) .@ y = y
 111   f .@ x  = f :@ x
 112   const   = Const
 113   flip    = Flip
 114   id      = Id
 115   unit    = Unit
 116   bool b  = Haskell (bool b)
 117   char c  = Haskell (char c)
 118   eq x    = Haskell (eq (trans x))
 119   cons    = Haskell cons
 120   nil     = Haskell nil
 121   left    = Haskell left
 122   right   = Haskell right
 123   nothing = Haskell nothing
 124   just    = Haskell just
 125 instance Haskellable ValueCode where
 126   (.)      = ValueCode (.) (.)
 127   ($)      = ValueCode ($) ($)
 128   (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
 129   bool b   = ValueCode (bool b) (bool b)
 130   char c   = ValueCode (char c) (char c)
 131   cons     = ValueCode cons cons
 132   const    = ValueCode const const
 133   eq x     = ValueCode (eq (value x)) (eq (code x))
 134   flip     = ValueCode flip flip
 135   id       = ValueCode id id
 136   nil      = ValueCode nil nil
 137   unit     = ValueCode unit unit
 138   left     = ValueCode left left
 139   right    = ValueCode right right
 140   nothing  = ValueCode nothing nothing
 141   just     = ValueCode just just
 142 instance Haskellable Value where
 143   (.)      = Value (Function..)
 144   ($)      = Value (Function.$)
 145   (.@) f x = Value (unValue f (unValue x))
 146   bool     = Value
 147   char     = Value
 148   cons     = Value (:)
 149   const    = Value Function.const
 150   eq x     = Value (unValue x Eq.==)
 151   flip     = Value Function.flip
 152   id       = Value Function.id
 153   nil      = Value []
 154   unit     = Value ()
 155   left     = Value Left
 156   right    = Value Right
 157   nothing  = Value Nothing
 158   just     = Value Just
 159 instance Haskellable Code where
 160   (.)      = Code [|| \f g x -> f (g x) ||]
 161   ($)      = Code [|| \f x -> f x ||]
 162   (.@) f x = Code [|| $$(unCode f) $$(unCode x) ||]
 163   bool b   = Code [|| b ||]
 164   char c   = Code [|| c ||]
 165   cons     = Code [|| \x xs -> x : xs ||]
 166   const    = Code [|| \x _ -> x ||]
 167   eq x     = Code [|| \y -> $$(unCode x) Eq.== y ||]
 168   flip     = Code [|| \f x y -> f y x ||]
 169   id       = Code [|| \x -> x ||]
 170   nil      = Code [|| [] ||]
 171   unit     = Code [|| () ||]
 172   left     = Code [|| Left ||]
 173   right    = Code [|| Right ||]
 174   nothing  = Code [|| Nothing ||]
 175   just     = Code [|| Just ||]