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.String (String)
  24 import Data.Text (Text)
  25 import Data.Tuple (swap)
  26 import Data.Type.Equality ((:~:)(..))
  27 import Prelude (Enum(..), error, max)
  28 import Text.Show (Show(..))
  29 import qualified Data.Char as Char
  30 import qualified Data.Map.Strict as Map
  31 import qualified Data.Text as Text
  32
  33 -- * Type 'Zero'
  34 data Zero
  35 -- * Type 'Succ'
  36 data Succ p
  37 -- * Type 'Index'
  38 type family Index xs x where
  39         Index (x     ': xs) x = Zero
  40         Index (not_x ': xs) x = Succ (Index xs x)
  41
  42 -- * Type 'Localization'
  43 data Localization l10n
  44  = forall l. l10n l =>
  45  Localization (FullLocale l)
  46
  47 -- ** Class 'Loqualize'
  48 -- | Build a 'Localization' containing the @l10n@ type class dictionnary
  49 -- corresponding to the given 'LocaleIn'
  50 -- (indexing a 'Locale' within the list of locales @ls@).
  51 class Loqualize ls l10n where
  52         localization :: LocaleIn ls -> Localization l10n
  53 instance l10n l => Loqualize '[l] l10n where
  54         localization (LocaleIn li) =
  55                 case li of
  56                  LocaleZ l -> Localization l
  57                  LocaleS{} -> error "localize: impossible locale"
  58 instance ( l10n l
  59          , Loqualize (l1 ': ls) l10n
  60          ) => Loqualize (l ': l1 ': ls) l10n where
  61         localization (LocaleIn (LocaleZ l)) = Localization l
  62         localization (LocaleIn (LocaleS l)) = localization (LocaleIn l)
  63
  64 -- * Type 'Locale'
  65 data Locale (ls::[*]) (l:: *) where
  66         LocaleZ :: FullLocale l -> Locale (l ': ls) l
  67         LocaleS :: Locale ls l -> Locale (not_l ': ls) l
  68 infixr 5 `LocaleS`
  69
  70 instance ( Show (FullLocale l)
  71          , Show (Locale ls l)
  72          ) => Show (Locale (l ': ls) l) where
  73         show (LocaleZ fl) = showFullLocale fl
  74         show (LocaleS l)  = show l
  75
  76 showFullLocale :: Show (FullLocale l) => FullLocale l -> String
  77 showFullLocale fl =
  78         case show fl of
  79          s0:s1:s@('_':_) -> Char.toLower s0:Char.toLower s1:s
  80          s -> s
  81
  82 eqLocale ::
  83  Eq (FullLocale x) =>
  84  Eq (FullLocale y) =>
  85  Locale ls x ->
  86  Locale ls y ->
  87  Maybe (x:~:y)
  88 eqLocale (LocaleZ x) (LocaleZ y) =
  89         if x == y then Just Refl else Nothing
  90 eqLocale (LocaleS x) (LocaleS y) = eqLocale x y
  91 eqLocale _x _y = Nothing
  92
  93 compareLocale ::
  94  Ord (FullLocale x) =>
  95  Ord (FullLocale y) =>
  96  Locale ls x ->
  97  Locale ls y ->
  98  Ordering
  99 compareLocale (LocaleZ x) (LocaleZ y) = compare x y
 100 compareLocale (LocaleS x) (LocaleS y) = compareLocale x y
 101 compareLocale LocaleZ{} LocaleS{} = LT
 102 compareLocale LocaleS{} LocaleZ{} = GT
 103
 104 -- ** Type 'FullLocale'
 105 data family FullLocale (l:: *) :: *
 106
 107 -- ** Type 'LocaleIn'
 108 data LocaleIn ls =
 109  forall l.
 110  ( Eq  (FullLocale l)
 111  , Ord (FullLocale l)
 112  ) => LocaleIn (Locale ls l)
 113
 114 instance Eq (LocaleIn ls) where
 115         LocaleIn x == LocaleIn y = isJust (eqLocale x y)
 116 instance Ord (LocaleIn ls) where
 117         compare (LocaleIn x) (LocaleIn y) = compareLocale x y
 118 instance Locales ls => Show (LocaleIn ls) where
 119         show = Text.unpack . (textLocales @ls Map.!)
 120
 121 -- ** Class 'LocaleInj'
 122 type LocaleInj ls l
 123  =   LocaleInjP (Index ls l) ls l
 124 localeInj :: forall l ls. LocaleInj ls l => FullLocale l -> Locale ls l
 125 localeInj = localeInjP @(Index ls l)
 126
 127 -- *** Class 'LocaleInjP'
 128 class LocaleInjP p ls l where
 129         localeInjP :: FullLocale l -> Locale ls l
 130 instance LocaleInjP Zero (l ': ls) l where
 131         localeInjP = LocaleZ
 132 instance LocaleInjP p ls l =>
 133          LocaleInjP (Succ p) (not_t ': ls) l where
 134         localeInjP = LocaleS . localeInjP @p
 135
 136 -- * Class 'Localize'
 137 class Localize ls msg a where
 138         localize :: LocaleIn ls -> a -> msg
 139 instance LocalizeIn l msg a => Localize '[l] msg a where
 140         localize (LocaleIn li) =
 141                 case li of
 142                  LocaleZ l -> localizeIn @l l
 143                  LocaleS{} -> error "localize: impossible locale"
 144 instance ( LocalizeIn l msg a
 145          , Localize (l1 ': ls) msg a
 146          ) => Localize (l ': l1 ': ls) msg a where
 147         localize (LocaleIn (LocaleZ l)) = localizeIn @l l
 148         localize (LocaleIn (LocaleS l)) = localize (LocaleIn l)
 149
 150 -- ** Class 'LocalizeIn'
 151 class LocalizeIn l msg a where
 152         localizeIn :: FullLocale l -> a -> msg
 153
 154 -- * Class 'Locales'
 155 class Locales ls where
 156         locales :: Map Text (LocaleIn ls)
 157
 158 textLocales :: Locales ls => Map (LocaleIn ls) Text
 159 textLocales = Map.fromListWith max $ swap <$> Map.toList locales
 160
 161 countryCode :: forall ls. Locales ls => LocaleIn ls -> Text
 162 countryCode = Text.takeWhile Char.isAlphaNum . (textLocales @ls Map.!)
 163
 164 instance Locales '[] where
 165         locales = Map.empty
 166 instance (LocalesFor l, Locales ls, Ord (FullLocale l)) => Locales (l ': ls) where
 167         locales =
 168                 Map.unionWithKey
 169                  (\k _n _o -> error $ "locales: duplicate locale: "<>Text.unpack k)
 170                  (LocaleIn . localeInj <$> localesFor @l)
 171                  ((\(LocaleIn l) -> LocaleIn $ LocaleS l) <$> locales @ls)
 172
 173 -- ** Class 'LocalesFor'
 174 class LocalesFor l where
 175         localesFor :: Map Text (FullLocale l)
 176
 177 fullLocales :: Show (FullLocale l) => [FullLocale l] -> [(Text, FullLocale l)]
 178 fullLocales = ((\fl -> (Text.pack (showFullLocale fl), fl)) <$>)
 179
 180 fullLocale :: Locale ls l -> FullLocale l
 181 fullLocale (LocaleZ l) = l
 182 fullLocale (LocaleS l) = fullLocale l
 183
 184 -- * Type 'FR'
 185 data FR
 186 data instance FullLocale FR
 187  = FR_BE
 188  | FR_CA
 189  | FR_CH
 190  | FR_FR
 191  | FR_LU
 192  deriving (Enum,Eq,Ord,Show)
 193 instance LocalesFor FR where
 194         localesFor = Map.fromList $
 195                 ("fr", FR_FR) :
 196                 fullLocales [toEnum 0 ..]
 197 fr_FR :: LocaleInj ls FR => Locale ls FR
 198 fr_FR = localeInj FR_FR
 199
 200 -- * Type 'EN'
 201 data EN
 202 data instance FullLocale EN
 203  = EN_AG
 204  | EN_AU
 205  | EN_BW
 206  | EN_CA
 207  | EN_DK
 208  | EN_GB
 209  | EN_HK
 210  | EN_IE
 211  | EN_IL
 212  | EN_IN
 213  | EN_NG
 214  | EN_NZ
 215  | EN_PH
 216  | EN_SG
 217  | EN_US
 218  | EN_ZA
 219  | EN_ZM
 220  | EN_ZW
 221  deriving (Enum,Eq,Ord,Show)
 222 instance LocalesFor EN where
 223         localesFor = Map.fromList $
 224                 ("en", EN_US) :
 225                 fullLocales [toEnum 0 ..]
 226 en_US :: LocaleInj ls EN => Locale ls EN
 227 en_US = localeInj EN_US