ScopeNamesBaseStruct.hs

module ScopeNamesBaseStruct where
import ScopeNames
import DefinedNames
import DefinedNamesBaseStruct()
import FreeNames
import BaseSyntax
import MUtils
import EnvM

instance ScopeNames i e ds1 ds2
      => ScopeNames i e (HsModuleI m i ds1) (HsModuleI m (i,e) ds2) where
  scopeNames ext (HsModule s m e i ds) = HsModule s m # sc e <# sc i <# sc ds
    where sc x = scopeNames ext x

instance ScopeNames i e (HsExportSpecI m i) (HsExportSpecI m (i,e)) where
  scopeNames = scopeSpec

instance ScopeNames i e (HsImportSpecI i) (HsImportSpecI (i,e)) where
  scopeNames = scopeSpec

instance ScopeNames i e (HsImportDeclI m i) (HsImportDeclI m (i,e)) where
  scopeNames = scopeSpec -- uses the wrong environment!!!

scopeSpec ext spec = do env <- getEnv ; return (fmap (\i->(i,env)) spec)

pairEnv x = (,) x # getEnv

instance (Eq i,
	  ScopeNames i e e1 e2,
	  ScopeNames i e p1 p2,DefinedNames i p1,
	  ScopeNames i e ds1 ds2,DefinedNames i ds1,
	  ScopeNames i e t1 t2,FreeNames i t1,
	  ScopeNames i e c1 c2,FreeNames i c1)
       => ScopeNames i e (EI i e1 p1 ds1 t1 c1)
		         (EI (i,e) e2 p2 ds2 t2 c2) where
  scopeNames ext e =
    case e of
      HsLambda ps e        -> ex ps (HsLambda # sc ps <# sc e)
      HsLet ds e           -> ex ds (HsLet    # sc ds <# sc e)
      HsCase e alts        -> HsCase # sc e <# sc alts
      HsDo stmts           -> HsDo # sc stmts
      HsListComp stmts     -> HsListComp # sc stmts
      HsExpTypeSig s e c t -> HsExpTypeSig s # sc e <# ex (sc c) <# ex (sc t)
        where ex = exttvar ext (c,t)
      _ -> seqEI . mapEI pairEnv sc sc sc sc sc $ e
    where
      sc x = scopeNames ext x
      ex b = extdef ext b

extdef ext b = inModEnv . ext $ definedNames b
exttvar ext b = inModEnv . ext $ freeTyvars b
exttvs ext = inModEnv . ext . map (typedTvar . HsVar)

instance (ScopeNames i e e1 e2,
	  ScopeNames i e p1 p2,DefinedNames i p1,
	  ScopeNames i e ds1 ds2,DefinedNames i ds1)
      => ScopeNames i e (HsStmt e1 p1 ds1) (HsStmt e2 p2 ds2) where
  scopeNames ext stmt =
    case stmt of
      HsGenerator s p e stmt -> HsGenerator s # ex p (sc p) <# sc e <# ex p (sc stmt)
      HsQualifier e stmt -> HsQualifier # sc e <# sc stmt
      HsLetStmt ds stmt -> ex ds $ HsLetStmt # sc ds <# sc stmt
      HsLast e -> HsLast # sc e
    where
      sc x = scopeNames ext x
      ex b = extdef ext b

instance (ScopeNames i e e1 e2,
	  ScopeNames i e p1 p2,DefinedNames i p1,
	  ScopeNames i e ds1 ds2,DefinedNames i ds1)
	  => ScopeNames i e (HsAlt e1 p1 ds1) (HsAlt e2 p2 ds2) where
  scopeNames ext (HsAlt s p rhs ds) =
      HsAlt s # ex p (scopeNames ext p) <# r rhs <# r ds
    where
      r x = ex (p,ds) (sc x)
      sc x = scopeNames ext x
      ex b = extdef ext b

instance (ScopeNames i e e1 e2,
	  ScopeNames i e p1 p2,DefinedNames i p1,
	  ScopeNames i e ds1 ds2,DefinedNames i ds1)
	  => ScopeNames i e (HsMatchI i e1 p1 ds1) (HsMatchI (i,e) e2 p2 ds2) where
  scopeNames ext (HsMatch s i ps rhs ds) =
      HsMatch s # pairEnv i <# ex ps (scopeNames ext ps) <# r rhs <# r ds
    where
      r x = ex (ps,ds) (sc x)
      sc x = scopeNames ext x
      ex b = extdef ext b

instance ScopeNames i e e1 e2 => ScopeNames i e (HsRhs e1) (HsRhs e2) where
  scopeNames ext = seqRhs . mapRhs (scopeNames ext)

instance ScopeNames i e p1 p2
      => ScopeNames i e (PI i p1) (PI (i,e) p2) where
  scopeNames ext = seqPI . mapPI pairEnv (scopeNames ext)

instance (Eq i,
	  ScopeNames i e e1 e2,
	  ScopeNames i e p1 p2,DefinedNames i p1,
	  ScopeNames i e ds1 ds2,DefinedNames i ds1,
	  ScopeNames i e t1 t2,FreeNames i t1,
	  ScopeNames i e c1 c2,FreeNames i c1,
	  ScopeNames i e tp1 tp2,FreeNames i tp1)
       => ScopeNames i e (DI i e1 p1 ds1 t1 c1 tp1)
		         (DI (i,e) e2 p2 ds2 t2 c2 tp2) where
  scopeNames ext d =
      case d of
       HsTypeDecl s tps t             -> st tps
       HsNewTypeDecl s ctx tps cd drv ->
         HsNewTypeDecl s # mr ctx <# mr tps <# mr cd <# mapM pairEnv drv
           where mr x = exttvar ext tps $ m x
       HsDataDecl s ctx tps cds drv   ->
         HsDataDecl s # mr ctx <# mr tps <# mr cds <# mapM pairEnv drv
           where mr x = exttvar ext tps $ m x
       HsClassDecl s c tp fdeps ds    -> st tp -- hmm, fdeps
		         -- !!  ^^ Hmm, typevars in type sigs ds
       HsInstDecl s optn c tp ds      -> st (c,tp)
       HsTypeSig s nms c tp           -> st (c,tp)
       HsFunBind s ms -> HsFunBind s # mapM m ms
       HsPatBind s p rhs ds -> HsPatBind s # m p <# mr rhs <# mr ds
          where mr x = extdef ext ds $ m x
		--                ^^ not (p,ds)
		-- The variables in p are added to the environment before
		-- entering the declaration group this binding is part of,
		-- and should not be added again.
       HsPrimitiveTypeDecl s ctx tp   -> st tp
       HsPrimitiveBind s nm tp        -> st tp
       _ -> scAll
    where
      st tp = exttvar ext tp scAll
      scAll = seqDI $ mapDI pairEnv m m m m m m d
      m x = scopeNames ext x

instance (ScopeNames i e t1 t2,ScopeNames i e c1 c2)
      => ScopeNames i e (HsConDeclI i t1 c1) (HsConDeclI (i,e) t2 c2) where
  scopeNames ext d =
    case d of
      HsConDecl s vs ectx c args -> st vs
      HsRecDecl s vs ectx c fields -> st vs
    where
      st vs = exttvs ext vs scAll
      scAll = seqConDecl $ mapConDeclI pairEnv m m d
      m x = scopeNames ext x

instance ScopeNames i e t1 t2
      => ScopeNames i e (TI i t1) (TI (i,e) t2) where
  scopeNames ext t =
      case t of
        HsTyForall vs ps t' -> exttvs ext vs scAll
	_ -> scAll
    where
      scAll = seqTI $ mapTI pairEnv m t
      m x = scopeNames ext x 

freeTyvars tp = [typedTvar i|(i@(HsVar _),_)<-freeNames tp]

typedTvar i = (i,Type blankTypeInfo)