src/Symantic/Parser/Grammar/Pure.hs

   1 {-# LANGUAGE PatternSynonyms #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 -- | Haskell terms which are interesting
   4 -- to pattern-match when optimizing.
   5 module Symantic.Parser.Grammar.Pure 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 'CombPurable'
  37 -- | Final encoding of 'CombPure',
  38 -- extended with useful terms.
  39 class CombPurable (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 'CombPurable'
  58 -- | Initial encoding of 'CombPurable',
  59 -- useful for some optimizations in 'optimizeComb'.
  60 data CombPure a where
  61   CombPure :: ValueCode a -> CombPure a
  62   (:.) :: CombPure ((b->c) -> (a->b) -> a -> c)
  63   (:$) :: CombPure ((a->b) -> a -> b)
  64   (:@) :: CombPure (a->b) -> CombPure a -> CombPure b
  65   Cons :: CombPure (a -> [a] -> [a])
  66   Const :: CombPure (a -> b -> a)
  67   Eq :: Eq a => CombPure a -> CombPure (a -> Bool)
  68   Flip :: CombPure ((a -> b -> c) -> b -> a -> c)
  69   Id :: CombPure (a->a)
  70   Unit :: CombPure ()
  71 infixr 0 $, :$
  72 infixr 9 ., :.
  73 infixl 9 .@, :@
  74
  75 {-
  76 pattern (:.@) ::
  77   -- Dummy constraint to get the following constraint
  78   -- in scope when pattern-matching.
  79   () =>
  80   ((x -> y -> z) ~ ((b -> c) -> (a -> b) -> a -> c)) =>
  81   CombPure x -> CombPure y -> CombPure z
  82 pattern (:.@) f g = (:.) :@ f :@ g
  83 pattern FlipApp ::
  84   () =>
  85   ((x -> y) ~ ((a -> b -> c) -> b -> a -> c)) =>
  86   CombPure x -> CombPure y
  87 pattern FlipApp f = Flip :@ f
  88 pattern FlipConst ::
  89   () =>
  90   (x ~ (a -> b -> b)) =>
  91   CombPure x
  92 pattern FlipConst = FlipApp Const
  93 -}
  94
  95 instance Show (CombPure a) where
  96   showsPrec p = \case
  97     CombPure{} -> showString "CombPure"
  98     (:$) -> showString "($)"
  99     (:.) :@ f :@ g ->
 100       showParen (p >= 9)
 101       Function.$ showsPrec 9 f
 102       Function.. showString " . "
 103       Function.. showsPrec 9 g
 104     (:.) -> showString "(.)"
 105     Cons :@ x :@ xs ->
 106       showParen (p >= 10)
 107       Function.$ showsPrec 10 x
 108       Function.. showString " : "
 109       Function.. showsPrec 10 xs
 110     Cons -> showString "cons"
 111     Const -> showString "const"
 112     Eq x ->
 113       showParen True
 114       Function.$ showString "== "
 115       Function.. showsPrec 0 x
 116     Flip -> showString "flip"
 117     Id -> showString "id"
 118     Unit -> showString "()"
 119     (:@) f x ->
 120       showParen (p >= 10)
 121       Function.$ showsPrec 10 f
 122       Function.. showString " "
 123       Function.. showsPrec 10 x
 124
 125 instance Trans CombPure TH.CodeQ where
 126   trans = code Function.. trans
 127 instance Trans CombPure Value where
 128   trans = value Function.. trans
 129 instance Trans CombPure ValueCode where
 130   trans = \case
 131     CombPure x -> x
 132     (:.) -> (.)
 133     (:$) -> ($)
 134     (:@) f x -> (.@) (trans f) (trans x)
 135     Cons -> cons
 136     Const -> const
 137     Eq x -> eq (trans x)
 138     Flip -> flip
 139     Id -> id
 140     Unit -> unit
 141 instance Trans ValueCode CombPure where
 142   trans = CombPure
 143 type instance Output CombPure = ValueCode
 144
 145 instance CombPurable CombPure where
 146   (.)     = (:.)
 147   ($)     = (:$)
 148   -- Small optimizations, mainly to reduce dump sizes.
 149   Id .@ x = x
 150   (Const :@ x) .@ _y = x
 151   ((Flip :@ Const) :@ _x) .@ y = y
 152   --
 153   f .@ x  = f :@ x
 154   cons    = Cons
 155   const   = Const
 156   eq      = Eq
 157   flip    = Flip
 158   id      = Id
 159   unit    = Unit
 160   bool b  = CombPure (bool b)
 161   char c  = CombPure (char c)
 162   nil     = CombPure nil
 163   left    = CombPure left
 164   right   = CombPure right
 165   nothing = CombPure nothing
 166   just    = CombPure just
 167 instance CombPurable ValueCode where
 168   (.)      = ValueCode (.) (.)
 169   ($)      = ValueCode ($) ($)
 170   (.@) f x = ValueCode ((.@) (value f) (value x)) ((.@) (code f) (code x))
 171   bool b   = ValueCode (bool b) (bool b)
 172   char c   = ValueCode (char c) (char c)
 173   cons     = ValueCode cons cons
 174   const    = ValueCode const const
 175   eq x     = ValueCode (eq (value x)) (eq (code x))
 176   flip     = ValueCode flip flip
 177   id       = ValueCode id id
 178   nil      = ValueCode nil nil
 179   unit     = ValueCode unit unit
 180   left     = ValueCode left left
 181   right    = ValueCode right right
 182   nothing  = ValueCode nothing nothing
 183   just     = ValueCode just just
 184 instance CombPurable Value where
 185   (.)      = Value (Function..)
 186   ($)      = Value (Function.$)
 187   (.@) f x = Value (unValue f (unValue x))
 188   bool     = Value
 189   char     = Value
 190   cons     = Value (:)
 191   const    = Value Function.const
 192   eq x     = Value (unValue x Eq.==)
 193   flip     = Value Function.flip
 194   id       = Value Function.id
 195   nil      = Value []
 196   unit     = Value ()
 197   left     = Value Left
 198   right    = Value Right
 199   nothing  = Value Nothing
 200   just     = Value Just
 201 instance CombPurable TH.CodeQ where
 202   (.)      = [|| (Function..) ||]
 203   ($)      = [|| (Function.$) ||]
 204   (.@) f x = [|| $$f $$x ||]
 205   bool b   = [|| b ||]
 206   char c   = [|| c ||]
 207   cons     = [|| (:) ||]
 208   const    = [|| Function.const ||]
 209   eq x     = [|| ($$x Eq.==) ||]
 210   flip     = [|| \f x y -> f y x ||]
 211   id       = [|| \x -> x ||]
 212   nil      = [|| [] ||]
 213   unit     = [|| () ||]
 214   left     = [|| Left ||]
 215   right    = [|| Right ||]
 216   nothing  = [|| Nothing ||]
 217   just     = [|| Just ||]