1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE ConstraintKinds #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE ExistentialQuantification #-}
5 {-# LANGUAGE FlexibleContexts #-}
6 {-# LANGUAGE FlexibleInstances #-}
8 {-# LANGUAGE MultiParamTypeClasses #-}
9 {-# LANGUAGE OverloadedStrings #-}
10 {-# LANGUAGE ScopedTypeVariables #-}
11 {-# LANGUAGE TypeApplications #-}
12 {-# LANGUAGE TypeFamilies #-}
13 {-# LANGUAGE TypeOperators #-}
14 module Data.Locale where
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
38 type family Index xs x where
39 Index (x ': xs) x = Zero
40 Index (not_x ': xs) x = Succ (Index xs x)
43 data Locale (ls::[*]) (l:: *) where
44 LocaleZ :: FullLocale l -> Locale (l ': ls) l
45 LocaleS :: Locale ls l -> Locale (not_l ': ls) l
48 instance ( Show (FullLocale l)
50 ) => Show (Locale (l ': ls) l) where
51 show (LocaleZ fl) = showFullLocale fl
52 show (LocaleS l) = show l
54 showFullLocale :: Show (FullLocale l) => FullLocale l -> String
57 s0:s1:s@('_':_) -> Char.toLower s0:Char.toLower s1:s
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
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
82 -- ** Type 'FullLocale'
83 data family FullLocale (l:: *) :: *
90 ) => LocaleIn (Locale ls l)
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.!)
99 -- ** Class 'LocaleInj'
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)
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
110 instance LocaleInjP p ls l =>
111 LocaleInjP (Succ p) (not_t ': ls) l where
112 localeInjP = LocaleS . localeInjP @p
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) =
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)
129 -- ** Class 'LocalizeIn'
130 class LocalizeIn l msg a where
131 localizeIn :: FullLocale l -> a -> msg
133 -- * Class 'Loqualize'
134 -- | Second method: localization using type qualification.
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) =
144 LocaleZ l -> Loqualization l
145 LocaleS{} -> error "loqualize: impossible locale"
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)
152 -- ** Type 'Loqualization'
155 Loqualization (FullLocale l)
158 class Locales ls where
159 locales :: Map Text (LocaleIn ls)
161 textLocales :: Locales ls => Map (LocaleIn ls) Text
162 textLocales = Map.fromListWith max $ swap <$> Map.toList locales
164 countryCode :: forall ls. Locales ls => LocaleIn ls -> Text
165 countryCode = Text.takeWhile Char.isAlphaNum . (textLocales @ls Map.!)
167 instance Locales '[] where
169 instance (LocalesFor l, Locales ls, Ord (FullLocale l)) => Locales (l ': ls) where
172 (\k _n _o -> error $ "locales: duplicate locale: "<>Text.unpack k)
173 (LocaleIn . localeInj <$> localesFor @l)
174 ((\(LocaleIn l) -> LocaleIn $ LocaleS l) <$> locales @ls)
176 -- ** Class 'LocalesFor'
177 class LocalesFor l where
178 localesFor :: Map Text (FullLocale l)
180 fullLocales :: Show (FullLocale l) => [FullLocale l] -> [(Text, FullLocale l)]
181 fullLocales = ((\fl -> (Text.pack (showFullLocale fl), fl)) <$>)
183 fullLocale :: Locale ls l -> FullLocale l
184 fullLocale (LocaleZ l) = l
185 fullLocale (LocaleS l) = fullLocale l
189 data instance FullLocale FR
195 deriving (Enum,Eq,Ord,Show)
196 instance LocalesFor FR where
197 localesFor = Map.fromList $
199 fullLocales [toEnum 0 ..]
200 fr_FR :: LocaleInj ls FR => Locale ls FR
201 fr_FR = localeInj FR_FR
205 data instance FullLocale EN
224 deriving (Enum,Eq,Ord,Show)
225 instance LocalesFor EN where
226 localesFor = Map.fromList $
228 fullLocales [toEnum 0 ..]
229 en_US :: LocaleInj ls EN => Locale ls EN
230 en_US = localeInj EN_US