{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

-- | 'Syntactic' instances for tuples and 'Typed' symbol domains

module Language.Syntactic.Sugar.TupleTyped where



import Data.Typeable
import Language.Haskell.TH

#if __GLASGOW_HASKELL__ < 710
import Data.Orphans ()
#endif

import Language.Syntactic
import Language.Syntactic.TH
import Language.Syntactic.Functional.Tuple
import Language.Syntactic.Functional.Tuple.TH



instance
    ( Syntactic a
    , Syntactic b
    , Typeable (Internal a)
    , Typeable (Internal b)
    , Tuple :<: sym
    , Domain a ~ Typed sym
    , Domain a ~ Domain b
    ) =>
      Syntactic (a,b)
  where
    type Domain (a,b)   = Domain a
    type Internal (a,b) = (Internal a, Internal b)
    desugar :: (a, b) -> ASTF (Domain (a, b)) (Internal (a, b))
desugar (a
a,b
b) = Typed
  sym (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> AST
     (Typed sym)
     (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (sym (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> Typed
     sym (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
forall sig (sym :: * -> *).
Typeable (DenResult sig) =>
sym sig -> Typed sym sig
Typed (sym
   (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
 -> Typed
      sym
      (Internal a :-> (Internal b :-> Full (Internal a, Internal b))))
-> sym
     (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> Typed
     sym (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
forall a b. (a -> b) -> a -> b
$ Tuple
  (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> sym
     (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj Tuple
  (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
forall a a. Tuple (a :-> (a :-> Full (a, a)))
Pair) AST
  (Typed sym)
  (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> AST (Typed sym) (Full (Internal a))
-> AST (Typed sym) (Internal b :-> Full (Internal a, Internal b))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ a -> ASTF (Domain a) (Internal a)
forall a. Syntactic a => a -> ASTF (Domain a) (Internal a)
desugar a
a AST (Typed sym) (Internal b :-> Full (Internal a, Internal b))
-> AST (Typed sym) (Full (Internal b))
-> AST (Typed sym) (Full (Internal a, Internal b))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ b -> ASTF (Domain b) (Internal b)
forall a. Syntactic a => a -> ASTF (Domain a) (Internal a)
desugar b
b
    sugar :: ASTF (Domain (a, b)) (Internal (a, b)) -> (a, b)
sugar ASTF (Domain (a, b)) (Internal (a, b))
ab      = (ASTF (Domain a) (Internal a) -> a
forall a. Syntactic a => ASTF (Domain a) (Internal a) -> a
sugar (ASTF (Domain a) (Internal a) -> a)
-> ASTF (Domain a) (Internal a) -> a
forall a b. (a -> b) -> a -> b
$ Typed sym ((Internal a, Internal b) :-> Full (Internal a))
-> AST (Typed sym) ((Internal a, Internal b) :-> Full (Internal a))
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (sym ((Internal a, Internal b) :-> Full (Internal a))
-> Typed sym ((Internal a, Internal b) :-> Full (Internal a))
forall sig (sym :: * -> *).
Typeable (DenResult sig) =>
sym sig -> Typed sym sig
Typed (sym ((Internal a, Internal b) :-> Full (Internal a))
 -> Typed sym ((Internal a, Internal b) :-> Full (Internal a)))
-> sym ((Internal a, Internal b) :-> Full (Internal a))
-> Typed sym ((Internal a, Internal b) :-> Full (Internal a))
forall a b. (a -> b) -> a -> b
$ Tuple ((Internal a, Internal b) :-> Full (Internal a))
-> sym ((Internal a, Internal b) :-> Full (Internal a))
forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj Tuple ((Internal a, Internal b) :-> Full (Internal a))
forall a a. Tuple ((a, a) :-> Full a)
Fst) AST (Typed sym) ((Internal a, Internal b) :-> Full (Internal a))
-> AST (Typed sym) (Full (Internal a, Internal b))
-> AST (Typed sym) (Full (Internal a))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST (Typed sym) (Full (Internal a, Internal b))
ASTF (Domain (a, b)) (Internal (a, b))
ab, ASTF (Domain b) (Internal b) -> b
forall a. Syntactic a => ASTF (Domain a) (Internal a) -> a
sugar (ASTF (Domain b) (Internal b) -> b)
-> ASTF (Domain b) (Internal b) -> b
forall a b. (a -> b) -> a -> b
$ Typed sym ((Internal a, Internal b) :-> Full (Internal b))
-> AST (Typed sym) ((Internal a, Internal b) :-> Full (Internal b))
forall (sym :: * -> *) sig. sym sig -> AST sym sig
Sym (sym ((Internal a, Internal b) :-> Full (Internal b))
-> Typed sym ((Internal a, Internal b) :-> Full (Internal b))
forall sig (sym :: * -> *).
Typeable (DenResult sig) =>
sym sig -> Typed sym sig
Typed (sym ((Internal a, Internal b) :-> Full (Internal b))
 -> Typed sym ((Internal a, Internal b) :-> Full (Internal b)))
-> sym ((Internal a, Internal b) :-> Full (Internal b))
-> Typed sym ((Internal a, Internal b) :-> Full (Internal b))
forall a b. (a -> b) -> a -> b
$ Tuple ((Internal a, Internal b) :-> Full (Internal b))
-> sym ((Internal a, Internal b) :-> Full (Internal b))
forall (sub :: * -> *) (sup :: * -> *) a.
(sub :<: sup) =>
sub a -> sup a
inj Tuple ((Internal a, Internal b) :-> Full (Internal b))
forall a b. Tuple ((a, b) :-> Full b)
Snd) AST (Typed sym) ((Internal a, Internal b) :-> Full (Internal b))
-> AST (Typed sym) (Full (Internal a, Internal b))
-> AST (Typed sym) (Full (Internal b))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST (Typed sym) (Full (Internal a, Internal b))
ASTF (Domain (a, b)) (Internal (a, b))
ab)

-- `desugar` and `sugar` can be seen as applying the eta-rule for pairs.
-- <https://mail.haskell.org/pipermail/haskell-cafe/2016-April/123639.html>

deriveSyntacticForTuples
    (return . classPred ''Typeable ConT . return)
    (AppT (ConT ''Typed))
    []
#if __GLASGOW_HASKELL__ < 708
    7
#else
    15
#endif