src/Symantic/Parser/Haskell.hs

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