module HsName where

import Char(isAlpha,isUpper)
import List(intersperse,isPrefixOf,isSuffixOf)
import PrettyPrint

data ModuleName
  = PlainModule String
  | MainModule FilePath
  deriving (Eq, Ord, Show, Read)

moduleName path "Main" = MainModule path
moduleName  _   s      = PlainModule s

plainModule s | s/="Main" = PlainModule s 

isMainModule (MainModule _) = True
isMainModule _ = False

isHierarchical (PlainModule s) = '.' `elem` s
isHierarchical _ = False

sameModuleName "Main" (MainModule _)   = True
sameModuleName s      (PlainModule s') = s==s'
sameModuleName _ _ = False

fakeModule = PlainModule
  -- used by the type checker to create unique variables like t.1, t.2, d.1, d.2

noModule = fakeModule "noModule" -- not a valid module name

{-
instance Show ModuleName where
  showsPrec n (Module s) = showsPrec n s
instance Read ModuleName where
  readsPrec n s = [(Module m,r)|(m,r)<-readsPrec n s]
-}

{-#
Identifiers
===========
-}
type Id = String


data HsName
    = Qual ModuleName Id
    | UnQual Id
      deriving (Eq, Ord, Show, Read)

hsUnQual = accHsName id

--- Map, Acc &amp; Seq for the HsName functor --------------------------------------

mapHsName idf (Qual q id) = Qual q (idf id)
mapHsName idf (UnQual id) = UnQual (idf id)

accHsName idf (Qual q id) = idf id -- ??
accHsName idf (UnQual id) = idf id

--- Parsing pretty-printed module names ----------------------------------------

parseModuleName m =
    if "Main{-" `isPrefixOf` m && "-}" `isSuffixOf` m
    then MainModule . reverse . drop 2 . reverse . drop 6 $ m
    else PlainModule m

--- Pretty printing for HsName and Module --------------------------------------

instance Printable ModuleName where
    ppi (PlainModule m)   = ppi m
    ppi (MainModule path) = "Main"<>cmnt ("{-"<>path<>"-}")
    wrap                  = ppi

instance Printable HsName where
    ppi (Qual (PlainModule "Prelude") "[]") = ppi "[]" -- hack
    ppi (Qual (PlainModule "Prelude") "()") = ppi "()" -- hack
    ppi (Qual (PlainModule "Prelude") "(,)") = ppi "(,)" -- hack
    ppi (Qual (PlainModule "Prelude") "->") = ppi "(->)" -- hack
    ppi (Qual q id) = q <> '.' <> id
    ppi (UnQual id) = ppi id

    wrap n | isSymbolOp n = parens n
           | otherwise    = ppi n

instance PrintableOp HsName where
    isOp = isSymbolOp
    ppiOp n = if isAlphaOp n
	      then backQuotes n
	      else ppi n

isSymbolOp, isAlphaOp, isConOp :: HsName -> Bool
isSymbolOp = isSymbol . head . hsUnQual
isAlphaOp  = isAlpha  . head . hsUnQual
isConOp    =  (==':') . head . hsUnQual

ppInfixOp n = ppiOp n
ppInfixName n = ppiOp n

isSymbol c = elem c ":!#$%&*+./<=>?@\\^|-~"

--- Extra stuff for heirarchical module names ----------------------------------

splitQualName path = uncurry (Qual . moduleName path) . splitQualName'

{-
-- Haskell 98 version:
splitQualName' s = Qual (Module m) n
  where (m,'.':n) = break (=='.') s
-}

-- For the "hierachical module name" extension:
splitQualName' s = (m,n)
  where
    m = concat (intersperse "." (init parts))
    n = last parts
    parts = chop s

    chop "" = []
    chop ('.':s@(c:_)) = if isUpper c
			 then []:chop s
			 else []:[s]
    chop (c:s) = 
	  case chop s of
	    [] -> [[c]]
	    s:ss -> (c:s):ss