]> Git — Sourcephile - doclang.git/blob - Data/Locale.hs
Automatize localesOf.
[doclang.git] / 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