src/Symantic/Parser/Staging.hs

   1 {-# LANGUAGE PatternSynonyms #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 module Symantic.Parser.Staging where
   4
   5 import Data.Bool (Bool(..))
   6 import Data.Either (Either(..))
   7 import Data.Eq (Eq)
   8 import Data.Maybe (Maybe(..))
   9 import Data.Ord (Ord(..))
  10 import Data.Kind (Type)
  11 import Text.Show (Show(..), showParen, showString)
  12 import qualified Data.Eq as Eq
  13 import qualified Data.Function as Function
  14 import qualified Language.Haskell.TH as TH
  15 import qualified Language.Haskell.TH.Syntax as TH
  16
  17 import Symantic.Univariant.Trans
  18
  19 -- * Type 'ValueCode'
  20 -- | Compile-time 'value' and corresponding 'code'
  21 -- (that can produce that value at runtime).
  22 data ValueCode a = ValueCode
  23   { value :: Value a
  24   , code :: TH.CodeQ a
  25   }
  26 getValue :: ValueCode a -> a
  27 getValue = unValue Function.. value
  28 getCode :: ValueCode a -> TH.CodeQ a
  29 getCode = code
  30
  31 -- ** Type 'Value'
  32 newtype Value a = Value { unValue :: a }
  33
  34 -- * Class 'Haskellable'
  35 -- | Final encoding of some Haskell functions
  36 -- useful for some optimizations in 'optimizeComb'.
  37 class Haskellable (repr :: Type -> Type) where
  38   (.) :: repr ((b->c) -> (a->b) -> a -> c)
  39   ($) :: repr ((a->b) -> a -> b)
  40   (.@) :: repr (a->b) -> repr a -> repr b
  41   bool :: Bool -> repr Bool
  42   char :: TH.Lift tok => tok -> repr tok
  43   cons :: repr (a -> [a] -> [a])
  44   const :: repr (a -> b -> a)
  45   eq :: Eq a => repr a -> repr (a -> Bool)
  46   flip :: repr ((a -> b -> c) -> b -> a -> c)
  47   id :: repr (a->a)
  48   nil :: repr [a]
  49   unit :: repr ()
  50   left :: repr (l -> Either l r)
  51   right :: repr (r -> Either l r)
  52   nothing :: repr (Maybe a)
  53   just :: repr (a -> Maybe a)
  54
  55 -- ** Type 'Haskellable'
  56 -- | Initial encoding of 'Haskellable'.
  57 data Haskell a where
  58   Haskell :: ValueCode a -> Haskell a
  59   (:.) :: Haskell ((b->c) -> (a->b) -> a -> c)
  60   (:$) :: Haskell ((a->b) -> a -> b)
  61   (:@) :: Haskell (a->b) -> Haskell a -> Haskell b
  62   Cons :: Haskell (a -> [a] -> [a])
  63   Const :: Haskell (a -> b -> a)
  64   Eq :: Eq a => Haskell a -> Haskell (a -> Bool)
  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
  72 {-
  73 pattern (:.@) ::
  74   -- Dummy constraint to get the following constraint
  75   -- in scope when pattern-matching.
  76   () =>
  77   ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
  78   Haskell x -> Haskell y -> Haskell z
  79 pattern (:.@) f g = (:.) :@ f :@ g
  80 pattern FlipApp ::
  81   () =>
  82   ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
  83   Haskell x -> Haskell y
  84 pattern FlipApp f = Flip :@ f
  85 pattern FlipConst ::
  86   () =>
  87   (x ~ (a -> b -> b)) =>
  88   Haskell x
  89 pattern FlipConst = FlipApp Const
  90 -}
  91
  92 instance Show (Haskell a) where
  93   showsPrec p = \case
  94     Haskell{} -> showString "Haskell"
  95     (:$) -> showString "($)"
  96     (:.) :@ f :@ g ->
  97       showParen (p >= 9)
  98       Function.$ showsPrec 9 f
  99       Function.. showString " . "
 100       Function.. showsPrec 9 g
 101     (:.) -> showString "(.)"
 102     Cons :@ x :@ xs ->
 103       showParen (p >= 10)
 104       Function.$ showsPrec 10 x
 105       Function.. showString " : "
 106       Function.. showsPrec 10 xs
 107     Cons -> showString "cons"
 108     Const -> showString "const"
 109     Eq x ->
 110       showParen True
 111       Function.$ showString "== "
 112       Function.. showsPrec 0 x
 113     Flip -> showString "flip"
 114     Id -> showString "id"
 115     Unit -> showString "()"
 116     (:@) f x ->
 117       showParen (p >= 10)
 118       Function.$ showsPrec 10 f
 119       Function.. showString " "
 120       Function.. showsPrec 10 x
 121 instance Trans Haskell Value where
 122   trans = value Function.. trans
 123 instance Trans Haskell TH.CodeQ where
 124   trans = code Function.. trans
 125 instance Trans Haskell ValueCode where
 126   trans = \case
 127     Haskell x -> x
 128     (:.) -> (.)
 129     (:$) -> ($)
 130     (:@) f x -> (.@) (trans f) (trans x)
 131     Cons -> cons
 132     Const -> const
 133     Eq x -> eq (trans x)
 134     Flip -> flip
 135     Id -> id
 136     Unit -> unit
 137 instance Trans ValueCode Haskell where
 138   trans = Haskell
 139 type instance Output Haskell = ValueCode
 140
 141 instance Haskellable Haskell where
 142   (.)     = (:.)
 143   ($)     = (:$)
 144   -- Small optimizations, mainly to reduce dump sizes.
 145   Id .@ x = x
 146   (Const :@ x) .@ _y = x
 147   ((Flip :@ Const) :@ _x) .@ y = y
 148   --
 149   f .@ x  = f :@ x
 150   cons    = Cons
 151   const   = Const
 152   eq      = Eq
 153   flip    = Flip
 154   id      = Id
 155   unit    = Unit
 156   bool b  = Haskell (bool b)
 157   char c  = Haskell (char c)
 158   nil     = Haskell nil
 159   left    = Haskell left
 160   right   = Haskell right
 161   nothing = Haskell nothing
 162   just    = Haskell just
 163 instance Haskellable ValueCode where
 164   (.)      = ValueCode (.) (.)
 165   ($)      = ValueCode ($) ($)
 166   (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
 167   bool b   = ValueCode (bool b) (bool b)
 168   char c   = ValueCode (char c) (char c)
 169   cons     = ValueCode cons cons
 170   const    = ValueCode const const
 171   eq x     = ValueCode (eq (value x)) (eq (code x))
 172   flip     = ValueCode flip flip
 173   id       = ValueCode id id
 174   nil      = ValueCode nil nil
 175   unit     = ValueCode unit unit
 176   left     = ValueCode left left
 177   right    = ValueCode right right
 178   nothing  = ValueCode nothing nothing
 179   just     = ValueCode just just
 180 instance Haskellable Value where
 181   (.)      = Value (Function..)
 182   ($)      = Value (Function.$)
 183   (.@) f x = Value (unValue f (unValue x))
 184   bool     = Value
 185   char     = Value
 186   cons     = Value (:)
 187   const    = Value Function.const
 188   eq x     = Value (unValue x Eq.==)
 189   flip     = Value Function.flip
 190   id       = Value Function.id
 191   nil      = Value []
 192   unit     = Value ()
 193   left     = Value Left
 194   right    = Value Right
 195   nothing  = Value Nothing
 196   just     = Value Just
 197 instance Haskellable TH.CodeQ where
 198   (.)      = [|| (Function..) ||]
 199   ($)      = [|| (Function.$) ||]
 200   (.@) f x = [|| $$f $$x ||]
 201   bool b   = [|| b ||]
 202   char c   = [|| c ||]
 203   cons     = [|| (:) ||]
 204   const    = [|| Function.const ||]
 205   eq x     = [|| ($$x Eq.==) ||]
 206   flip     = [|| \f x y -> f y x ||]
 207   id       = [|| \x -> x ||]
 208   nil      = [|| [] ||]
 209   unit     = [|| () ||]
 210   left     = [|| Left ||]
 211   right    = [|| Right ||]
 212   nothing  = [|| Nothing ||]
 213   just     = [|| Just ||]