NameMapsBaseStruct.hs

module NameMapsBaseStruct where
import NameMaps
import BaseSyntax
import HasBaseName
import MUtils
import DefinedNames -- because of tp, grr

--accNamesModule f (HsModule s m e i ds) = HsModule s m e i (accNames f ds)

instance (AccNames i e,AccNames i p,AccNames i ds, AccNames i t, AccNames i c)
       => AccNames i (EI i e p ds t c) where
  accNames f = accEI f m m m m m
    where m x = accNames f x

instance AccNames i p => AccNames i (PI i p) where
  accNames f = accPI f (accNames f)

instance (AccNames i e, AccNames i p, AccNames i ds, AccNames i t, AccNames i c,
	  AccNames i tp)
       => AccNames i (DI i e p ds t c tp) where
  accNames f = accDI f m m m m m m
    where m x = accNames f x

instance AccNames i t => AccNames i (TI i t) where
  accNames f = accTI f (accNames f)

instance AccNames i (HsIdentI i) where accNames = accHsIdent

-----------------------------------------------------------------------------
mapNamesModule2 d f (HsModule s mn e i ds) =
    HsModule s mn (m2 e) (m2 i) (m2 ds)
  where
    m2 x = mapNames2 d f x

{-
-- This could be error prone...
instance MapNames i1 (HsIdentI i1) i2 (HsIdentI i2) where
  mapNames = fmap
  --mapNames2  = ?? -- unknown namespace
-}

instance (HasBaseName m ModuleName, MapNames i1 ds1 i2 ds2)
      => MapNames i1 (HsModuleI m i1 ds1) i2 (HsModuleI m i2 ds2) where
  mapNames2 = mapNamesModule2

instance MapNames i1 (HsExportSpecI m i1) i2 (HsExportSpecI m i2) where
  mapNames2 dctx f@(vf,cf) e =
    case e of
      ModuleE mn -> ModuleE mn
      EntE e -> EntE (mapNames2 Export f e)

instance MapNames i1 (EntSpec i1) i2 (EntSpec i2) where
  mapNames2 dctx f@(vf,cf) e =
    -- pre: dctx==Export || dctx==Import m
    case e of
      Var i -> Var (vf eval i)
      Abs i -> Abs (cf etype i)
      AllSubs i -> AllSubs (cf etype i)
      ListSubs i is -> ListSubs (cf etype i) (map (subent i) is)
    where
      eval = (prim,ValueNames)
      etype = (prim,ClassOrTypeNames)
      subent i = both (sub i,ValueNames) mapHsIdent2 f

      prim = ent dctx Nothing
      sub  = ent dctx . Just

      ent Export = ExpEnt
      ent (Import m) = ImpEnt m
      ent _ = const Use -- entity specification in unexpected context!!

instance HasBaseName m ModuleName => 
         MapNames i1 (HsImportDeclI m i1) i2 (HsImportDeclI m i2) where
  mapNames2 dctx f (HsImportDecl s m q as optspec) =
      HsImportDecl s m q as (fmap (apSnd (mapNames2 d f)) optspec)
    where d = Import (getBaseName m)

instance (MapNames i1 e1 i2 e2,
	  MapNames i1 p1 i2 p2,
	  MapNames i1 ds1 i2 ds2,
	  MapNames i1 t1 i2 t2,
	  MapNames i1 c1 i2 c2)
       => MapNames i1 (EI i1 e1 p1 ds1 t1 c1)
		   i2 (EI i2 e2 p2 ds2 t2 c2) where
  mapNames2 dctx f e =
      case e of
        HsRecConstr s i fs -> HsRecConstr s (snd f useval i) (m fs)
        HsRecUpdate s e fs -> HsRecUpdate s (m e) (m fs)
        _ -> bothval mapEI2 f m mp ml ml ml e
    where
      m x = m' dctx x
      ml x = m' Local x
      mp x = m' Pattern x
      m' dctx = mapNames2 dctx f

instance MapNames i1 p1 i2 p2 => MapNames i1 (PI i1 p1) i2 (PI i2 p2) where
  mapNames2 dctx f@(vf,cf) p =
    case p of
      HsPRec i p -> HsPRec (snd f useval i) (m p)
      _ -> mapPI2 vf' (cf useval) m p
    where
      m x = mapNames2 dctx f x
      --vf' = vf (defval dctx)
      vf' = case dctx of ClassDef _ -> vf useval
			 _ -> vf (defval dctx)

instance MapNames i1 e1 i2 e2
      => MapNames i1 (HsFieldI i1 e1) i2 (HsFieldI i2 e2) where
  mapNames2 dctx f = mapFieldI (fst f (FieldLabel,ValueNames)) m
    where
      m = mapNames2 dctx f

-- All identifiers i in EI i ... and PI i p denote values
-- All identifiers i in TI i t denote types 

