module Data.Name
    ( Name (..)
    , Name_
    -- * Parsers
    , parseName
    , readNameLFM
    , readNameFML
    -- * Writers
    , showNameLFM
    , showNameFML
    , renderNameLFM
    , renderNameFML
    ) where

import Prolog
import Data.Aeson
import Data.Alias
import Data.Char (isSpace)
import Data.Set qualified as S
import Data.Text qualified as T


data Name a = Name
    { lastName :: !a
    , firstName :: !a
    , middleName :: !(Maybe a)
    } deriving (Eq, Functor, Foldable, Generic, Generic1, Ord, Show, Traversable)

type Name_ = Name StrictText

instance Binary a => Binary (Name a)

instance Ord a => ToAliases (Name a) (Name a) where
    toAliases = S.singleton

instance Applicative Name where
    pure a = Name a a (pure a)
    Name l f m <*> Name l' f' m' = Name (l l') (f f') (m <*> m')

instance ToJSON a => ToJSON (Name a) where
    toJSON (Name l f m) = object $
        [ "first" .= f
        , "last" .= l
        ] <> maybe [] (pure . ("middle" .=)) m
    toEncoding (Name l f m) = pairs $ fold $
        [ "first" .= f
        , "last" .= l
        ] <> maybe [] (pure . ("middle" .=)) m

instance (StringConv s StrictText, ToJSON s) => ToJSONKey (Name s) where
    toJSONKey = showNameLFM . fmap toSL >$< toJSONKey

instance StringConv StrictText s => FromJSONKey (Name s) where
    fromJSONKey = FromJSONKeyTextParser $ \t -> toSL <<$>> (readNameLFM t <|> readNameFML t)



instance StringConv StrictText s => FromJSON (Name s) where
    parseJSON (Object v) = fmap (fmap $ toSL @StrictText) $ Name
        <$> v .: "first"
        <*> v .: "last"
        <*> v .:? "middle" .!= Nothing
    parseJSON (String t) = toSL <<$>> (readNameLFM t <|> readNameFML t)
    parseJSON _ = empty



readNameLFM :: Alternative m => StrictText -> m Name_
readNameLFM t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
    case T.break (== ',') t of
      (l, fm)
        | T.null l -> empty
        | otherwise -> case T.dropWhile ((||) <$> isSpace <*> (== ',')) fm of
                         fm'
                           | T.null fm' -> empty
                           | otherwise -> case T.break isSpace fm' of
                                            (f, m) -> pure $ Name l f $ case T.dropWhile isSpace m of
                                                                          x | T.null x -> Nothing
                                                                            | otherwise -> Just x

readNameFML :: Alternative m => StrictText -> m Name_
readNameFML t = T.map (\c -> if c == '~' then ' ' else c) <<$>>
    case T.words t of
      [] -> empty
      (f:xs) -> case unsnoc xs of
                  Nothing -> empty
                  Just (m, l) -> pure $ Name f l $ case m of
                                                     [] -> Nothing
                                                     _ -> Just $ T.unwords m

parseName :: Alternative m => StrictText -> m Name_
parseName = (<|>) <$> readNameLFM <*> readNameFML

showNameLFM :: Name_ -> StrictText
showNameLFM (Name l f m) = stt l <> ", " <> stt f <> maybe "" (\x -> " " <> stt x) m

showNameFML :: Name_ -> StrictText
showNameFML (Name l f m) = stt f <> maybe " " (\x -> " " <> stt x <> " ") m <> stt l

renderNameLFM :: (Semigroup a, IsString a) => Name a -> a
renderNameLFM (Name l f m) = l <> ", " <> f <> maybe "" (\x -> " " <> x) m

renderNameFML :: (Semigroup a, IsString a) => Name a -> a
renderNameFML (Name l f m) = f <> maybe " " (\x -> " " <> x <> " ") m <> l

-- Helpers

unsnoc :: [a] -> Maybe ([a],a)
unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing
{-# INLINABLE unsnoc #-}

stt :: StrictText -> StrictText
stt = T.map $ \c -> if isSpace c then '~' else c
{-# INLINABLE stt #-}