Language/Symantic/Type/Map.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE MultiParamTypeClasses #-}
   5 {-# LANGUAGE OverloadedStrings #-}
   6 {-# LANGUAGE PatternSynonyms #-}
   7 {-# LANGUAGE ScopedTypeVariables #-}
   8 {-# LANGUAGE TypeFamilies #-}
   9 {-# OPTIONS_GHC -fno-warn-orphans #-}
  10 module Language.Symantic.Type.Map where
  11
  12 import Data.Proxy
  13 import Data.Map.Strict as Map
  14
  15 import Language.Symantic.Type.Root
  16 import Language.Symantic.Type.Type0
  17 import Language.Symantic.Type.Type2
  18
  19 -- * Type 'Type_Map'
  20 -- | The 'Map' type.
  21 type Type_Map = Type_Type2 (Proxy Map)
  22
  23 type instance Constraint2_of (Proxy Map)
  24  = Constraint2_Map
  25
  26 {- FIXME: Could not deduce (Ord k) arising from a pattern…
  27 pattern Type_Map
  28  :: Ord k => root k -> root a
  29  -> Type_Type2 (Proxy Map) root (Map k a)
  30 pattern Type_Map k a
  31  = Type_Type2 Proxy k a
  32 -}
  33
  34 -- ** Class 'Constraint2_Map'
  35 class Constraint2_Map k a
  36 instance Ord k => Constraint2_Map k a
  37
  38 instance -- String_from_Type
  39  String_from_Type root =>
  40  String_from_Type (Type_Map root) where
  41         string_from_type (Type_Type2 _ k a) =
  42                 "Map (" ++ string_from_type k ++ ")"
  43                  ++ " (" ++ string_from_type a ++ ")"
  44
  45 -- | Inject 'Type_Map' within a root type.
  46 type_map
  47  :: forall root h_k h_a.
  48  (Lift_Type_Root Type_Map root, Ord h_k)
  49  => root h_k -> root h_a
  50  -> root (Map h_k h_a)
  51 type_map k a = lift_type_root (Type_Type2 Proxy k a
  52          ::Type_Map root (Map h_k h_a))