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