src/Symantic/Parser/Haskell/Term.hs

   1 {-# LANGUAGE DefaultSignatures #-}
   2 {-# LANGUAGE TemplateHaskell #-}
   3 -- | Haskell terms which are interesting
   4 -- to pattern-match when optimizing.
   5 module Symantic.Parser.Haskell.Term 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.Functor.Identity (Identity(..))
  12 import Prelude (undefined)
  13 import Text.Show (Show(..))
  14 import qualified Data.Eq as Eq
  15 import qualified Data.Function as Fun
  16 import qualified Language.Haskell.TH as TH
  17 import qualified Language.Haskell.TH.Syntax as TH
  18
  19 import qualified Symantic.Univariant.Trans as Sym
  20
  21 -- * Class 'Termable'
  22 -- | Single-out some Haskell terms in order to
  23 class Termable repr where
  24   -- | Application, aka. unabstract.
  25   (.@) :: repr (a->b) -> repr a -> repr b
  26   -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
  27   lam :: (repr a -> repr b) -> repr (a->b)
  28   -- | Like 'lam' but whose argument is used only once,
  29   -- hence safe to beta-reduce (inline) without duplicating work.
  30   lam1 :: (repr a -> repr b) -> repr (a->b)
  31
  32   -- Singled-out terms
  33   bool :: Bool -> repr Bool
  34   char :: (TH.Lift tok, Show tok) => tok -> repr tok
  35   cons :: repr (a -> [a] -> [a])
  36   nil :: repr [a]
  37   eq :: Eq a => repr (a -> a -> Bool)
  38   unit :: repr ()
  39   left :: repr (l -> Either l r)
  40   right :: repr (r -> Either l r)
  41   nothing :: repr (Maybe a)
  42   just :: repr (a -> Maybe a)
  43   const :: repr (a -> b -> a)
  44   flip :: repr ((a -> b -> c) -> b -> a -> c)
  45   id :: repr (a->a)
  46   (.) :: repr ((b->c) -> (a->b) -> a -> c)
  47   ($) :: repr ((a->b) -> a -> b)
  48
  49   default (.@) ::
  50     Sym.Liftable2 repr => Termable (Sym.Output repr) =>
  51     repr (a->b) -> repr a -> repr b
  52   default lam ::
  53     Sym.Liftable repr => Sym.Unliftable repr => Termable (Sym.Output repr) =>
  54     (repr a -> repr b) -> repr (a->b)
  55   default lam1 ::
  56     Sym.Liftable repr => Sym.Unliftable repr => Termable (Sym.Output repr) =>
  57     (repr a -> repr b) -> repr (a->b)
  58   default bool ::
  59     Sym.Liftable repr => Termable (Sym.Output repr) =>
  60     Bool -> repr Bool
  61   default char ::
  62     Sym.Liftable repr => Termable (Sym.Output repr) =>
  63     TH.Lift tok => Show tok =>
  64     tok -> repr tok
  65   default cons ::
  66     Sym.Liftable repr => Termable (Sym.Output repr) =>
  67     repr (a -> [a] -> [a])
  68   default nil ::
  69     Sym.Liftable repr => Termable (Sym.Output repr) =>
  70     repr [a]
  71   default eq ::
  72     Sym.Liftable repr => Termable (Sym.Output repr) =>
  73     Eq a => repr (a -> a -> Bool)
  74   default unit ::
  75     Sym.Liftable repr => Termable (Sym.Output repr) =>
  76     repr ()
  77   default left ::
  78     Sym.Liftable repr => Termable (Sym.Output repr) =>
  79     repr (l -> Either l r)
  80   default right ::
  81     Sym.Liftable repr => Termable (Sym.Output repr) =>
  82     repr (r -> Either l r)
  83   default nothing ::
  84     Sym.Liftable repr => Termable (Sym.Output repr) =>
  85     repr (Maybe a)
  86   default just ::
  87     Sym.Liftable repr => Termable (Sym.Output repr) =>
  88     repr (a -> Maybe a)
  89   default const ::
  90     Sym.Liftable repr => Termable (Sym.Output repr) =>
  91     repr (a -> b -> a)
  92   default flip ::
  93     Sym.Liftable repr => Termable (Sym.Output repr) =>
  94     repr ((a -> b -> c) -> b -> a -> c)
  95   default id ::
  96     Sym.Liftable repr => Termable (Sym.Output repr) =>
  97     repr (a->a)
  98   default (.) ::
  99     Sym.Liftable repr => Termable (Sym.Output repr) =>
 100     repr ((b->c) -> (a->b) -> a -> c)
 101   default ($) ::
 102     Sym.Liftable repr => Termable (Sym.Output repr) =>
 103     repr ((a->b) -> a -> b)
 104
 105   (.@) = Sym.lift2 (.@)
 106   lam f = Sym.lift (lam (Sym.trans Fun.. f Fun.. Sym.trans))
 107   lam1 f = Sym.lift (lam1 (Sym.trans Fun.. f Fun.. Sym.trans))
 108   bool = Sym.lift Fun.. bool
 109   char = Sym.lift Fun.. char
 110   cons = Sym.lift cons
 111   nil = Sym.lift nil
 112   eq = Sym.lift eq
 113   unit = Sym.lift unit
 114   left = Sym.lift left
 115   right = Sym.lift right
 116   nothing = Sym.lift nothing
 117   just = Sym.lift just
 118   const = Sym.lift const
 119   flip = Sym.lift flip
 120   id = Sym.lift id
 121   (.) = Sym.lift (.)
 122   ($) = Sym.lift ($)
 123 infixr 0 $
 124 infixr 9 .
 125 infixl 9 .@
 126
 127 -- * Type 'ValueCode'
 128 data ValueCode a = ValueCode
 129   { value :: a
 130   , code :: TH.CodeQ a
 131   }
 132 instance Termable ValueCode where
 133   f .@ x = ValueCode
 134     { value = runIdentity (Identity (value f) .@ (Identity (value x)))
 135     , code = code f .@ code x
 136     }
 137   lam f = ValueCode
 138     { value = runIdentity (lam (Identity Fun.. value Fun.. f Fun.. (`ValueCode` undefined) Fun.. runIdentity))
 139     , code  = lam (code Fun.. f Fun.. ValueCode undefined)
 140     }
 141   lam1     = lam
 142   bool b   = ValueCode (runIdentity (bool b)) (bool b)
 143   char c   = ValueCode (runIdentity (char c)) (char c)
 144   cons     = ValueCode (runIdentity cons) cons
 145   nil      = ValueCode (runIdentity nil) nil
 146   eq       = ValueCode (runIdentity eq) eq
 147   unit     = ValueCode (runIdentity unit) unit
 148   left     = ValueCode (runIdentity left) left
 149   right    = ValueCode (runIdentity right) right
 150   nothing  = ValueCode (runIdentity nothing) nothing
 151   just     = ValueCode (runIdentity just) just
 152   const    = ValueCode (runIdentity const) const
 153   flip     = ValueCode (runIdentity flip) flip
 154   id       = ValueCode (runIdentity id) id
 155   ($)      = ValueCode (runIdentity ($)) ($)
 156   (.)      = ValueCode (runIdentity (.)) (.)
 157 instance Termable Identity where
 158   f .@ x   = Identity (runIdentity f (runIdentity x))
 159   lam f    = Identity (runIdentity Fun.. f Fun.. Identity)
 160   lam1     = lam
 161   bool     = Identity
 162   char     = Identity
 163   cons     = Identity (:)
 164   nil      = Identity []
 165   eq       = Identity (Eq.==)
 166   unit     = Identity ()
 167   left     = Identity Left
 168   right    = Identity Right
 169   nothing  = Identity Nothing
 170   just     = Identity Just
 171   const    = Identity Fun.const
 172   flip     = Identity Fun.flip
 173   id       = Identity Fun.id
 174   ($)      = Identity (Fun.$)
 175   (.)      = Identity (Fun..)
 176 instance Termable TH.CodeQ where
 177   (.@) f x = [|| $$f $$x ||]
 178   lam f    = [|| \x -> $$(f [||x||]) ||]
 179   lam1     = lam
 180   bool b   = [|| b ||]
 181   char c   = [|| c ||]
 182   cons     = [|| (:) ||]
 183   nil      = [|| [] ||]
 184   eq       = [|| (Eq.==) ||]
 185   unit     = [|| () ||]
 186   left     = [|| Left ||]
 187   right    = [|| Right ||]
 188   nothing  = [|| Nothing ||]
 189   just     = [|| Just ||]
 190   const    = [|| Fun.const ||]
 191   id       = [|| \x -> x ||]
 192   flip     = [|| \f x y -> f y x ||]
 193   ($)      = [|| (Fun.$) ||]
 194   (.)      = [|| (Fun..) ||]