module Wayland.CodeGen.Utils
  ( pascalCase
  , camelCase
  , recordField
  , protocolModule
  , interfaceModule
  , fullModule
  , FlatModules
  , flattenModules
  , resolveTypes
  ) where

import Data.Char (toUpper, toLower)
import Wayland.CodeGen.Types
import qualified Data.Map as M
import Control.Monad.State.Strict (State, runState, gets, modify)
import Data.Functor (($>))

type FlatModules = M.Map String (TypedProtocol, TypedInterfaceDesc)

pascalCase :: String -> String
pascalCase (c:cs) = toUpper c : camelCase cs
pascalCase []     = []

camelCase :: String -> String
camelCase ('_':cs) = pascalCase cs
camelCase (c  :cs) = c : camelCase cs
camelCase []       = []

recordField :: String -> String -> String
recordField name field = applyFirst toLower name ++ applyFirst toUpper field
  where applyFirst _ []     = []
        applyFirst f (x:xs) = f x : xs

protocolModule :: ProtocolT i -> String
protocolModule = fromName . protName
  where fromName "wayland" = "Core"
        fromName name      = pascalCase name

interfaceModule :: InterfaceDesc -> String
interfaceModule = pascalCase . ifName

fullModule :: ProtocolT i -> InterfaceDesc -> String
fullModule p i = "Wayland.Protocols." ++ protocolModule p ++ "." ++ interfaceModule i

flattenModules :: [TypedProtocol] -> FlatModules
flattenModules protocols = M.unions $ fmap flattenProtocol protocols
  where flattenProtocol p    = M.fromList $ fmap (flattenInterface p) (protInterfaces p)
        flattenInterface p i = (ifName (fst i), (p, i))

resolveTypes :: Protocol -> TypedProtocol
resolveTypes p = Protocol { protName = protName p
                          , protDescription = protDescription p
                          , protCopyright   = protCopyright p
                          , protInterfaces  = runInterface <$> protInterfaces p
                          }
  where runInterface i = runState (resolveInterfaceTypes i $> i) emptyTypeInfo

resolveInterfaceTypes :: InterfaceDesc -> State TypeInfo ()
resolveInterfaceTypes i = do
  let assignRequestArgs r a (TypeInfo requests events enums) = TypeInfo (M.insert r a requests) events enums
  let assignEventArgs   e a (TypeInfo requests events enums) = TypeInfo requests (M.insert e a events) enums
  let assignEnumName    e n (TypeInfo requests events enums) = TypeInfo requests events (M.insert e n enums)
  let resolveAndAssign res ass = do x <- res; modify $ ass x
  mapM_ (\m -> resolveAndAssign (resolveMessageType m) (assignEventArgs   (msgName  m))) (ifEvents   i)
  mapM_ (\m -> resolveAndAssign (resolveMessageType m) (assignRequestArgs (msgName  m))) (ifRequests i)
  mapM_ (\e -> resolveAndAssign (resolveEnumType    e) (assignEnumName    (enumName e))) (ifEnums    i)

resolveMessageType :: MessageDesc -> State TypeInfo ArgumentName
resolveMessageType m = case msgArguments m of
                         []  -> pure ArgumentNameNone
                         [a] -> pure $ ArgumentNameSingle a
                         as  -> ArgumentNameRecord as <$> getFreeTypeName (pascalCase (msgName m)) Nothing

resolveEnumType :: EnumDesc -> State TypeInfo EnumName
resolveEnumType e = EnumName e <$> name
  where name = getFreeTypeName (pascalCase (enumName e)) $ Just (if enumBitfield e then "Flag" else "Value")

getFreeTypeName :: String -> Maybe String -> State TypeInfo String
getFreeTypeName requested conflictSuffix = attemptRequested
  where attemptName :: String -> State TypeInfo Bool
        attemptName name = gets $ isTypeFree name
        attemptRequested = attemptName requested >>= \s -> if s then pure requested else attemptSuffix
        attemptSuffix = case conflictSuffix of
                          Just suffix -> let n = requested ++ suffix
                                         in attemptName n >>= \s -> if s then pure n else attemptPrime n
                          Nothing     -> attemptPrime requested
        attemptPrime n = let n' = n ++ "'"
                         in attemptName n' >>= \s -> if s then pure n' else attemptPrime n'