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