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.Char (Char)
   9 import Data.Either (Either(..))
  10 import Data.Eq (Eq)
  11 import Data.Maybe (Maybe(..))
  12 import Data.Functor.Identity (Identity(..))
  13 import Prelude (undefined)
  14 import Text.Show (Show(..))
  15 import qualified Data.Eq as Eq
  16 import qualified Data.Function as Fun
  17 import qualified Language.Haskell.TH as TH
  18 import qualified Language.Haskell.TH.Syntax as TH
  19
  20 import Symantic.Univariant.Trans
  21 {-
  22 class Abstractable repr where
  23   -- | Application, aka. unabstract.
  24   (.@) :: repr (a->b) -> repr a -> repr b; infixl 9 .@
  25   -- | Lambda term abstraction, in HOAS (Higher-Order Abstract Syntax) style.
  26   lam :: (repr a -> repr b) -> repr (a->b)
  27   -- | Like 'lam' but whose argument is used only once,
  28   -- hence safe to beta-reduce (inline) without duplicating work.
  29   lam1 :: (repr a -> repr b) -> repr (a->b)
  30   const :: repr (a -> b -> a)
  31   flip :: repr ((a -> b -> c) -> b -> a -> c)
  32   id :: repr (a->a)
  33   (.) :: repr ((b->c) -> (a->b) -> a -> c); infixr 9 .
  34   ($) :: repr ((a->b) -> a -> b); infixr 0 $
  35   default (.@) ::
  36     Liftable2 repr => Abstractable (Output repr) =>
  37     repr (a->b) -> repr a -> repr b
  38   default lam ::
  39     Liftable repr => Unliftable repr => Abstractable (Output repr) =>
  40     (repr a -> repr b) -> repr (a->b)
  41   default lam1 ::
  42     Liftable repr => Unliftable repr => Abstractable (Output repr) =>
  43     (repr a -> repr b) -> repr (a->b)
  44   default const ::
  45     Liftable repr => Abstractable (Output repr) =>
  46     repr (a -> b -> a)
  47   default flip ::
  48     Liftable repr => Abstractable (Output repr) =>
  49     repr ((a -> b -> c) -> b -> a -> c)
  50   default id ::
  51     Liftable repr => Abstractable (Output repr) =>
  52     repr (a->a)
  53   default (.) ::
  54     Liftable repr => Abstractable (Output repr) =>
  55     repr ((b->c) -> (a->b) -> a -> c)
  56   default ($) ::
  57     Liftable repr => Abstractable (Output repr) =>
  58     repr ((a->b) -> a -> b)
  59   (.@) = lift2 (.@)
  60   lam f = lift (lam (trans Fun.. f Fun.. trans))
  61   lam1 f = lift (lam1 (trans Fun.. f Fun.. trans))
  62   const = lift const
  63   flip = lift flip
  64   id = lift id
  65   (.) = lift (.)
  66   ($) = lift ($)
  67 class Boolable repr where
  68   bool :: Bool -> repr Bool
  69   default bool ::
  70     Liftable repr => Boolable (Output repr) =>
  71     Bool -> repr Bool
  72   bool = lift Fun.. bool
  73 class Charable repr where
  74   char :: Char -> repr Char
  75   default char ::
  76     Liftable repr => Charable (Output repr) =>
  77     Char -> repr Char
  78   char = lift Fun.. char
  79 class Eitherable repr where
  80   left :: repr (l -> Either l r)
  81   right :: repr (r -> Either l r)
  82   default left ::
  83     Liftable repr => Eitherable (Output repr) =>
  84     repr (l -> Either l r)
  85   default right ::
  86     Liftable repr => Eitherable (Output repr) =>
  87     repr (r -> Either l r)
  88   left = lift left
  89   right = lift right
  90 class Equalable repr where
  91   eq :: Eq a => repr (a -> a -> Bool)
  92   default eq ::
  93     Liftable repr => Equalable (Output repr) =>
  94     Eq a => repr (a -> a -> Bool)
  95   eq = lift eq
  96 class Listable repr where
  97   cons :: repr (a -> [a] -> [a])
  98   nil :: repr [a]
  99   default cons ::
 100     Liftable repr => Listable (Output repr) =>
 101     repr (a -> [a] -> [a])
 102   default nil ::
 103     Liftable repr => Listable (Output repr) =>
 104     repr [a]
 105   cons = lift cons
 106   nil = lift nil
 107 class Maybeable repr where
 108   nothing :: repr (Maybe a)
 109   just :: repr (a -> Maybe a)
 110   default nothing ::
 111     Liftable repr => Maybeable (Output repr) =>
 112     repr (Maybe a)
 113   default just ::
 114     Liftable repr => Maybeable (Output repr) =>
 115     repr (a -> Maybe a)
 116   nothing = lift nothing
 117   just = lift just
 118 class Unitable repr where
 119   unit :: repr ()
 120   default unit ::
 121     Liftable repr => Unitable (Output repr) =>
 122     repr ()
 123   unit = lift unit
 124
 125 -}