Language/Symantic/Type/Tuple.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE PatternSynonyms #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Language.Symantic.Type.Tuple where
   9
  10 import qualified Data.MonoTraversable as MT
  11 import Data.Proxy
  12 import Data.Type.Equality ((:~:)(Refl))
  13
  14 import Language.Symantic.Type.Root
  15 import Language.Symantic.Type.Type0
  16 import Language.Symantic.Type.Type1
  17 import Language.Symantic.Type.Type2
  18
  19 -- * Type 'Type_Tuple2'
  20 -- | The @(,)@ type.
  21 type Type_Tuple2 = Type_Type2 (Proxy (,))
  22
  23 pattern Type_Tuple2
  24  :: root a -> root b
  25  -> Type_Tuple2 root ((,) a b)
  26 pattern Type_Tuple2 a b
  27  = Type_Type2 Proxy a b
  28
  29 instance Unlift_Type1 Type_Tuple2 where
  30         unlift_type1 (Type_Type2 px a b) k =
  31                 k ( Type_Type1 (Proxy::Proxy ((,) a)) b
  32                   , Lift_Type1 (\(Type_Type1 _ b') -> Type_Type2 px a b')
  33                   )
  34 instance
  35  Constraint_Type Eq root =>
  36  Constraint_Type Eq (Type_Tuple2 root) where
  37         constraint_type c (Type_Type2 _ a b)
  38          | Just Dict <- constraint_type c a
  39          , Just Dict <- constraint_type c b
  40          = Just Dict
  41         constraint_type _c _ = Nothing
  42 instance
  43  Constraint_Type Ord root =>
  44  Constraint_Type Ord (Type_Tuple2 root) where
  45         constraint_type c (Type_Type2 _ a b)
  46          | Just Dict <- constraint_type c a
  47          , Just Dict <- constraint_type c b
  48          = Just Dict
  49         constraint_type _c _ = Nothing
  50 instance
  51  Constraint_Type Monoid root =>
  52  Constraint_Type Monoid (Type_Tuple2 root) where
  53         constraint_type c (Type_Type2 _ a b)
  54          | Just Dict <- constraint_type c a
  55          , Just Dict <- constraint_type c b
  56          = Just Dict
  57         constraint_type _c _ = Nothing
  58 instance Constraint_Type Num (Type_Tuple2 root)
  59 instance Constraint_Type Integral (Type_Tuple2 root)
  60 instance Constraint_Type MT.MonoFunctor (Type_Tuple2 root) where
  61         constraint_type _c Type_Type2{} = Just Dict
  62 instance Constraint_Type1 Functor (Type_Tuple2 root) where
  63         constraint_type1 _c Type_Type2{} = Just Dict
  64 instance
  65  Constraint_Type Monoid root =>
  66  Constraint_Type1 Applicative (Type_Tuple2 root) where
  67         constraint_type1 _c (Type_Type2 _ a _b)
  68          | Just Dict <- constraint_type (Proxy::Proxy Monoid) a
  69          = Just Dict
  70         constraint_type1 _c _ = Nothing
  71 instance Constraint_Type1 Foldable (Type_Tuple2 root) where
  72         constraint_type1 _c Type_Type2{} = Just Dict
  73 instance Constraint_Type1 Traversable (Type_Tuple2 root) where
  74         constraint_type1 _c Type_Type2{} = Just Dict
  75 instance -- Eq_Type
  76  Eq_Type root =>
  77  Eq_Type (Type_Tuple2 root) where
  78         eq_type (Type_Type2 _px1 a1 b1) (Type_Type2 _px2 a2 b2)
  79          | Just Refl <- a1 `eq_type` a2
  80          , Just Refl <- b1 `eq_type` b2
  81          = Just Refl
  82         eq_type _ _ = Nothing
  83 instance -- Eq_Type1
  84  Eq_Type root =>
  85  Eq_Type1 (Type_Tuple2 root) where
  86         eq_type1 (Type_Type2 _px1 a1 _b1) (Type_Type2 _px2 a2 _b2)
  87          | Just Refl <- a1 `eq_type` a2
  88          = Just Refl
  89         eq_type1 _ _ = Nothing
  90 instance -- String_from_Type
  91  String_from_Type root =>
  92  String_from_Type (Type_Tuple2 root) where
  93         string_from_type (Type_Type2 _ a b) =
  94                 "("  ++ string_from_type a ++
  95                 ", " ++ string_from_type b ++ ")"
  96
  97 -- | Inject 'Type_Tuple2' within a root type.
  98 type_tuple2
  99  :: forall root h_a h_b.
 100  Lift_Type_Root Type_Tuple2 root
 101  => root h_a
 102  -> root h_b
 103  -> root (h_a, h_b)
 104 type_tuple2 = type_type2