{-# OPTIONS_GHC -Wno-orphans #-}
module HsKu.Load where

import HsKu
import Prelude as P
import Data.Text as T
import Data.Maybe
import Data.Either
import Data.Set as S
import Data.Map as M
import Data.Yaml
import System.Environment
import System.Directory
import System.FilePath
import Control.Monad

instance FromJSON Language where
  parseJSON :: Value -> Parser Language
parseJSON (Object Object
v) = Text -> Set Char -> Set Text -> Language
Language
    (Text -> Set Char -> Set Text -> Language)
-> Parser Text -> Parser (Set Char -> Set Text -> Language)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>                   (Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name")
    Parser (Set Char -> Set Text -> Language)
-> Parser (Set Char) -> Parser (Set Text -> Language)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Set Char) -> Parser Text -> Parser (Set Char)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Set Char
toVowels     (Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"vowels")
    Parser (Set Text -> Language)
-> Parser (Set Text) -> Parser Language
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Set Text) -> Parser Text -> Parser (Set Text)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> Set Text
toDiphtongs  (Object
v Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"diphtongs")
    where toVowels :: Text -> Set Char
toVowels    = String -> Set Char
forall a. Ord a => [a] -> Set a
S.fromList (String -> Set Char) -> (Text -> String) -> Text -> Set Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Char) -> [Text] -> String
forall a b. (a -> b) -> [a] -> [b]
P.map HasCallStack => Text -> Char
Text -> Char
T.head ([Text] -> String) -> (Text -> [Text]) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words
          toDiphtongs :: Text -> Set Text
toDiphtongs = [Text] -> Set Text
forall a. Ord a => [a] -> Set a
S.fromList ([Text] -> Set Text) -> (Text -> [Text]) -> Text -> Set Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.words
  parseJSON Value
_ = String -> Parser Language
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Couldn't parse language"

loadLanguages :: IO Languages
loadLanguages :: IO Languages
loadLanguages = do
  String
langDir   <- String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"languages" (Maybe String -> String) -> IO (Maybe String) -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
lookupEnv String
"HSKU_LANGUAGES"
  [String]
langFiles <- (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
P.filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
".yml") (String -> Bool) -> (String -> String) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeExtension) ([String] -> [String]) -> IO [String] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
listDirectory String
langDir
  [(Text, Language)]
nameLangs <- ([Either ParseException (Text, Language)] -> [(Text, Language)])
-> IO [Either ParseException (Text, Language)]
-> IO [(Text, Language)]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Either ParseException (Text, Language)] -> [(Text, Language)]
forall a b. [Either a b] -> [b]
rights (IO [Either ParseException (Text, Language)]
 -> IO [(Text, Language)])
-> IO [Either ParseException (Text, Language)]
-> IO [(Text, Language)]
forall a b. (a -> b) -> a -> b
$ [String]
-> (String -> IO (Either ParseException (Text, Language)))
-> IO [Either ParseException (Text, Language)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
langFiles ((String -> IO (Either ParseException (Text, Language)))
 -> IO [Either ParseException (Text, Language)])
-> (String -> IO (Either ParseException (Text, Language)))
-> IO [Either ParseException (Text, Language)]
forall a b. (a -> b) -> a -> b
$ \String
fp -> do
                let ln :: String
ln = String -> String
takeBaseName String
fp
                (Language -> (Text, Language))
-> Either ParseException Language
-> Either ParseException (Text, Language)
forall a b.
(a -> b) -> Either ParseException a -> Either ParseException b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack String
ln,) (Either ParseException Language
 -> Either ParseException (Text, Language))
-> IO (Either ParseException Language)
-> IO (Either ParseException (Text, Language))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either ParseException Language)
forall a. FromJSON a => String -> IO (Either ParseException a)
decodeFileEither (String
langDir String -> String -> String
</> String
fp)
  Languages -> IO Languages
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Languages -> IO Languages) -> Languages -> IO Languages
forall a b. (a -> b) -> a -> b
$ [(Text, Language)] -> Languages
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Text, Language)]
nameLangs