{-# LANGUAGE OverloadedStrings #-}
module Name.Name(
    Module(..),
    Name,
    Class,
    NameType(..),
    ToName(..),
    ffiExportName,
    fromModule,
    fromTypishHsName,
    fromValishHsName,
    getIdent,
    getModule,
    isConstructorLike,
    isTypeNamespace,
    isValNamespace,
    mainModule,
    preludeModule,
    mapName,
    mapName',
    nameName,
    nameParts,
    nameType,
    parseName,
    primModule,
    qualifyName,
    setModule,
    quoteName,
    fromQuotedName,
    toModule,
    toUnqualified
    ) where

import Data.Char
import Data.Data

import C.FFI
import Data.Binary
import Doc.DocLike
import Doc.PPrint
import GenUtil
import StringTable.Atom

-------------
-- Name types
-------------

data NameType
    = TypeConstructor
    | DataConstructor
    | ClassName
    | TypeVal
    | Val
    | SortName
    | FieldLabel
    | RawType
    | UnknownType
    | QuotedName
    deriving(Ord,Eq,Enum,Read,Show)

isTypeNamespace TypeConstructor = True
isTypeNamespace ClassName = True
isTypeNamespace TypeVal = True
isTypeNamespace _ = False

isValNamespace DataConstructor = True
isValNamespace Val = True
isValNamespace _ = False

-----------------
-- name definiton
-----------------

newtype Name = Name Atom
    deriving(Ord,Eq,Typeable,Binary,Data,ToAtom,FromAtom)

isConstructorLike n =  isUpper x || x `elem` ":("  || xs == "->" || xs == "[]" where
    (_,_,xs@(x:_)) = nameParts n

fromTypishHsName, fromValishHsName :: Name -> Name
fromTypishHsName name
    | nameType name == QuotedName = name
    | isConstructorLike name = toName TypeConstructor name
    | otherwise = toName TypeVal name
fromValishHsName name
    | nameType name == QuotedName = name
    | isConstructorLike name = toName DataConstructor name
    | otherwise = toName Val name

createName :: NameType -> Module -> String -> Name
createName _ (Module "") i = error $ "createName: empty module " ++ i
createName _ m "" = error $ "createName: empty ident " ++ show m
createName t m i = Name $ toAtom $ (chr $ ord '1' + fromEnum t):show m ++ ";" ++ i

createUName :: NameType -> String -> Name
createUName _ "" = error $ "createUName: empty ident"
createUName t i =  Name $ toAtom $ (chr $ fromEnum t + ord '1'):";" ++ i

class ToName a where
    toName :: NameType -> a -> Name
    fromName :: Name -> (NameType, a)

instance ToName (String,String) where
    toName nt (m,i) = createName nt (Module $ toAtom m) i
    fromName n = case nameParts n of
            (nt,Just (Module m),i) -> (nt,(show m,i))
            (nt,Nothing,i) -> (nt,("",i))

instance ToName (Module,String) where
    toName nt (m,i) = createName nt m i
    fromName n = case nameParts n of
            (nt,Just m,i) -> (nt,(m,i))
            (nt,Nothing,i) -> (nt,(Module "",i))

instance ToName (Maybe Module,String) where
    toName nt (Just m,i) = createName nt m i
    toName nt (Nothing,i) = createUName nt i
    fromName n = case nameParts n of
        (nt,a,b) -> (nt,(a,b))

instance ToName Name where
    toName nt i = toName nt (x,y) where
        (_,x,y) = nameParts i
    fromName n = (nameType n,n)

instance ToName String where
    toName nt i = createUName nt i
    fromName n = (nameType n, mi ) where
        mi = case snd $ fromName n of
            (Just (Module m),i) -> show m ++ "." ++ i
            (Nothing,i) -> i

getModule :: Monad m => Name -> m Module
getModule n = case nameParts n of
    (_,Just m,_) -> return m
    _ -> fail "Name is unqualified."

getIdent :: Name -> String
getIdent n = case nameParts n of
    (_,_,s)  -> s

toUnqualified :: Name -> Name
toUnqualified n = case nameParts n of
    (_,Nothing,_) -> n
    (t,Just _,i) -> toName t (Nothing :: Maybe Module,i)

qualifyName :: Module -> Name -> Name
qualifyName m n = case nameParts n of
    (t,Nothing,n) -> toName t (Just m, n)
    _ -> n

setModule :: Module -> Name -> Name
setModule m n = qualifyName m  $ toUnqualified n

parseName :: NameType -> String -> Name
parseName t name = toName t (intercalate "." ms, intercalate "." (ns ++ [last sn])) where
    sn = (split (== '.') name)
    (ms,ns) = span validMod (init sn)
    validMod (c:cs) = isUpper c && all (\c -> isAlphaNum c || c `elem` "_'") cs
    validMod _ = False

nameType :: Name -> NameType
nameType (Name a) = toEnum $ fromIntegral ( a `unsafeByteIndex` 0) - ord '1'

nameName :: Name -> Name
nameName n = n

nameParts :: Name -> (NameType,Maybe Module,String)
nameParts n@(Name a) = f $ tail (fromAtom a) where
    f (';':xs) = (nameType n,Nothing,xs)
    f xs = (nameType n,Just $ Module (toAtom a),b) where
        (a,_:b) = span (/= ';') xs

instance Show Name where
    showsPrec _ n = case nameParts n of
        (QuotedName,Nothing,b) -> showChar '`' . showString b
        (_,Just a,b) -> shows a . showChar '.' . showString b
        (_,Nothing,b) -> showString b

instance DocLike d => PPrint d Name  where
    pprint n = text (show n)

mapName :: (Module -> Module,String -> String) -> Name -> Name
mapName (f,g) n = case nameParts n of
    (nt,Nothing,i) -> toName nt (g i)
    (nt,Just m,i) -> toName nt (Just (f m :: Module),g i)
mapName' :: (Maybe Module -> Maybe Module) -> (String -> String) -> Name -> Name
mapName' f g n = case nameParts n of
    (nt,m,i) -> toName nt (f m,g i)

ffiExportName :: FfiExport -> Name
ffiExportName (FfiExport cn _ cc _ _) = toName Val (Module "FE@", show cc ++ "." ++ cn)
type Class = Name

-------------
-- Quoting
-------------

quoteName :: Name -> Name
quoteName (Name n) = createUName QuotedName (fromAtom n)
fromQuotedName :: Name -> Maybe Name
fromQuotedName n = case nameParts n of
    (QuotedName,Nothing,s) -> Just $ Name (toAtom s)
    _ -> Nothing

--------------
-- Modules
--------------

newtype Module = Module Atom
  deriving(Eq,Data,Typeable,ToAtom,FromAtom)

instance Ord Module where
    compare x y = show x `compare` show y

instance Show Module where
    showsPrec _ (Module n) = shows n

fromModule (Module s) = fromAtom s

mainModule = Module "Main@"
primModule = Module "Prim@"
preludeModule = Module "Prelude"

toModule :: String -> Module
toModule s = Module $ toAtom s