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

-- | 'Syntactic' instances for tuples

module Language.Syntactic.Sugar.Tuple where



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



instance
    ( Syntactic a
    , Syntactic b
    , Tuple :<: Domain a
    , 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) = Tuple
  (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> AST
     (Domain b)
     (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
  (Domain b)
  (Internal a :-> (Internal b :-> Full (Internal a, Internal b)))
-> AST (Domain b) (Full (Internal a))
-> AST (Domain b) (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 (Domain b) (Internal b :-> Full (Internal a, Internal b))
-> AST (Domain b) (Full (Internal b))
-> AST (Domain b) (Full (Internal a, Internal b))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ b -> AST (Domain b) (Full (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
$ Tuple ((Internal a, Internal b) :-> Full (Internal a))
-> AST (Domain b) ((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 (Domain b) ((Internal a, Internal b) :-> Full (Internal a))
-> AST (Domain b) (Full (Internal a, Internal b))
-> AST (Domain b) (Full (Internal a))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST (Domain b) (Full (Internal a, Internal b))
ASTF (Domain (a, b)) (Internal (a, b))
ab, AST (Domain b) (Full (Internal b)) -> b
forall a. Syntactic a => ASTF (Domain a) (Internal a) -> a
sugar (AST (Domain b) (Full (Internal b)) -> b)
-> AST (Domain b) (Full (Internal b)) -> b
forall a b. (a -> b) -> a -> b
$ Tuple ((Internal a, Internal b) :-> Full (Internal b))
-> AST (Domain b) ((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 (Domain b) ((Internal a, Internal b) :-> Full (Internal b))
-> AST (Domain b) (Full (Internal a, Internal b))
-> AST (Domain b) (Full (Internal b))
forall (sym :: * -> *) a sig.
AST sym (a :-> sig) -> AST sym (Full a) -> AST sym sig
:$ AST (Domain b) (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 (const []) id [] 15