NameMaps.hs

module NameMaps(module NameMaps,NameSpace(..)) where
--import StateM
import MUtils
import Recursive
import AccList
import HsName(ModuleName)
import TypedIds(NameSpace(..))

class AccNames i s | s->i where
  accNames :: (i->a->a)->s->a->a

-- Auxiliary types for the MapNames class:

data Context i = TopLevel | Local | ClassDef i | Instance i | Pattern
               | Export | Import ModuleName
               --deriving (Show)

data Role i = Def (Context i) | Sig (Context i) | Use | Logic | FieldLabel
            | ExpEnt (Maybe i)  --Just i=subordinate to i
            | ImpEnt ModuleName (Maybe i)  --Just i=subordinate to i
            --deriving (Show)

type Occurence i = (Role i,NameSpace)

instance Functor Context where
  fmap f c = case c of
	       TopLevel -> TopLevel
	       Local -> Local
	       ClassDef i -> ClassDef (f i)
	       Instance i -> Instance (f i)
	       Pattern -> Pattern

instance Functor Role where
  fmap f (Def c) = Def (fmap f c)
  fmap f (Sig c) = Sig (fmap f c)
  fmap f Use = Use
  fmap f Logic = Logic
  fmap f FieldLabel = FieldLabel
  fmap f (ExpEnt opti) = ExpEnt (fmap f opti)
  fmap f (ImpEnt m opti) = ImpEnt m (fmap f opti)

class MapNames i1 s1 i2 s2 | s1->i1,s1 i2->s2,s2->i2 where
  mapNames2 :: Context i1 ->
               (Occurence i1->i1->i2,Occurence i1->i1->i2) -> s1 -> s2
            -- (variables           ,constructors        )
  mapNames :: (i1->i2) -> s1 -> s2
  mapNames f = mapNames2 TopLevel (const f,const f)

class (Monad m,Functor m) => SeqNames m s1 s2 | s1->m s2 where
  seqNames :: s1 -> m s2

instance AccNames i s => AccNames i [s] where
  accNames = accList . accNames

instance (AccNames i a,AccNames i b) => AccNames i (a,b) where
  accNames f (a,b) = accNames f a . accNames f b

instance (AccNames i a,AccNames i b,AccNames i c) => AccNames i (a,b,c) where
  accNames f (a,b,c) = accNames f a . accNames f b . accNames f c

instance MapNames i1 s1 i2 s2 => MapNames i1 [s1] i2 [s2] where
  mapNames2 dctx = map . mapNames2 dctx
  mapNames = map . mapNames

instance MapNames i1 s1 i2 s2 => MapNames i1 (Maybe s1) i2 (Maybe s2) where
  mapNames2 dctx = fmap . mapNames2 dctx
  mapNames = fmap . mapNames

instance (MapNames i1 a1 i2 a2,MapNames i1 b1 i2 b2)
      => MapNames i1 (a1,b1) i2 (a2,b2) where
  mapNames2 dctx f (a,b) = (mapNames2 dctx f a,mapNames2 dctx f b)
  mapNames f (a,b) = (mapNames f a,mapNames f b)

instance SeqNames m s1 s2 => SeqNames m [s1] [s2] where
  seqNames = mapM seqNames

instance SeqNames m s1 s2 => SeqNames m (Maybe s1) (Maybe s2) where
  seqNames = seqMaybe . fmap seqNames

instance (SeqNames m a1 a2,SeqNames m b1 b2)
      => SeqNames m (a1,b1) (a2,b2) where
  seqNames (a1,a2) = (,) # seqNames a1 <# seqNames a2

accNamesRec f = accNames f . struct
mapNames2Rec dctx f = rec . mapNames2 dctx f . struct
seqNamesRec x = rec # seqNames (struct x)

mapNamesM f = seqNames . mapNames f
mapNames2M ctx f = seqNames . mapNames2 ctx f

--- utilities

pat ctx g (vf,cf) = g (vf (defval ctx)) (cf useval)
bothval = both  useval
bothtype = both (Use,ClassOrTypeNames)
both x g (f1,f2) = g (f1 x) (f2 x)
useval=(Use,ValueNames)
usetype=(Use,ClassOrTypeNames)
defval ctx=(Def ctx,ValueNames)
sigval ctx=(Sig ctx,ValueNames)
deftype ctx=(Def ctx,ClassOrTypeNames)