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