Language/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 Language.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 (LocaleZ l)) = localizeIn @l l
 115 instance ( LocalizeIn l msg a
 116          , Localize (l1 ': ls) msg a
 117          ) => Localize (l ': l1 ': ls) msg a where
 118         localize (LocaleIn (LocaleZ l)) = localizeIn @l l
 119         localize (LocaleIn (LocaleS l)) = localize (LocaleIn l)
 120
 121 -- ** Class 'LocalizeIn'
 122 class LocalizeIn l msg a where
 123         localizeIn :: FullLocale l -> a -> msg
 124
 125 -- * Class 'Locales'
 126 class Locales ls where
 127         locales :: Map Text (LocaleIn ls)
 128
 129 textLocales :: Locales ls => Map (LocaleIn ls) Text
 130 textLocales = Map.fromListWith max $ swap <$> Map.toList locales
 131
 132 instance Locales '[] where
 133         locales = Map.empty
 134 instance (LocalesFor l, Locales ls, Ord (FullLocale l)) => Locales (l ': ls) where
 135         locales =
 136                 Map.unionWithKey
 137                  (\k _n _o -> error $ "locales: duplicate locale: "<>Text.unpack k)
 138                  (LocaleIn . localeInj <$> localesFor @l)
 139                  ((\(LocaleIn l) -> LocaleIn $ LocaleS l) <$> locales @ls)
 140
 141 -- ** Class 'LocalesFor'
 142 class LocalesFor l where
 143         localesFor :: Map Text (FullLocale l)
 144
 145 -- * Type 'FR'
 146 data FR
 147 data instance FullLocale FR
 148  = FR_BE
 149  | FR_CA
 150  | FR_CH
 151  | FR_FR
 152  | FR_LU
 153  deriving (Eq,Ord,Show)
 154 instance LocalesFor FR where
 155         localesFor = Map.fromList
 156          [ ("fr"   , FR_FR)
 157          , ("fr_BE", FR_BE)
 158          , ("fr_CA", FR_CA)
 159          , ("fr_CH", FR_CH)
 160          , ("fr_FR", FR_FR)
 161          , ("fr_LU", FR_LU)
 162          ]
 163 fr_FR :: LocaleInj ls FR => Locale ls FR
 164 fr_FR = localeInj FR_FR
 165
 166 -- * Type 'EN'
 167 data EN
 168 data instance FullLocale EN
 169  = EN_AG
 170  | EN_AU
 171  | EN_BW
 172  | EN_CA
 173  | EN_DK
 174  | EN_GB
 175  | EN_HK
 176  | EN_IE
 177  | EN_IL
 178  | EN_IN
 179  | EN_NG
 180  | EN_NZ
 181  | EN_PH
 182  | EN_SG
 183  | EN_US
 184  | EN_ZA
 185  | EN_ZM
 186  | EN_ZW
 187  deriving (Eq,Ord,Show)
 188 instance LocalesFor EN where
 189         localesFor = Map.fromList
 190          [ ("en"   , EN_US)
 191          , ("en_AG", EN_AG)
 192          , ("en_AU", EN_AU)
 193          , ("en_BW", EN_BW)
 194          , ("en_CA", EN_CA)
 195          , ("en_DK", EN_DK)
 196          , ("en_GB", EN_GB)
 197          , ("en_HK", EN_HK)
 198          , ("en_IE", EN_IE)
 199          , ("en_IL", EN_IL)
 200          , ("en_IN", EN_IN)
 201          , ("en_NG", EN_NG)
 202          , ("en_NZ", EN_NZ)
 203          , ("en_PH", EN_PH)
 204          , ("en_SG", EN_SG)
 205          , ("en_US", EN_US)
 206          , ("en_ZA", EN_ZA)
 207          , ("en_ZM", EN_ZM)
 208          , ("en_ZW", EN_ZW)
 209          ]
 210 en_US :: LocaleInj ls EN => Locale ls EN
 211 en_US = localeInj EN_US