instance (MapNames i1 e1 i2 e2,
	  MapNames i1 p1 i2 p2,
	  MapNames i1 ds1 i2 ds2,
	  MapNames i1 t1 i2 t2,
	  MapNames i1 c1 i2 c2,
	  MapNames i1 tp1 i2 tp2,
	  DefinedNames i1 t1,
	  DefinedNames i1 tp1)
       => MapNames i1 (DI i1 e1 p1 ds1 t1 c1 tp1)
		   i2 (DI i2 e2 p2 ds2 t2 c2 tp2) where
  mapNames2 dctx f@(vf,cf) d =
      case d of
        HsTypeDecl s tp t -> HsTypeDecl s (m tp) (ml t)
        HsNewTypeDecl s ctx tp cd ns ->
             HsNewTypeDecl s (ml ctx) (m tp) (map2conD cd) (map tconf ns)
        HsDataDecl s ctx tp cds ns  ->
             HsDataDecl s (ml ctx) (m tp) (map map2conD cds) (map tconf ns)
	HsClassDecl s ctx tp fdeps ds ->
	    HsClassDecl s (ml ctx) (m tp) (mapFunDeps tvarf fdeps) (mc c1 ds)
	  where c1 = definedType tp 
        HsInstDecl s optn ctx tp ds ->
	     HsInstDecl s (fmap vdef optn) (ml ctx) (ml tp) (mi c1 ds)
	  where c1 = definedType tp 
		--c2 = tconf c1
	HsDefaultDecl s ts -> HsDefaultDecl s (ml ts)
	HsTypeSig s is ctx tp -> HsTypeSig s (map vf is) (ml ctx) (ml tp)
          where
	    vf = case dctx of ClassDef _ -> vdef
	                      _          -> vsig
	HsInfixDecl s fixity is ->
            HsInfixDecl s fixity (map (bothsigval mapHsIdent2 f) is)
        HsFunBind s ms -> HsFunBind s (m ms)
        HsPrimitiveTypeDecl s ctx tp  ->
            HsPrimitiveTypeDecl s (ml ctx) (m tp)
	HsPrimitiveBind s i tp -> HsPrimitiveBind s (vdef i) (ml tp)
        _ -> bothval mapDI2 f m m ml m m m d
    where
      m x = m' dctx x
      mc c x = m' (ClassDef c) x
      mi c x = m' (Instance c) x
      ml x = m' Local x
      m' dctx = mapNames2 dctx f
      tconf = cf usetype
      tvarf = vf usetype
      --vuse = vf useval
      vdef  = vf (defval dctx)
      vsig  = vf (sigval dctx)
      cdef  = cf (defval dctx)
      --bothdefval = both (defval dctx)
      bothsigval = both (sigval dctx)

      map2conD (HsConDecl s is c n args) =
          HsConDecl s (localq f is) (ml c) (cdef n) (ml args)
      map2conD (HsRecDecl s is c n fields) =
          HsRecDecl s (localq f is) (ml c) (cdef n) (map mf fields)
        where
          mf (is,t) = (map vdef is,ml t)

instance MapNames i1 t1 i2 t2
      => MapNames i1 (HsBangType t1) i2 (HsBangType t2) where
  mapNames2 dctx f = mapBangType (mapNames2 dctx f)

instance (MapNames i1 e1 i2 e2,
	  MapNames i1 p1 i2 p2,
	  MapNames i1 ds1 i2 ds2)
       => MapNames i1 (HsMatchI i1 e1 p1 ds1)
		   i2 (HsMatchI i2 e2 p2 ds2) where
  mapNames2 dctx f@(vf,_) (HsMatch s n ps rhs ds) =
      HsMatch s (vf' n) (mp ps) (mapRhs m rhs) (ml ds)
    where
      vf' = case dctx of ClassDef _ -> vuse
			 --Instance _ -> vdef
			 _ -> vdef
      m x = m' dctx x
      ml x = m' Local x
      mp x = m' Pattern x
      m' dctx = mapNames2 dctx f
      vdef = vf (defval dctx)
      vuse = vf useval

instance MapNames i1 t1 i2 t2 => MapNames i1 (TI i1 t1) i2 (TI i2 t2) where
  mapNames2 dctx f@(vf,cf) t =
      case t of
        HsTyForall vs ps t' -> HsTyForall (localq f vs) (m ps) (m t')
        _ -> mapTI2 vf' cf' (mapNames2 dctx f) t
    where
      m x = mapNames2 dctx f x

      (vf',cf') = case dctx of
		    Local -> (vf usetype,cf usetype)
		    _     -> (vf (deftype Pattern),cf (deftype dctx))

localq (vf,_) = map (vf (deftype Pattern))

--------------------------------------------------------------------------------

instance SeqNames m ds1 ds2
      => SeqNames m (HsModuleI mn (m i) ds1) (HsModuleI mn i ds2) where
  seqNames (HsModule s m e i ds) =
     HsModule s m # seqNames e <# seqNames i <# seqNames ds

instance (Functor m,Monad m) => SeqNames m (EntSpec (m i)) (EntSpec i) where
  seqNames = seqEntSpec

instance (Functor m,Monad m)
      => SeqNames m (HsImportDeclI mn (m i)) (HsImportDeclI mn i) where
  seqNames = seqImportDecl

instance (Functor m,Monad m)
      => SeqNames m (HsExportSpecI mn (m i)) (HsExportSpecI mn i) where
  seqNames = seqExportSpec

instance (SeqNames m e1 e2,SeqNames m p1 p2,SeqNames m ds1 ds2,
          SeqNames m t1 t2,SeqNames m c1 c2)
      => SeqNames m (EI (m i) e1 p1 ds1 t1 c1) (EI i e2 p2 ds2 t2 c2) where
  seqNames = seqEI . mapEI id sn sn sn sn sn

instance SeqNames m p1 p2 => SeqNames m (PI (m i) p1) (PI i p2) where
  seqNames = seqPI . mapPI id sn

instance (SeqNames m e1 e2,SeqNames m p1 p2,SeqNames m ds1 ds2,
          SeqNames m t1 t2,SeqNames m c1 c2,SeqNames m tp1 tp2)
      => SeqNames m (DI (m i) e1 p1 ds1 t1 c1 tp1) (DI i e2 p2 ds2 t2 c2 tp2) where
  seqNames = seqDI . mapDI id sn sn sn sn sn sn

instance SeqNames m t1 t2 => SeqNames m (TI (m i) t1) (TI i t2) where
  seqNames = seqTI . mapT sn

r x = return x
sn x = seqNames x
--------------------------------------------------------------------------------