module HsKu
  (
    -- * Data types
      Language(..)
    , Languages
    , Haiku
    -- * Haiku parsing
    , parseHaiku
    , parseHaikuForLanguage
  ) where

import Data.Bool
import Data.Char
import Data.Text as T
import Data.Set as S
import Data.Map
import Data.Void
import Data.Either.Extra
import Text.Megaparsec as P
import Text.Megaparsec.Char
import Control.Applicative as A
import Control.Monad.Reader

-- Data types

data Language = Language
  { Language -> Text
name      :: Text
  , Language -> Set Char
vowels    :: Set Char
  , Language -> Set Text
diphtongs :: Set Text
  } deriving (Language -> Language -> Bool
(Language -> Language -> Bool)
-> (Language -> Language -> Bool) -> Eq Language
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Language -> Language -> Bool
== :: Language -> Language -> Bool
$c/= :: Language -> Language -> Bool
/= :: Language -> Language -> Bool
Eq, Int -> Language -> ShowS
[Language] -> ShowS
Language -> String
(Int -> Language -> ShowS)
-> (Language -> String) -> ([Language] -> ShowS) -> Show Language
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Language -> ShowS
showsPrec :: Int -> Language -> ShowS
$cshow :: Language -> String
show :: Language -> String
$cshowList :: [Language] -> ShowS
showList :: [Language] -> ShowS
Show)

type Languages = Map Text Language

type Haiku = (Text, Text, Text)

-- Haiku parsing

type Parser = ReaderT Language (Parsec Void Text)

parseHaiku :: Languages -> Text -> Maybe (Language, Haiku)
parseHaiku :: Languages -> Text -> Maybe (Language, Haiku)
parseHaiku Languages
langs Text
text = Map Text (Maybe (Language, Haiku)) -> Maybe (Language, Haiku)
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum (Language -> Maybe (Language, Haiku)
tryLang (Language -> Maybe (Language, Haiku))
-> Languages -> Map Text (Maybe (Language, Haiku))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Languages
langs)
  where tryLang :: Language -> Maybe (Language, Haiku)
tryLang Language
lang = (Language
lang,) (Haiku -> (Language, Haiku))
-> Maybe Haiku -> Maybe (Language, Haiku)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language -> Text -> Maybe Haiku
parseHaikuForLanguage Language
lang Text
text

parseHaikuForLanguage :: Language -> Text -> Maybe Haiku
parseHaikuForLanguage :: Language -> Text -> Maybe Haiku
parseHaikuForLanguage Language
lang =
  Either (ParseErrorBundle Text Void) Haiku -> Maybe Haiku
forall a b. Either a b -> Maybe b
eitherToMaybe (Either (ParseErrorBundle Text Void) Haiku -> Maybe Haiku)
-> (Text -> Either (ParseErrorBundle Text Void) Haiku)
-> Text
-> Maybe Haiku
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text Haiku
-> String -> Text -> Either (ParseErrorBundle Text Void) Haiku
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
runParser (ReaderT Language (Parsec Void Text) Haiku
-> Language -> Parsec Void Text Haiku
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Language (Parsec Void Text) Haiku
pHaiku Language
lang) String
""

  where

        pVowel :: Parser Char
        pVowel :: Parser Char
pVowel = do
          String
vs <- (Language -> String) -> ReaderT Language (Parsec Void Text) String
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Set Char -> String
forall a. Set a -> [a]
S.toList (Set Char -> String)
-> (Language -> Set Char) -> Language -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Set Char
vowels)
          [Parser Char] -> Parser Char
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice (Char -> Parser Char
Token Text -> ReaderT Language (Parsec Void Text) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char' (Char -> Parser Char) -> String -> [Parser Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
vs)

        pDiphtong :: Parser Text
        pDiphtong :: Parser Text
pDiphtong = do
          [Text]
dps <- (Language -> [Text]) -> ReaderT Language (Parsec Void Text) [Text]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Set Text -> [Text]
forall a. Set a -> [a]
S.toList (Set Text -> [Text])
-> (Language -> Set Text) -> Language -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Set Text
diphtongs)
          [Parser Text] -> Parser Text
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
choice (Text -> Parser Text
Tokens Text -> ReaderT Language (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
(MonadParsec e s m, FoldCase (Tokens s)) =>
Tokens s -> m (Tokens s)
string' (Text -> Parser Text) -> [Text] -> [Parser Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Text]
dps)

        pSyl :: Parser Text
        pSyl :: Parser Text
pSyl = Parser Text -> Parser Text
forall a.
ReaderT Language (Parsec Void Text) a
-> ReaderT Language (Parsec Void Text) a
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try Parser Text
pDiphtong Parser Text -> Parser Text -> Parser Text
forall a.
ReaderT Language (Parsec Void Text) a
-> ReaderT Language (Parsec Void Text) a
-> ReaderT Language (Parsec Void Text) a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Char -> Text
T.singleton (Char -> Text) -> Parser Char -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Char
pVowel)

        pSep :: Parser Text
        pSep :: Parser Text
pSep = do
          Set Char
syls <- (Language -> Set Char)
-> ReaderT Language (Parsec Void Text) (Set Char)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Language -> Set Char
sylChars
          Maybe String
