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 class Localize ls msg a where
 116         localize :: LocaleIn ls -> a -> msg
 117 instance LocalizeIn l msg a => Localize '[l] msg a where
 118         localize (LocaleIn li) =
 119                 case li of
 120                  LocaleZ l -> localizeIn @l l
 121                  LocaleS{} -> error "localize: impossible locale"
 122 instance ( LocalizeIn l msg a
 123          , Localize (l1 ': ls) msg a
 124          ) => Localize (l ': l1 ': ls) msg a where
 125         localize (LocaleIn (LocaleZ l)) = localizeIn @l l
 126         localize (LocaleIn (LocaleS l)) = localize (LocaleIn l)
 127
 128 -- ** Class 'LocalizeIn'
 129 class LocalizeIn l msg a where
 130         localizeIn :: FullLocale l -> a -> msg
 131
 132 -- * Class 'Locales'
 133 class Locales ls where
 134         locales :: Map Text (LocaleIn ls)
 135
 136 textLocales :: Locales ls => Map (LocaleIn ls) Text
 137 textLocales = Map.fromListWith max $ swap <$> Map.toList locales
 138
 139 countryCode :: forall ls. Locales ls => LocaleIn ls -> Text
 140 countryCode = Text.takeWhile Char.isAlphaNum . (textLocales @ls Map.!)
 141
 142 instance Locales '[] where
 143         locales = Map.empty
 144 instance (LocalesFor l, Locales ls, Ord (FullLocale l)) => Locales (l ': ls) where
 145         locales =
 146                 Map.unionWithKey
 147                  (\k _n _o -> error $ "locales: duplicate locale: "<>Text.unpack k)
 148                  (LocaleIn . localeInj <$> localesFor @l)
 149                  ((\(LocaleIn l) -> LocaleIn $ LocaleS l) <$> locales @ls)
 150
 151 -- ** Class 'LocalesFor'
 152 class LocalesFor l where
 153         localesFor :: Map Text (FullLocale l)
 154
 155 fullLocales :: Show (FullLocale l) => [FullLocale l] -> [(Text, FullLocale l)]
 156 fullLocales = ((\fl -> (Text.pack (showFullLocale fl), fl)) <$>)
 157
 158 -- * Type 'FR'
 159 data FR
 160 data instance FullLocale FR
 161  = FR_BE
 162  | FR_CA
 163  | FR_CH
 164  | FR_FR
 165  | FR_LU
 166  deriving (Enum,Eq,Ord,Show)
 167 instance LocalesFor FR where
 168         localesFor = Map.fromList $
 169                 ("fr", FR_FR) :
 170                 fullLocales [toEnum 0 ..]
 171 fr_FR :: LocaleInj ls FR => Locale ls FR
 172 fr_FR = localeInj FR_FR
 173
 174 -- * Type 'EN'
 175 data EN
 176 data instance FullLocale EN
 177  = EN_AG
 178  | EN_AU
 179  | EN_BW
 180  | EN_CA
 181  | EN_DK
 182  | EN_GB
 183  | EN_HK
 184  | EN_IE
 185  | EN_IL
 186  | EN_IN
 187  | EN_NG
 188  | EN_NZ
 189  | EN_PH
 190  | EN_SG
 191  | EN_US
 192  | EN_ZA
 193  | EN_ZM
 194  | EN_ZW
 195  deriving (Enum,Eq,Ord,Show)
 196 instance LocalesFor EN where
 197         localesFor = Map.fromList $
 198                 ("en", EN_US) :
 199                 fullLocales [toEnum 0 ..]
 200 en_US :: LocaleInj ls EN => Locale ls EN
 201 en_US = localeInj EN_US