FreeNamesBaseStruct.hs

module FreeNamesBaseStruct where

import FreeNames
import DefinedNames(DefinedNames)

import BaseSyntax
import Lists((\\\))
import List(nub)
import TypedIds
--import AccList(accList)

import HsName


-- modules (computes names that need to be imported)

instance FreeNames i ds => FreeNames i (HsModuleI m i ds) where
  freeNames = freeNames . hsModDecls

instance FreeNames i p => FreeNames i (PI i p) where
    freeNames p =
      case p of
        HsPRec i fs -> con i : freeNames fs
        _           -> accPI2 (const id) ((:).con) ((++).freeNames) p []

-- freeNotDef p = freeNames p \\\ defs p

-- record fields
instance FreeNames i p => FreeNames i (HsFieldI i p) where
  freeNames (HsField f p) = field f:freeNames p


-- rhss
instance FreeNames i e => FreeNames i (HsRhs e) where
    freeNames x = accRhs (++) (mapRhs freeNames x) []

-- alts
instance (FreeNames i e, FreeNames i p, FreeNames i ds,
         DefinedNames i ds, DefinedNames i p)
      => FreeNames i (HsAlt e p ds) where
    freeNames (HsAlt _ p rhs ds) 
        = freeNames p ++ (freeNames (rhs,ds) \\\ defs (ds,p))

-- stmts
instance ( FreeNames i e, FreeNames i p, FreeNames i ds
         , DefinedNames i p, DefinedNames i ds
         ) => FreeNames i (HsStmt e p ds) where
    freeNames stmt =
      case stmt of
        HsGenerator _ p e stmt -> freeNames (p,e) ++ (freeNames stmt \\\ defs p)
        HsQualifier   e stmt -> freeNames (e,stmt)
        HsLetStmt    ds stmt -> freeNames (stmt,ds) \\\ defs ds
        HsLast        e      -> freeNames e


-- Since this is not a strictly accumulating function, there are many cases
-- in which accE can not be used...

-- exps
instance ( FreeNames i e, FreeNames i p, FreeNames i ds
         , FreeNames i t, FreeNames i c 
         , DefinedNames i p, DefinedNames i ds 
         ) => FreeNames i (EI i e p ds t c) where
    freeNames e =
      case e of
        HsLambda ps e          -> freeNames ps ++ (freeNames e \\\ defs ps)
        HsLet ds e             -> freeNames (e,ds) \\\ defs ds
        HsId n                 -> [val n]
        HsInfixApp x op z      -> val op : freeNames (x,z)
        HsCase e alts          -> freeNames (e,alts)
        HsDo stmts             -> freeNames stmts
        HsLeftSection x op     -> val op : freeNames x
        HsRightSection op y    -> val op : freeNames y
        HsListComp stmts       -> freeNames stmts
	HsRecConstr s n fs     -> con n : freeNames fs
	HsRecUpdate s e fs     -> freeNames (e,fs)

        _                      ->
            accEI bug descend bug bug descend descend e []
        where
	descend s = ((++).freeNames) s
        bug = error "freeNames at E ...: should have been handled"

-- matches
instance ( FreeNames i e, FreeNames i p, FreeNames i ds
         , DefinedNames i ds, DefinedNames i p 
         ) => FreeNames i (HsMatchI i e p ds) where
    freeNames (HsMatch _ n ps rhs ds) =
        freeNames ps ++ ((freeNames (rhs,ds) \\\ defs ps) 
                                \\\ (val (HsVar n) : defs ds))

-- decls 
instance ( FreeNames i e, FreeNames i p, FreeNames i ds, FreeNames i t
         , FreeNames i c, FreeNames i tp
         , DefinedNames i p, DefinedNames i ds 
         ) => FreeNames i (DI i e p ds t c tp) where
    freeNames d =
	case d of
	  HsTypeDecl s tps t             -> freeNames t \\\ freeNames tps
	  HsNewTypeDecl s ctx tps cd drv -> dataNames ctx tps [cd] drv
	  HsDataDecl s ctx tps cds drv   -> dataNames ctx tps cds  drv
	  HsClassDecl s c tp fdeps ds    -> freeNames (c,ds) \\\ freeNames tp -- hmm
	  HsInstDecl s optn c tp ds      -> freeNames ((c,tp),ds) \\\ freeVars tp -- hmm
	  HsDefaultDecl s t              -> freeNames t
	  HsTypeSig s nms c tp           -> freeCons (c,tp)
	  HsFunBind s matches            -> freeNames matches
	  HsPatBind s p rhs ds           -> freeNames p ++ 
					      (freeNames (rhs,ds) \\\ defs (p,ds))
	  HsInfixDecl   s fixity names   -> []

  --      HsPrimitiveTypeDecl s cntxt nm   ->
  --      HsPrimitiveBind s nm t           ->

	  -- TODO
	  _                               -> []
      where
        dataNames ctx tps cds drv =
          nub (map tcon drv++freeNames (ctx,cds)) \\\ freeNames tps

instance (FreeNames i t,FreeNames i c) => FreeNames i (HsConDeclI i t c) where
  freeNames cd =
    case cd of 
      HsConDecl s is c n args -> freeNames (c,args) \\\ map tvar is
      HsRecDecl s is c n fields -> freeNames (c,map snd fields) \\\ map tvar is

instance FreeNames i t => FreeNames i (HsBangType t) where
  freeNames = freeNames . unbang

instance FreeNames i t => FreeNames i (TI i t) where
  freeNames t =
    case t of
      HsTyVar v -> [tvar v]
      HsTyCon v -> [tcon v]
      HsTyForall xs ps t -> freeNames (ps,t) \\\ map tvar xs
      _ -> crushT freeNames t


-- utils ---------------------------------------

field = var -- hmm!!