-> (Token Text -> Bool)
-> ReaderT Language (Parsec Void Text) (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe String
forall a. Maybe a
Nothing (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Set Char -> Bool
forall a. Ord a => a -> Set a -> Bool
`S.member` Set Char
syls))
          where sylChars :: Language -> Set Char
sylChars = Set Char -> Set Char -> Set Char
forall a. Ord a => Set a -> Set a -> Set a
S.union (Set Char -> Set Char -> Set Char)
-> (Language -> Set Char) -> Language -> Set Char -> Set Char
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language -> Set Char
vowels (Language -> Set Char -> Set Char)
-> (Language -> Set Char) -> Language -> Set Char
forall a b.
(Language -> a -> b) -> (Language -> a) -> Language -> b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Text -> Char) -> Set Text -> Set Char
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map HasCallStack => Text -> Char
Text -> Char
T.head (Set Text -> Set Char)
-> (Language -> Set Text) -> Language -> Set Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Language -> Set Text
diphtongs

        pWordSep :: Parser Text
        pWordSep :: Parser Text
pWordSep = Parser Text
pSep Parser Text -> (Text -> Parser Text) -> Parser Text
forall a b.
ReaderT Language (Parsec Void Text) a
-> (a -> ReaderT Language (Parsec Void Text) b)
-> ReaderT Language (Parsec Void Text) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Text -> Bool) -> Text -> Parser Text
forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
guarded ((Char -> Bool) -> Text -> Bool
T.any Char -> Bool
isSpace)

        pSylSep :: Parser (Text, Text)
        pSylSep :: Parser (Text, Text)
pSylSep = (,) (Text -> Text -> (Text, Text))
-> Parser Text
-> ReaderT Language (Parsec Void Text) (Text -> (Text, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pSyl ReaderT Language (Parsec Void Text) (Text -> (Text, Text))
-> Parser Text -> Parser (Text, Text)
forall a b.
ReaderT Language (Parsec Void Text) (a -> b)
-> ReaderT Language (Parsec Void Text) a
-> ReaderT Language (Parsec Void Text) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Text
pSep

        pSyls :: Int -> Parser Text
        pSyls :: Int -> Parser Text
pSyls Int
n = do
          [(Text, Text)]
sylSeps <- Int
-> Parser (Text, Text)
-> ReaderT Language (Parsec Void Text) [(Text, Text)]
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
P.count (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) Parser (Text, Text)
pSylSep
          Text
lastSyl <- Parser Text
pSyl
          let initSyls :: Text
initSyls = [Text] -> Text
T.concat ((Text -> Text -> Text) -> (Text, Text) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text
append ((Text, Text) -> Text) -> [(Text, Text)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
sylSeps)
          Text -> Parser Text
forall a. a -> ReaderT Language (Parsec Void Text) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> Parser Text) -> Text -> Parser Text
forall a b. (a -> b) -> a -> b
$ Text
initSyls Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
lastSyl

        pHaiku :: Parser Haiku
        pHaiku :: ReaderT Language (Parsec Void Text) Haiku
pHaiku = do
          Text
start1          <- Text -> Parser Text -> Parser Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" Parser Text
pSep
          Text
line1           <- Int -> Parser Text
pSyls Int
5
          (Text
end1, Text
start2)  <- Text -> (Text, Text)
splitWordSep (Text -> (Text, Text)) -> Parser Text -> Parser (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pWordSep
          Text
line2           <- Int -> Parser Text
pSyls Int
7
          (Text
end2, Text
start3)  <- Text -> (Text, Text)
splitWordSep (Text -> (Text, Text)) -> Parser Text -> Parser (Text, Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text
pWordSep
          Text
line3           <- Int -> Parser Text
pSyls Int
5
          Text
end3            <- Text -> Parser Text -> Parser Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" Parser Text
pSep
          Haiku -> ReaderT Language (Parsec Void Text) Haiku
forall a. a -> ReaderT Language (Parsec Void Text) a
forall (m :: * -> *) a. Monad m => a -> m a
return  ( Text
start1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line1 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end1
                  , Text
start2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line2 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end2
                  , Text
start3 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
line3 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
end3
                  )

-- Utility functions

splitWordSep :: Text -> (Text, Text)
splitWordSep :: Text -> (Text, Text)
splitWordSep Text
sep =
  let right :: Text
right = (Char -> Bool) -> Text -> Text
T.takeWhileEnd (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) Text
sep
      rest :: Text
rest  = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) Text
sep
      left :: Text
left  = (Char -> Bool) -> Text -> Text
T.dropWhileEnd Char -> Bool
isSpace Text
rest
  in  (Text
left, Text
right)

guarded :: Alternative f => (a -> Bool) -> a -> f a
guarded :: forall (f :: * -> *) a. Alternative f => (a -> Bool) -> a -> f a
guarded = (f a -> Bool -> f a) -> (a -> f a) -> (a -> Bool) -> a -> f a
forall a b c. (a -> b -> c) -> (a -> a) -> (a -> b) -> a -> c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (f a -> f a -> Bool -> f a
forall a. a -> a -> Bool -> a
bool f a
forall a. f a
forall (f :: * -> *) a. Alternative f => f a
A.empty) a -> f a
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure -- soon to be in Control.Monad.Extra