Language/Symantic/Type/Tuple.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE GADTs #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE ScopedTypeVariables #-}
   6 {-# LANGUAGE TypeFamilies #-}
   7 module Language.Symantic.Type.Tuple where
   8
   9 import Data.Maybe (isJust)
  10 import Data.Type.Equality ((:~:)(Refl))
  11
  12 import Language.Symantic.Type.Common
  13
  14 -- * Type 'Type_Tuple2'
  15 -- | The (,) type.
  16 data Type_Tuple2 root h where
  17         Type_Tuple2 :: root h_a
  18                     -> root h_b
  19                     -> Type_Tuple2 root (h_a, h_b)
  20
  21 type instance Root_of_Type      (Type_Tuple2 root) = root
  22 type instance Error_of_Type ast (Type_Tuple2 root) = No_Error_Type
  23
  24 instance -- Eq_Type
  25  Eq_Type root =>
  26  Eq_Type (Type_Tuple2 root) where
  27         eq_type (Type_Tuple2 a1 b1) (Type_Tuple2 a2 b2)
  28          | Just Refl <- a1 `eq_type` a2
  29          , Just Refl <- b1 `eq_type` b2
  30          = Just Refl
  31         eq_type _ _ = Nothing
  32 instance -- Eq
  33  Eq_Type root =>
  34  Eq (Type_Tuple2 root h) where
  35         x == y = isJust $ eq_type x y
  36 instance -- String_from_Type
  37  String_from_Type root =>
  38  String_from_Type (Type_Tuple2 root) where
  39         string_from_type (Type_Tuple2 a b) =
  40                 "Tuple (" ++ string_from_type a ++
  41                  ", " ++ string_from_type b ++ ")"
  42 instance -- Show
  43  String_from_Type root =>
  44  Show (Type_Tuple2 root h) where
  45         show = string_from_type
  46
  47 -- | Convenient alias to include a 'Type_Tuple2' within a type.
  48 type_tuple2
  49  :: Type_Root_Lift Type_Tuple2 root
  50  => root h_a
  51  -> root h_b
  52  -> root (h_a, h_b)
  53 type_tuple2 a b = type_root_lift (Type_Tuple2 a b)