SourceNames.hs

module SourceNames where
import HsName(Id,HsName(..),hsUnQual,ModuleName(..),moduleName)
import SrcLoc(SrcLoc,loc0,srcFile)
import qualified SrcLoc as L
import PrettyPrint
import PrettyUtil(ppqIfDebug)
import HasBaseName
import UniqueNames
import QualNames
import SpecialNames

import Char(isUpper)

data SN i = SN i SrcLoc

instance Show i => Show (SN i) where
  showsPrec p (SN i _) = showsPrec p i

instance Read i => Read (SN i) where
  readsPrec p s = [(SN i loc0,r)|(i,r)<-readsPrec p s]

instance Unique (SN HsName) where
  unique m (SN n p) = G m (hsUnQual n) (srcLoc p)

instance Unique (SN Id) where
  unique m (SN n p) = G m n (srcLoc p)

--srcName (PN n _) = SN n loc0 -- a temporary hack (I hope)
srcName n = SN (getBaseName n) (L.srcLoc n)
fakeSN n = SN n loc0

instance HasBaseName (SN i) i where getBaseName (SN i _) = i

instance Eq i  => Eq  (SN i) where SN n1 _==SN n2 _ = n1==n2
instance Ord i => Ord (SN i) where compare (SN n1 _) (SN n2 _) = compare n1 n2

instance Functor SN where fmap f (SN i o) = SN (f i) o

instance QualNames qn m n => QualNames (SN qn) m (SN n) where
    getQualifier                = getQualifier . getBaseName
    getQualified                = fmap getQualified

    mkUnqual                    = fmap mkUnqual
    mkQual m                    = fmap (mkQual m)

instance HasSpecialNames i => HasSpecialNames (SrcLoc->SN i) where
  list_tycon_name = SN list_tycon_name
  fun_tycon_name = SN fun_tycon_name
  char_tycon_name = SN char_tycon_name
  tuple_tycon_name = SN . tuple_tycon_name

instance IsSpecialName i => IsSpecialName (SN i) where
  is_list_tycon_name (SN i _) = is_list_tycon_name i
  is_fun_tycon_name (SN i _) = is_fun_tycon_name i
  is_char_tycon_name (SN i _) = is_char_tycon_name i
  is_tuple_tycon_name n (SN i _) = is_tuple_tycon_name n i

---

instance Printable   i => Printable   (SN i) where
  ppi (SN n p) = ppi n<>ppqIfDebug p
  wrap (SN n p) = wrap n<>ppqIfDebug p

            -- positions ends up outside parenthesis...

instance PrintableOp i => PrintableOp (SN i) where
  isOp (SN n p) = isOp n
  ppiOp (SN n p) = ppiOp n<>ppqIfDebug p


hsName2modName (SN hs loc) =
  case hs of
    UnQual m -> return (SN (moduleName (srcFile loc) m) loc)
    Qual m n@(c:_) ->
	 if isUpper c
         then return (SN (PlainModule (mn m++"."++n)) loc)
         else fail "Invalid hierarchical module name"
       where mn (PlainModule s) = s
             mn (MainModule _) = "Main"