symantic-lib/Language/Symantic/Lib/Applicative.hs

   1 {-# LANGUAGE UndecidableInstances #-}
   2 {-# OPTIONS_GHC -fno-warn-orphans #-}
   3 -- | Symantic for 'Applicative'.
   4 module Language.Symantic.Lib.Applicative where
   5
   6 import Control.Applicative (Applicative)
   7 import Prelude hiding (Functor(..), (<$>), Applicative(..), id, const)
   8 import qualified Control.Applicative as Applicative
   9 import qualified Data.Function as Fun
  10
  11 import Language.Symantic
  12 import Language.Symantic.Lib.Function (a0, b1)
  13 import Language.Symantic.Lib.Functor (Sym_Functor(..), (<$>), f1, f2)
  14
  15 -- * Class 'Sym_Applicative'
  16 type instance Sym Applicative = Sym_Applicative
  17 class Sym_Functor term => Sym_Applicative term where
  18         pure  :: Applicative f => term a -> term (f a)
  19         (<*>) :: Applicative f => term (f (a -> b)) -> term (f a) -> term (f b); infixl 4 <*>
  20         (*>)  :: Applicative f => term (f a) -> term (f b) -> term (f b); infixl 4 *>
  21         (<*)  :: Applicative f => term (f a) -> term (f b) -> term (f a); infixl 4 <*
  22
  23         default pure  :: Sym_Applicative (UnT term) => Trans term => Applicative f => term a -> term (f a)
  24         default (<*>) :: Sym_Applicative (UnT term) => Trans term => Applicative f => term (f (a -> b)) -> term (f a) -> term (f b)
  25         default (*>)  :: Sym_Lambda term => Applicative f => term (f a) -> term (f b) -> term (f b)
  26         default (<*)  :: Sym_Lambda term => Applicative f => term (f a) -> term (f b) -> term (f a)
  27
  28         pure   = trans1 pure
  29         (<*>)  = trans2 (<*>)
  30         x *> y = lam1 Fun.id    <$  x <*> y
  31         x <* y = lam2 Fun.const <$> x <*> y
  32
  33 -- Interpreting
  34 instance Sym_Applicative Eval where
  35         pure  = eval1 Applicative.pure
  36         (<*>) = eval2 (Applicative.<*>)
  37 instance Sym_Applicative View where
  38         pure  = view1 "pure"
  39         (<*>) = viewInfix "<*>" (infixL 4)
  40         (<* ) = viewInfix "<*"  (infixL 4)
  41         ( *>) = viewInfix "*>"  (infixL 4)
  42 instance (Sym_Applicative r1, Sym_Applicative r2, Sym_Lambda r1, Sym_Lambda r2) => Sym_Applicative (Dup r1 r2) where
  43         pure  = dup1 @Sym_Applicative pure
  44         (<*>) = dup2 @Sym_Applicative (<*>)
  45
  46 -- Transforming
  47 instance (Sym_Lambda term, Sym_Applicative term) => Sym_Applicative (BetaT term) where
  48         (<*) = trans2 (<*)
  49         (*>) = trans2 (*>)
  50
  51 -- Typing
  52 instance FixityOf Applicative
  53 instance ClassInstancesFor Applicative
  54 instance TypeInstancesFor Applicative
  55
  56 -- Compiling
  57 instance Gram_Term_AtomsFor src ss g Applicative
  58 instance (Source src, SymInj ss Applicative) => ModuleFor src ss Applicative where
  59         moduleFor = ["Applicative"] `moduleWhere`
  60          [ "<*>" `withInfixL` 4 := teApplicative_app
  61          , "<*"  `withInfixL` 4 := teApplicative_const
  62          , "*>"  `withInfixL` 4 := teApplicative_tsnoc
  63          ]
  64
  65 -- ** 'Type's
  66 tyApplicative :: Source src => Type src vs a -> Type src vs (Applicative a)
  67 tyApplicative a = tyConstLen @(K Applicative) @Applicative (lenVars a) `tyApp` a
  68
  69 -- ** 'Term's
  70 teApplicative_pure :: TermDef Applicative '[Proxy a, Proxy f] (Applicative f #> (a -> f a))
  71 teApplicative_pure = Term (tyApplicative f1) (a0 ~> f1 `tyApp` a0) $ teSym @Applicative $ lam1 pure
  72
  73 teApplicative_app :: TermDef Applicative '[Proxy a, Proxy b, Proxy f] (Applicative f #> (f (a -> b) -> f a -> f b))
  74 teApplicative_app = Term (tyApplicative f2) (f2 `tyApp` (a0 ~> b1) ~> f2 `tyApp` a0 ~> f2 `tyApp` b1) $ teSym @Applicative $ lam2 (<*>)
  75
  76 teApplicative_const :: TermDef Applicative '[Proxy a, Proxy b1, Proxy f] (Applicative f #> (f a -> f b1 -> f a))
  77 teApplicative_const = Term (tyApplicative f2) (f2 `tyApp` a0 ~> f2 `tyApp` b1 ~> f2 `tyApp` a0) $ teSym @Applicative $ lam2 (<*)
  78
  79 teApplicative_tsnoc :: TermDef Applicative '[Proxy a, Proxy b, Proxy f] (Applicative f #> (f a -> f b -> f b))
  80 teApplicative_tsnoc = Term (tyApplicative f2) (f2 `tyApp` a0 ~> f2 `tyApp` b1 ~> f2 `tyApp` b1) $ teSym @Applicative $ lam2 (*>)