{-# LANGUAGE PostfixOperators #-}

module Language.Lojban.Lujvo (rafsis,fixClusters) where

import Control.Monad
import Control.Applicative ((<$>))
import Data.Maybe
import Prelude hiding ((^),(*),(/),(+))
import Text.ParserCombinators.Parsec hiding (notFollowedBy)

data Rafsi = ShortRafsi [Char] | Rafsi4Let [Char] | Rafsi5Let [Char]
instance Show Rafsi where
    show (ShortRafsi e) = e
    show (Rafsi4Let e) = e
    show (Rafsi5Let e) = e

-- | Fix clusters in lojbanic words, consonants, vowels, hyphens, etc. Might not be accurate sometimes.
fixClusters :: String -> String
fixClusters xs = go xs [] where
    go stream acc | stream == xs && isJust broken = go rest (acc++cmavo++[hyphen])
                  where broken = breakCmavo stream
                        Just (cmavo,hyphen,rest) = broken
    go (x:y:xs) acc | validCluster (x:y:[]) = go (y:xs) (acc++[x])
                    | otherwise             = go (y:xs) (acc++[x]++"y")
    go [x] acc = go [] (acc++[x])
    go [] acc = acc

breakCmavo :: String -> Maybe (String,Char,String)
breakCmavo stream = either (const Nothing) Just $ parse break "" stream where
    break = do cmavo' <- cmavo
               rest <- ccv!> (lujvoRest / gismu / cmavo)
               let hyphen = if head rest == 'r' then 'n' else 'r'               
               return (cmavo',hyphen,rest)
        where lujvoRest = (concat . map show) `fmap` lujvo

validCluster :: [Char] -> Bool
validCluster = either (const False) (const True) . parse cluster ""

cluster = diphthong 
        / vt & string "'"
        / string "'" & vt 
        / (ct / vowel) & (ct / vt)
        / ct & string "y"
        / string "y" & ct

-- | The rafsis of a lujvo. (Empty list for invalid parse.)
rafsis :: String -> [String]
rafsis s = 
    case parse lujvo "" s of
      Right rs -> map show rs
      Left _ -> []

cmavo = ct & (diphthong / vt & h & vt / vt)
lujvo = (do r1 <- raf; rs <- (raf+); return (r1:rs)) <!anyChar
               where raf = rafsi5 <!anyChar / rafsi3 / rafsi4
rafsi3 = ShortRafsi <$> ((cvc / ccv / cvv) <!y <!(anyChar >> y))
rafsi4 = Rafsi4Let <$> (ct & (vt & ct / ct & vt) & ct <&anyChar <&!(y?))
rafsi5 = do (Rafsi4Let ls) <- rafsi4; v <- vt; return $ Rafsi5Let (ls++v)
gismu = do (Rafsi4Let ls) <- rafsi4; v <- vt; return (ls++v)
cvc = ct & vt & ct <&anyChar <&!(y?)
ccv = ct & ct & vt <&!(((r / n) <& ct)?)
cvv = ct & (diphthong / vt & h & vt) <&!(((r / n) <& ct)?)
ct = consonant
vt = vowel
syllabic = l / m / n / r
consonant = voiced / unvoiced / syllabic
diphthong = (a & i / a & u / e & i / o & i) <!nucleus <!glide
vowel = (a / e / i / o / u) <!nucleus
a = oneOf' "aA"
e = oneOf' "eE"
i = oneOf' "iI"
o = oneOf' "oO"
u = oneOf' "uU"
y = oneOf' "yY"
affricate = t & c / t & s / d & j / d & z
glide = (i / u) <&nucleus <!glide
nucleus = vowel / diphthong / y <!nucleus
voiced = b / d / g / j / v / z
unvoiced = c / f / k / p / s / t / x
l = oneOf' "lL" <!l
m = oneOf' "mM" <!m <!z
n = oneOf' "nN" <!n <!affricate
r = oneOf' "rR" <!r
b = oneOf' "bB" <!b <!unvoiced
d = oneOf' "dD" <!d <!unvoiced
g = oneOf' "gG" <!g <!unvoiced
v = oneOf' "vV" <!v <!unvoiced
j = oneOf' "jJ" <!j <!z <!unvoiced
z = oneOf' "zZ" <!z <!j <!unvoiced
s = oneOf' "sS" <!s <!c <!voiced
c = oneOf' "cC" <!c <!s <!x <!voiced
x = oneOf' "xX" <!x <!c <!k <!voiced
k = oneOf' "kK" <!k <!x <!voiced
f = oneOf' "fF" <!f <!voiced
p = oneOf' "pP" <!p <!voiced
t = oneOf' "tT" <!t <!voiced
h = oneOf' "'h" <!h <&nucleus

p <&! p1 = do r <- p; p1; return r
infixl 2 <&!
oneOf' p = oneOf p >>= return . (:[])
(+) p = many1 (try p)
(*) p = many (try p)
(!>) a a1 = (do r <- try a; unexpected $ show r) <|> a1
infixr 3 !>
(<!) a a1 = do r <- a; ((try a1 >>= unexpected . show) <|> return r)
infixl 2 <!
(/) a a1 = (try a <|> a1)
infixl 1 /
(&) a a1 = (do r <- a; r1 <- a1; return $ mplus r r1)
infixl 4 &
(<&) a a1 = do r <- a; lookAhead a1; return r
infixl 2 <&
(?) p = (try p <|> return mzero)