Data/Locale.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE ConstraintKinds #-}
   3 {-# LANGUAGE DataKinds #-}
   4 {-# LANGUAGE ExistentialQuantification #-}
   5 {-# LANGUAGE FlexibleContexts #-}
   6 {-# LANGUAGE FlexibleInstances #-}
   7 {-# LANGUAGE GADTs #-}
   8 {-# LANGUAGE MultiParamTypeClasses #-}
   9 {-# LANGUAGE OverloadedStrings #-}
  10 {-# LANGUAGE ScopedTypeVariables #-}
  11 {-# LANGUAGE TypeApplications #-}
  12 {-# LANGUAGE TypeFamilies #-}
  13 {-# LANGUAGE TypeOperators #-}
  14 module Data.Locale where
  15
  16 import Data.Eq (Eq(..))
  17 import Data.Function (($), (.))
  18 import Data.Functor ((<$>))
  19 import Data.Map.Strict (Map)
  20 import Data.Maybe (Maybe(..), isJust)
  21 import Data.Ord (Ord(..), Ordering(..))
  22 import Data.Semigroup (Semigroup(..))
  23 import Data.Text (Text)
  24 import Data.Tuple (swap)
  25 import Data.Type.Equality ((:~:)(..))
  26 import Prelude (error, max)
  27 import Text.Show (Show(..))
  28 import qualified Data.Char as Char
  29 import qualified Data.Map.Strict as Map
  30 import qualified Data.Text as Text
  31
  32 -- * Type 'Zero'
  33 data Zero
  34 -- * Type 'Succ'
  35 data Succ p
  36 -- * Type 'Index'
  37 type family Index xs x where
  38         Index (x     ': xs) x = Zero
  39         Index (not_x ': xs) x = Succ (Index xs x)
  40
  41 -- * Type 'Locale'
  42 data Locale (ls::[*]) (l:: *) where
  43         LocaleZ :: FullLocale l -> Locale (l ': ls) l
  44         LocaleS :: Locale ls l -> Locale (not_l ': ls) l
  45 infixr 5 `LocaleS`
  46
  47 instance ( Show (FullLocale l)
  48          , Show (Locale ls l)
  49          ) => Show (Locale (l ': ls) l) where
  50         show (LocaleZ fl) =
  51                 case show fl of
  52                  s0:s1:s@('_':_) -> Char.toLower s0:Char.toLower s1:s
  53                  s -> s
  54         show (LocaleS l)  = show l
  55
  56 eqLocale ::
  57  Eq (FullLocale x) =>
  58  Eq (FullLocale y) =>
  59  Locale ls x ->
  60  Locale ls y ->
  61  Maybe (x:~:y)
  62 eqLocale (LocaleZ x) (LocaleZ y) =
  63         if x == y then Just Refl else Nothing
  64 eqLocale (LocaleS x) (LocaleS y) = eqLocale x y
  65 eqLocale _x _y = Nothing
  66
  67 compareLocale ::
  68  Ord (FullLocale x) =>
  69  Ord (FullLocale y) =>
  70  Locale ls x ->
  71  Locale ls y ->
  72  Ordering
  73 compareLocale (LocaleZ x) (LocaleZ y) = compare x y
  74 compareLocale (LocaleS x) (LocaleS y) = compareLocale x y
  75 compareLocale LocaleZ{} LocaleS{} = LT
  76 compareLocale LocaleS{} LocaleZ{} = GT
  77
  78 -- ** Type 'FullLocale'
  79 data family FullLocale (l:: *) :: *
  80
  81 -- ** Type 'LocaleIn'
  82 data LocaleIn ls =
  83  forall l.
  84  ( Eq  (FullLocale l)
  85  , Ord (FullLocale l)
  86  ) => LocaleIn (Locale ls l)
  87
  88 instance Eq (LocaleIn ls) where
  89         LocaleIn x == LocaleIn y = isJust (eqLocale x y)
  90 instance Ord (LocaleIn ls) where
  91         compare (LocaleIn x) (LocaleIn y) = compareLocale x y
  92 instance Locales ls => Show (LocaleIn ls) where
  93         show = Text.unpack . (textLocales @ls Map.!)
  94
  95 -- ** Class 'LocaleInj'
  96 type LocaleInj ls l
  97  =   LocaleInjP (Index ls l) ls l
  98 localeInj :: forall l ls. LocaleInj ls l => FullLocale l -> Locale ls l
  99 localeInj = localeInjP @(Index ls l)
 100
 101 -- *** Class 'LocaleInjP'
 102 class LocaleInjP p ls l where
 103         localeInjP :: FullLocale l -> Locale ls l
 104 instance LocaleInjP Zero (l ': ls) l where
 105         localeInjP = LocaleZ
 106 instance LocaleInjP p ls l =>
 107          LocaleInjP (Succ p) (not_t ': ls) l where
 108         localeInjP = LocaleS . localeInjP @p
 109
 110 -- * Class 'Localize'
 111 class Localize ls msg a where
 112         localize :: LocaleIn ls -> a -> msg
 113 instance LocalizeIn l msg a => Localize '[l] msg a where
 114         localize (LocaleIn li) =
 115                 case li of
 116                  LocaleZ l -> localizeIn @l l
 117                  LocaleS{} -> error "localize: impossible locale"
 118 instance ( LocalizeIn l msg a
 119          , Localize (l1 ': ls) msg a
 120          ) => Localize (l ': l1 ': ls) msg a where
 121         localize (LocaleIn (LocaleZ l)) = localizeIn @l l
 122         localize (LocaleIn (LocaleS l)) = localize (LocaleIn l)
 123
 124 -- ** Class 'LocalizeIn'
 125 class LocalizeIn l msg a where
 126         localizeIn :: FullLocale l -> a -> msg
 127
 128 -- * Class 'Locales'
 129 class Locales ls where
 130         locales :: Map Text (LocaleIn ls)
 131
 132 textLocales :: Locales ls => Map (LocaleIn ls) Text
 133 textLocales = Map.fromListWith max $ swap <$> Map.toList locales
 134
 135 instance Locales '[] where
 136         locales = Map.empty
 137 instance (LocalesFor l, Locales ls, Ord (FullLocale l)) => Locales (l ': ls) where
 138         locales =
 139                 Map.unionWithKey
 140                  (\k _n _o -> error $ "locales: duplicate locale: "<>Text.unpack k)
 141                  (LocaleIn . localeInj <$> localesFor @l)
 142                  ((\(LocaleIn l) -> LocaleIn $ LocaleS l) <$> locales @ls)
 143
 144 -- ** Class 'LocalesFor'
 145 class LocalesFor l where
 146         localesFor :: Map Text (FullLocale l)
 147
 148 -- * Type 'FR'
 149 data FR
 150 data instance FullLocale FR
 151  = FR_BE
 152  | FR_CA
 153  | FR_CH
 154  | FR_FR
 155  | FR_LU
 156  deriving (Eq,Ord,Show)
 157 instance LocalesFor FR where
 158         localesFor = Map.fromList
 159          [ ("fr"   , FR_FR)
 160          , ("fr_BE", FR_BE)
 161          , ("fr_CA", FR_CA)
 162          , ("fr_CH", FR_CH)
 163          , ("fr_FR", FR_FR)
 164          , ("fr_LU", FR_LU)
 165          ]
 166 fr_FR :: LocaleInj ls FR => Locale ls FR
 167 fr_FR = localeInj FR_FR
 168
 169 -- * Type 'EN'
 170 data EN
 171 data instance FullLocale EN
 172  = EN_AG
 173  | EN_AU
 174  | EN_BW
 175  | EN_CA
 176  | EN_DK
 177  | EN_GB
 178  | EN_HK
 179  | EN_IE
 180  | EN_IL
 181  | EN_IN
 182  | EN_NG
 183  | EN_NZ
 184  | EN_PH
 185  | EN_SG
 186  | EN_US
 187  | EN_ZA
 188  | EN_ZM
 189  | EN_ZW
 190  deriving (Eq,Ord,Show)
 191 instance LocalesFor EN where
 192         localesFor = Map.fromList
 193          [ ("en"   , EN_US)
 194          , ("en_AG", EN_AG)
 195          , ("en_AU", EN_AU)
 196          , ("en_BW", EN_BW)
 197          , ("en_CA", EN_CA)
 198          , ("en_DK", EN_DK)
 199          , ("en_GB", EN_GB)
 200          , ("en_HK", EN_HK)
 201          , ("en_IE", EN_IE)
 202          , ("en_IL", EN_IL)
 203          , ("en_IN", EN_IN)
 204          , ("en_NG", EN_NG)
 205          , ("en_NZ", EN_NZ)
 206          , ("en_PH", EN_PH)
 207          , ("en_SG", EN_SG)
 208          , ("en_US", EN_US)
 209          , ("en_ZA", EN_ZA)
 210          , ("en_ZM", EN_ZM)
 211          , ("en_ZW", EN_ZW)
 212          ]
 213 en_US :: LocaleInj ls EN => Locale ls EN
 214 en_US = localeInj EN_US