{-# 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 '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'
-- | First method: localization using data type.
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 'Loqualize'
-- | Second method: localization using type qualification.
--
-- Build a 'Loqualization' containing the @q@ type class dictionnary
-- corresponding to the given 'LocaleIn'
-- (indexing a 'Locale' within the list of locales @ls@).
class Loqualize ls q where
	loqualize :: LocaleIn ls -> Loqualization q
instance q l => Loqualize '[l] q where
	loqualize (LocaleIn li) =
		case li of
		 LocaleZ l -> Loqualization l
		 LocaleS{} -> error "loqualize: impossible locale"
instance ( q l
         , Loqualize (l1 ': ls) q
         ) => Loqualize (l ': l1 ': ls) q where
	loqualize (LocaleIn (LocaleZ l)) = Loqualization l
	loqualize (LocaleIn (LocaleS l)) = loqualize (LocaleIn l)

-- ** Type 'Loqualization'
data Loqualization q
 = forall l. q l =>
 Loqualization (FullLocale l)

-- * 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