{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Data.Locale where import Data.Eq (Eq(..)) import Data.Function (($), (.)) import Data.Functor ((<$>)) import Data.Map.Strict (Map) import Data.Maybe (Maybe(..), isJust) import Data.Ord (Ord(..), Ordering(..)) import Data.Semigroup (Semigroup(..)) import Data.String (String) import Data.Text (Text) import Data.Tuple (swap) import Data.Type.Equality ((:~:)(..)) import Prelude (Enum(..), error, max) import Text.Show (Show(..)) import qualified Data.Char as Char import qualified Data.Map.Strict as Map import qualified Data.Text as Text -- * Type 'Zero' data Zero -- * Type 'Succ' data Succ p -- * Type 'Index' type family Index xs x where Index (x ': xs) x = Zero Index (not_x ': xs) x = Succ (Index xs x) -- * Type 'Localization' data Localization l10n = forall l. l10n l => Localization (FullLocale l) -- ** Class 'Loqualize' -- | Build a 'Localization' containing the @l10n@ type class dictionnary -- corresponding to the given 'LocaleIn' -- (indexing a 'Locale' within the list of locales @ls@). class Loqualize ls l10n where localization :: LocaleIn ls -> Localization l10n instance l10n l => Loqualize '[l] l10n where localization (LocaleIn li) = case li of LocaleZ l -> Localization l LocaleS{} -> error "localize: impossible locale" instance ( l10n l , Loqualize (l1 ': ls) l10n ) => Loqualize (l ': l1 ': ls) l10n where localization (LocaleIn (LocaleZ l)) = Localization l localization (LocaleIn (LocaleS l)) = localization (LocaleIn l) -- * Type 'Locale' data Locale (ls::[*]) (l:: *) where LocaleZ :: FullLocale l -> Locale (l ': ls) l LocaleS :: Locale ls l -> Locale (not_l ': ls) l infixr 5 `LocaleS` instance ( Show (FullLocale l) , Show (Locale ls l) ) => Show (Locale (l ': ls) l) where show (LocaleZ fl) = showFullLocale fl show (LocaleS l) = show l showFullLocale :: Show (FullLocale l) => FullLocale l -> String showFullLocale fl = case show fl of s0:s1:s@('_':_) -> Char.toLower s0:Char.toLower s1:s s -> s eqLocale :: Eq (FullLocale x) => Eq (FullLocale y) => Locale ls x -> Locale ls y -> Maybe (x:~:y) eqLocale (LocaleZ x) (LocaleZ y) = if x == y then Just Refl else Nothing eqLocale (LocaleS x) (LocaleS y) = eqLocale x y eqLocale _x _y = Nothing compareLocale :: Ord (FullLocale x) => Ord (FullLocale y) => Locale ls x -> Locale ls y -> Ordering compareLocale (LocaleZ x) (LocaleZ y) = compare x y compareLocale (LocaleS x) (LocaleS y) = compareLocale x y compareLocale LocaleZ{} LocaleS{} = LT compareLocale LocaleS{} LocaleZ{} = GT -- ** Type 'FullLocale' data family FullLocale (l:: *) :: * -- ** Type 'LocaleIn' data LocaleIn ls = forall l. ( Eq (FullLocale l) , Ord (FullLocale l) ) => LocaleIn (Locale ls l) instance Eq (LocaleIn ls) where LocaleIn x == LocaleIn y = isJust (eqLocale x y) instance Ord (LocaleIn ls) where compare (LocaleIn x) (LocaleIn y) = compareLocale x y instance Locales ls => Show (LocaleIn ls) where show = Text.unpack . (textLocales @ls Map.!) -- ** Class 'LocaleInj' type LocaleInj ls l = LocaleInjP (Index ls l) ls l localeInj :: forall l ls. LocaleInj ls l => FullLocale l -> Locale ls l localeInj = localeInjP @(Index ls l) -- *** Class 'LocaleInjP' class LocaleInjP p ls l where localeInjP :: FullLocale l -> Locale ls l instance LocaleInjP Zero (l ': ls) l where localeInjP = LocaleZ instance LocaleInjP p ls l => LocaleInjP (Succ p) (not_t ': ls) l where localeInjP = LocaleS . localeInjP @p -- * Class 'Localize' class Localize ls msg a where localize :: LocaleIn ls -> a -> msg instance LocalizeIn l msg a => Localize '[l] msg a where localize (LocaleIn li) = case li of LocaleZ l -> localizeIn @l l LocaleS{} -> error "localize: impossible locale" instance ( LocalizeIn l msg a , Localize (l1 ': ls) msg a ) => Localize (l ': l1 ': ls) msg a where localize (LocaleIn (LocaleZ l)) = localizeIn @l l localize (LocaleIn (LocaleS l)) = localize (LocaleIn l) -- ** Class 'LocalizeIn' class LocalizeIn l msg a where localizeIn :: FullLocale l -> a -> msg -- * Class 'Locales' class Locales ls where locales :: Map Text (LocaleIn ls) textLocales :: Locales ls => Map (LocaleIn ls) Text textLocales = Map.fromListWith max $ swap <$> Map.toList locales countryCode :: forall ls. Locales ls => LocaleIn ls -> Text countryCode = Text.takeWhile Char.isAlphaNum . (textLocales @ls Map.!) instance Locales '[] where locales = Map.empty instance (LocalesFor l, Locales ls, Ord (FullLocale l)) => Locales (l ': ls) where locales = Map.unionWithKey (\k _n _o -> error $ "locales: duplicate locale: "<>Text.unpack k) (LocaleIn . localeInj <$> localesFor @l) ((\(LocaleIn l) -> LocaleIn $ LocaleS l) <$> locales @ls) -- ** Class 'LocalesFor' class LocalesFor l where localesFor :: Map Text (FullLocale l) fullLocales :: Show (FullLocale l) => [FullLocale l] -> [(Text, FullLocale l)] fullLocales = ((\fl -> (Text.pack (showFullLocale fl), fl)) <$>) fullLocale :: Locale ls l -> FullLocale l fullLocale (LocaleZ l) = l fullLocale (LocaleS l) = fullLocale l -- * Type 'FR' data FR data instance FullLocale FR = FR_BE | FR_CA | FR_CH | FR_FR | FR_LU deriving (Enum,Eq,Ord,Show) instance LocalesFor FR where localesFor = Map.fromList $ ("fr", FR_FR) : fullLocales [toEnum 0 ..] fr_FR :: LocaleInj ls FR => Locale ls FR fr_FR = localeInj FR_FR -- * Type 'EN' data EN data instance FullLocale EN = EN_AG | EN_AU | EN_BW | EN_CA | EN_DK | EN_GB | EN_HK | EN_IE | EN_IL | EN_IN | EN_NG | EN_NZ | EN_PH | EN_SG | EN_US | EN_ZA | EN_ZM | EN_ZW deriving (Enum,Eq,Ord,Show) instance LocalesFor EN where localesFor = Map.fromList $ ("en", EN_US) : fullLocales [toEnum 0 ..] en_US :: LocaleInj ls EN => Locale ls EN en_US = localeInj EN_US