content: -- $Id: ScopeRec.hs,v 1.1 2001/07/24 17:39:10 moran Exp $
  
  module ScopeRec where 
  
  import Syntax
  import List(find, nub, nubBy, (\\), sortBy, groupBy, union)
  --import Observe
  import PrettyPrint
  import Maybe
  import IOExts
  import SyntaxUtil(isTyVar, getTyName)
  import Scope2
  import HsConstants
  import ScopeStruct
  
  names :: HsDecl -> Senv
  names (Dec d) = namesD d
  
  dataName (HsConDecl s nm slots) = (nm, s, length slots)
  dataName (HsRecDecl s nm slots) = (nm, s, length slots)
  
  recordName :: HsConDecl t -> [(HsName, SrcLoc)] 
  recordName (HsConDecl s nm slots) = []
  recordName (HsRecDecl s nm slots) = foldr f [] slots
      where f (names,domain) xs = map (\nm -> (nm,s)) names ++ xs
    
  allNames :: [HsDecl] -> Senv -> Senv  
  allNames ds initial = foldr acc initial ds
    where acc d env = concatEnv (names d) env 
  
  
  ----------------------------------------------------------------------         
  -- Generic Static checking functions
  
  duplicates :: Eq a => [a] -> [a]
  duplicates [] = []
  duplicates (x:xs) = 
    if elem x xs then x : (duplicates (filter (/=x) xs)) else (duplicates xs)
  
  collect_duplicate_info :: ([a] -> [b]) -> (a -> a -> Ordering) -> [a] -> [b]
  collect_duplicate_info infof compare = 
    concat . (map infof) . (groupBy (lift compare)) . (sortBy compare)
      where lift g x y = case g x y of { EQ -> True; _ -> False }
  
  dupErrs :: (Show a, Show b) => b -> [(a,SrcLoc)] -> [Error]
  dupErrs sort [] = []
  dupErrs sort [x] =[]
  dupErrs sort xs@((nm,loc):_) = chk loc True (duplicate_things sort nm (map snd xs))
  
  dupTvErr srcloc [x]    = []
  dupTvErr srcloc (x:xs) = [(srcloc, duplicate_type_vars x)]
  
  chk:: SrcLoc -> Bool -> String -> [Error]
  chk loc test message = if test then [(loc,message)] else []
  
  unique :: Eq a => [(a,b)] -> [(a,b)]
  unique = nubBy (\(a,_) (b,_) -> a==b)
  
  
  ------------------------------------------------------------------------------
  -- Scope checking 
  ------------------------------------------------------------------------------
  nmConflict :: Senv -> [Error]
  nmConflict env = 
      let ts = tconstrNames env 
          cs = classNames env
          sameName (tn,tloc,_,_) errs =
            case find (\(a,_,_,_) -> a==tn) cs of 
              Nothing           -> errs
              Just (_,cloc,_,_) -> (tloc, type_class_conflict tn [tloc,cloc]) : errs
      in  foldr sameName [] ts
  
  classMethodErr :: Senv -> [Error]
  classMethodErr env = 
     let ss = sigNames env
         vs = varNames env
         sigExists (vn,vloc) errs =
           case find (\(a,_) -> a==vn) ss of
             Nothing      -> (vloc, method_without_signature vn) : errs
             Just _       -> errs
     in  foldr sigExists [] vs
  
  type_class_conflict tn cloc = 
    "Type name " ++ pp tn ++ " is used as class name "++ pp cloc 
  method_without_signature vn = 
    "Definition of " ++ pp vn  ++ " without declaration"
  
  
  
  getClass (Typ (HsTyApp x _)) = getClass x
  getClass (Typ (HsTyCon c))   = Just c
  getClass _                   = Nothing
  
  
  allTypNames (Typ (HsTyVar v)) (vs, cs) = (v : vs, cs)
  allTypNames (Typ (HsTyCon c)) (vs, cs) = (vs,     c : cs)
  allTypNames (Typ t)           ans      = accT allTypNames t ans
  
  isTyConApp (Typ (HsTyCon _))   = True
  isTyConApp (Typ (HsTyApp f _)) = isTyConApp f
  isTyConApp _                   = False
  
  getTyAppArgs (Typ (HsTyCon _))   args = args
  getTyAppArgs (Typ (HsTyApp f x)) args = getTyAppArgs f (x:args)
  
  -- Well formed type expression: C x*
  wfTp :: SrcLoc -> TPContext -> HsType -> [Error] -> [Error]
  wfTp srcloc c t errs =
      if isTyConApp t && all isTyVar (getTyAppArgs t []) then
          errs
      else
          (srcloc, type_former_is_not_constructor t c) : errs
  
  -- well formed simple class specification: C x+
  wfSclass :: SrcLoc -> HsType -> [Error] -> [Error]
  wfSclass loc t errs =
      if isTyConApp t && not (null args) && all isTyVar args then
          errs
      else
          (loc, illformed_sclass t) : errs
      where args = getTyAppArgs t []
  
   
  
  -------------------------------------------------------------------------
  
  srcloc (HsTypeDecl          loc  _ _     ) = loc
  srcloc (HsNewTypeDecl       loc  _ _ _ _ ) = loc
  srcloc (HsDataDecl          loc  _ _ _ _ ) = loc
  srcloc (HsClassDecl         loc  _ _ _   ) = loc
  srcloc (HsInstDecl          loc  _ _ _   ) = loc
  srcloc (HsDefaultDecl       loc  _       ) = loc
  srcloc (HsTypeSig           loc  _ _ _   ) = loc
  srcloc (HsFunBind           loc  _       ) = loc
  srcloc (HsPatBind           loc  _ _ _   ) = loc
  srcloc (HsPrimitiveTypeDecl loc  _ _     ) = loc
  srcloc (HsPrimitiveBind     loc  _ _     ) = loc
  
  whatIs (HsTypeDecl          _  _ _     ) = "type declaration"
  whatIs (HsNewTypeDecl       _  _ _ _ _ ) = "newtype declaration"
  whatIs (HsDataDecl          _  _ _ _ _ ) = "data declaration"
  whatIs (HsClassDecl         _  _ _ _   ) = "class declaration"
  whatIs (HsInstDecl          _  _ _ _   ) = "instance declaration"
  whatIs (HsDefaultDecl       _  _       ) = "declaration"
  whatIs (HsTypeSig           _  _ _ _   ) = "type signature"
  whatIs (HsFunBind           _  _       ) = "function binding"
  whatIs (HsPatBind           _  _ _ _   ) = "pattern binding"
  whatIs (HsPrimitiveTypeDecl _  _ _     ) = "declaration"
  whatIs (HsPrimitiveBind     _  _ _     ) = "declaration"
  
  
  --------------------------------------------------------------
  -- The first kind of scoping and its combinators
  --------------------------------------------------------------
  
  scopE :: v -> E (v -> e) (v->v,v -> p) (v->v,v -> ds) (v -> t) (v -> c) -> E e p ds t c
  scopE env x =
    case x of
      HsLet (envtrans,f) e -> let env2 = envtrans env 
                              in  HsLet (f env2) (e env2)
      HsLambda ps e        -> let (env2,ps') = scopPatList env ps  
                              in  HsLambda ps' (e env2)
      HsCase e alts        -> HsCase (e env) (map (scopAlt env) alts)
      HsDo stmt            -> HsDo (scopStmt env stmt)
      HsListComp stmt      -> HsListComp (scopStmt env stmt)
      
      z -> mapE (\ f -> f env) (error "missing HsExp case") 
                (error "missing HsDecl case") (\ f -> f env) (\ f -> f env) z
  
  scopAlt :: v -> HsAlt (v -> e) (v->v,v -> p) (v->v,v -> ds) -> HsAlt e p ds
  scopAlt env (HsAlt s (f,pf) rhs (g,dsf)) = 
      let env2 = g (f env)
      in  (HsAlt s (pf env) (scopRhs env2 rhs) (dsf env2))
  
  scopRhs :: v -> HsRhs (v -> e) -> HsRhs e
  scopRhs env x = mapRhs (\ f -> f env) x
  
  scopStmt :: v -> HsStmt (v -> e) (v->v,v -> p) (v->v,v -> ds) -> HsStmt e p ds
  scopStmt env (HsGenerator (tr,pf) e s) = 
     let env2 = tr env in HsGenerator (pf env) (e env2) (scopStmt env2 s)
  scopStmt env (HsQualifier e s) = HsQualifier (e env) (scopStmt env s)
  scopStmt env (HsLetStmt (tf,dsf) s) = 
     let env2 = tf env in HsLetStmt (dsf env2) (scopStmt env2 s)
  scopStmt env (HsLast e) = HsLast (e env)   
  
  scopPatList :: v -> [(v -> v,v -> p)] -> (v,[p])
  scopPatList env ps = (foldr (\ (tf,_ ) e -> tf e) env ps,
                        map (\ (_ ,pf)   -> pf env) ps)
  
  --------------------------------------------------------------------------
  -- Then for the declaration sub-language
  
  scopD :: Env v => v -> 
           D (v -> e)
           (v -> v, v -> p)
           (v -> v, v -> ds)
           (v -> t)
           (v -> c)
           (v -> v, v -> tp) -> 
           D e p ds t c tp 
  scopD env x =
    let scopConDecl env = mapConDecl (\f -> f env) 
        extendWithTvs env tvs = foldr extTvar env tvs
        scopMatch env (HsMatch loc nm ps rhs (dectrans,ds)) = 
          let (env2,ps') = scopPatList env ps
              env3 = dectrans (extVar nm loc env2)
          in HsMatch loc nm ps' (scopRhs env3 rhs) (ds env3)
    in
    case x of
      HsPatBind loc (pattrans,pf) rhs (dectrans,dsf) ->
          let env2 = dectrans (pattrans env)
          in
          HsPatBind loc (pf env) (scopRhs env2 rhs) (dsf env2)
      HsFunBind loc matches -> HsFunBind loc (map (scopMatch env) matches)
      HsTypeDecl loc (transtpfs @ ((ctrans,cmaker):fs)) tf -> 
          let env2 = ctrans env
              constr = cmaker env
              (env3,args) = scopPatList env fs
          in HsTypeDecl loc (constr:args) (tf env3)
          
      HsNewTypeDecl loc contxtf transtpfs condecl derivs ->
            let (env2,args) = scopPatList env transtpfs
                (env3,_) = scopPatList (restrictTvar env) (tail transtpfs)
            in  HsNewTypeDecl loc (contxtf env3) args  (scopConDecl env2 condecl) derivs
      
      HsDataDecl loc contxtf transtpfs condecls derivs ->
           let (env2,args) = scopPatList env transtpfs
               (env3,_) = scopPatList (restrictTvar env) (tail transtpfs)
           in  HsDataDecl loc (contxtf env3) args (map (scopConDecl env2) condecls) derivs
      
      HsClassDecl loc contxtf (trans,tpf) (dectrans,dsf) ->    
           let env1 = trans (restrictTvar env) 
           in HsClassDecl loc (contxtf env1) (tpf env) (dsf $ dectrans env1) 
      HsInstDecl loc contxtf (trans,tpf) (dectrans,dsf) ->    
           let env1 = trans (restrictTvar env) 
           in HsInstDecl loc (contxtf env1) (tpf env) (dsf $ dectrans env1) 
      HsTypeSig loc nms contxtf (transf, tpf)  ->
           HsTypeSig loc nms (contxtf (transf env)) (tpf env)
      z -> mapD (\ f -> f env) h h (\ f -> f env) (\ f -> f env) (error "type pattern") z
           where h (trans,f) = f (trans env) 
  
  
  --------------------------------------------------------------------------
  -- Then for the type sub-language
  
  scopT :: v -> T (v -> t) -> T t
  scopT env t = mapT (\f -> f env) t 
  
  --------------------------------------------------------------------------
  -- Computing Things about patterns
  --------------------------------------------------------------------------
  
  boundInP :: HsPat -> [HsName] -> [HsName]
  boundInP (Pat(HsPId(HsVar s))) ans = s:ans
  boundInP (Pat(HsPAsPat n p)) ans = boundInP p (n:ans)
  boundInP (Pat x) ans = accP boundInP ans x
  
  
  ------------------------------------------------------------------------
      -- patBound: Compute three things while visiting each pattern sub-node.
      -- 1) A list of unique names bound by the pattern
      -- 2) A list of names that appear more than once. 
      --    These are errors because we allow only linear patterns
      -- 3) A list of every construtor and the arity at which it was used.
      --    These are potential errors if the arites do not match
  
  patBound :: HsPat -> ([HsName], [HsName], [(HsName, Int)]) -> 
                       ([HsName], [HsName], [(HsName, Int)])
  patBound (Pat p) ans =
      case p of
      HsPId(HsVar n)      -> add n ans
      HsPAsPat n p        -> patBound p (add n ans) 
      HsPApp c ps         -> cadd c (length ps) ans'
      HsPInfixApp p1 c p2 -> cadd (getHSName c) 2 ans'
      _                   -> ans'
  
      where add x (a, b, c) = 
                 if elem x a 
                    then if elem x b 
                            then (a, b, c)
                            else (a, x:b, c)  
                    else (x:a, b, c)
            cadd c n (x, y, z) = (x, y, (c, n):z)
            ans' = accP patBound ans p
  
  
  ------------------------------------------------------------------------------
  -- Static Check for Expressions
  
  chE :: SrcLoc -> HsExp -> Senv -> [Error]
  chE loc (exp @ (Exp x)) env =
    case scopE env (mapE (chE loc) (chP loc)
                 (chDs WhereLikeDecl) (chT loc ) (error "ctxt")  x) of
      HsId (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsInfixApp x (HsVar n) y -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsLeftSection x (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsRightSection (HsVar n) x -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsLambda ps e -> e ++ (chPatList loc env ps)
    
      z -> accE (++) (\ (ns,errs) a -> errs++a) (++) (++) (++) z []
      
  --------------------------------------------
  -- Static checks for individual patterns
  
  chP :: SrcLoc -> HsPat -> (Senv -> Senv,Senv -> ([HsName],[Error]))
  chP loc (pat @ (Pat x)) = (envTrans, f)
    where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])
          envTrans env = foldr extName env uniqueNames
          extName nm = extVar nm loc
          duperr = chk loc (not (null dups)) (duplicate_vars_in_pattern dups)
          f env = (uniqueNames,allErrors env)
          allErrors env = foldr arityCheck duperr constrArities
            where arityCheck (c,n) ans = check c n (cArity c env) ++ ans
                  check c n Nothing  = [(loc,undefined_constr c)]
                  check c n (Just m) = chk loc (m /=n) (constr_wrong_arity n c)
  
  -----------------------------------------------------------------------------
  -- When language constructs have a list of patterns like : (\ p1 ... pn -> e)
  -- or (case x of { C p1 ... pn -> e }), Haskell has the rule that no variable
  -- should appear more than once in the list. We can't check this, pattern by
  -- pattern, but have to observe the complete list. If we map (chP env) over a
  -- list of patterns we get [([unique_names],[error_messages])], from this we
  -- can compute additional error_messages dealing with duplicates.
  
  chPatList :: SrcLoc -> Senv -> [([HsName],[Error])] -> [Error]      
  chPatList loc env ps =
   let accumulate (ns,errs) (names,errors) = (ns++names,errs++errors)
       (allbound,internalerr) = foldr accumulate ([],[]) ps
       dups = duplicates allbound
       duperr = chk loc (not (null dups)) (repeated_pattern_variables dups)
   in internalerr ++ duperr
  
  --------------------------------------------------------------------------
  -- static checks for a list of Decls
  
  
  chDs :: DeclContext -> [HsDecl] -> (Senv->Senv,Senv -> [Error] )
  chDs contxt ds = (envtrans,errorfun)
    where env      = allNames ds env0
          envtrans = concatEnv env
          errorfun env = foldr (\ d ans -> (check env d) ++ ans) allErrors ds
          sameName (x,y) (a,b) = compare x a
          contextErrors = catMaybes $ map (legal contxt) ds
          dupErr k message = collect_duplicate_info (dupErrs message) sameName (locations k env)
          dupValErrors  = dupErr Var    "value definitions"
          dupSigErrors  = dupErr Sig    "type signatures"
          dupClsErrors  = dupErr Class  "class definitions"
          dupTypErrors  = dupErr TyCons "type definitions"
          dupConsErrors = dupErr Cons   "constructor functions"
  
          allErrors = contextErrors++dupValErrors++dupSigErrors++dupClsErrors
                      ++ dupTypErrors ++ dupConsErrors ++ nmConflict env ++ clsMethodErr
          sigerr loc name = chk loc ((not $ elem name (map fst (varNames env))) && contxt/=ClassDecl)
                                    (signature_without_definition name)
          methodErr c (nm,loc) = chk loc (not $ isMethod nm c env) (not_a_method nm c)
          clsMethodErr = case contxt of 
                         ClassDecl -> classMethodErr env
                         other     -> []
          check env (Dec x) =
            let loc = srcloc x
                methodErrs (HsInstDecl loc c tp ds) = 
                  let nms = varNames $ allNames ds env0
                  in  case getClass tp of
                       Nothing -> []
                       Just c  -> concat $ map (methodErr c) nms
            in
             case scopD env (mapD' (chE loc) (chP loc) (chDs) (chT loc) (chCntxt loc) (chTp loc) x) of
               HsTypeSig loc nms c t  -> (concat $ map (sigerr loc) nms)++c++t
               HsInstDecl loc c tp ds -> methodErrs x ++ c ++ tp ++ ds
               z -> accD (++) (\ (ns,errs) a -> (errs)++a) (++) (++) (++) (++) z []
  
      
      
  ---------------------------------------------------------------------------
  
  chT :: SrcLoc -> HsType -> Senv -> [Error]
  chT loc (typ @ (Typ t)) env = 
    case t of 
     HsTyVar nm -> chk loc (not (tvarDefined nm env)) (undefined_tvar nm)
     HsTyCon nm -> chk loc (not (tconDefined nm env)) (undefined_tcon nm)
     HsTyApp (Typ f) x -> synCheck (chT loc) env f x 1
     z -> accT (++) (scopT env (mapT (chT loc)  z)) []
  
  synCheck chf env (HsTyCon c) arg n = 
      case synArity c env of
      Nothing -> chk loc (not (tconDefined c env)) (undefined_tcon c) ++ chf arg env 
      Just m  -> chk loc (m/=n) (tysynonym_not_fully_applied c) ++ chf arg env
  synCheck chf env (HsTyApp (Typ f) x) arg n =
      synCheck chf env f x (n+1) ++ chf arg env
  synCheck chf env t arg n = chf (Typ t) env ++ chf arg env
  
  -----------------------------------------------------------------------------
  -- Static checks for contexts
  
  chCntxt :: SrcLoc ->  DeclContext -> [HsType] -> (Senv -> [Error])
  chCntxt loc c ts env = foldr (check c) [] ts
    where inscope (Typ (HsTyVar x)) ans = 
              chk loc (not $ tvarDefined x env) (undefined_tvar_in_context x) ++ ans
          inscope (Typ (HsTyCon c)) ans = 
              chk loc (not $ classDefined c env) (undefined_class_in_context c) ++ ans 
          inscope (Typ x) ans  = accT inscope x ans 
  
          -- class: C (x t*)+
          wfClass t (Typ (HsTyApp (Typ (HsTyCon c)) x )) xs =
             wfClassArg x x xs
          wfClass t (Typ (HsTyApp x y ))                 xs =
             wfClass t x $ wfClassArg x x xs
          wfClass t (Typ x)                              xs =
             (loc, illformed_class t) : xs
  
          -- class arg: x t*
          wfClassArg t (Typ (HsTyVar y))   xs = xs
          wfClassArg t (Typ (HsTyApp x _)) xs = wfClassArg t x xs 
          wfClassArg t (Typ x)             xs = (loc, illformed_class_arg t) : xs
  
          check ClassDecl x ans = wfSclass loc x (inscope x ans)
          check InstDecl  x ans = wfSclass loc x (inscope x ans)
          check _         x ans = wfClass  x x   (inscope x ans)
  
  -----------------------------------------------------------------------------
  -- Static checks for type patterns
  
  
  chTp :: SrcLoc ->  TPContext -> HsType -> (Senv -> Senv, Senv -> [Error])
  chTp srcloc InstTP x =
    let errors = wf x []
        -- well formed instance: C (C x*)+
  
        wf (Typ(HsTyApp (Typ(HsTyCon c)) arg)) xs =
           wfTp srcloc InstTP arg xs
        wf (Typ(HsTyCon c)) xs                 =
           (srcloc, instance_required c) : xs 
        wf (Typ(HsTyApp y arg)) xs             =
           wf y (wfTp srcloc InstTP arg xs)
        wf tp xs                               =
           (srcloc, instance_not_class_app tp) : xs
  
        (classname, ts) = instPatToParts x
        (tvs, cs) = foldr allTypNames ([], []) ts
        trans env = if null errors then foldr extTvar env tvs else env
        clsError env = chk srcloc (not $ classDefined classname env) 
                                  (undefined_class_in_instance classname)
        cdef env c ans = 
           if tconDefined c env 
           then case synArity c env of
                Nothing   -> ans
                Just _    -> (srcloc, synonym_illegal_in_instance c):ans
           else (srcloc,undefined_tcon_in_instance c):ans
        dupErrs = collect_duplicate_info (dupTvErr srcloc) compare tvs
        tpf env = if null errors
                  then foldr (cdef env) (dupErrs ++ clsError env) cs
                  else errors
    in (trans, tpf)                
  
  chTp srcloc SigTP x =
    let (tvs, cs)     = allTypNames x ([], [])
        trans env    = foldr extTvar env tvs
        cdef env c ans = 
           if tconDefined c env 
           then ans
           else (srcloc, undefined_tcon_in_signature c):ans
        tpf env = foldr (cdef env) [] cs
    in  (trans, tpf)
  
  chTp srcloc cntxt x =
    let (constr, tvs) = typePatToParts x
        errors = case cntxt of DataLikeTP ->  wfTp     srcloc cntxt x []
                               ClassTP    ->  wfSclass srcloc       x []
        trans env = if null errors then foldr extTvar env tvs else env
        tpf env   = if null errors 
                    then collect_duplicate_info (dupTvErr srcloc) compare tvs
                    else errors
    in (trans, tpf)
  
  
  
  -------------------------------------------------------------------------
  -- Error Message Strings are computed here
  -------------------------------------------------------------------------
  
  undefined_variable nm = "Undefined variable: "++ pp nm
  duplicate_vars_in_pattern dups =
    "Variables appear more than once in single pattern: " ++ pp dups
  undefined_constr c =
    "Undefined Constructor in pattern: " ++ pp c
  constr_wrong_arity n c =
    "Constructor "++ pp c++ " must have exactly "++ pp n ++ " arguments."
  repeated_pattern_variables dups =
    "Repeated variables in pattern list: " ++ pp dups
  duplicate_things sort name locs =
    "Duplicate " ++ show sort ++ " of " ++ show name ++
    " at locations: " ++ pp locs
  signature_without_definition name =
    "Signature for "++pp name++" without matching definition."
  
  undefined_class_in_instance classname =
    "Class name in instance: " ++ pp classname ++ "  is not defined"
  undefined_tcon_in_instance c =
    "Type constructor " ++ pp c ++ " in instance is not defined"
  synonym_illegal_in_instance c =
    "Type synonym " ++ pp c ++ " in instance"
  
  undefined_tcon_in_signature c =
    "Type constructor " ++ pp c ++ " in signature is not defined"
    
  undefined_class_in_context clsname =
    "Class name " ++ pp clsname ++ " in context is not defined"
  undefined_tvar_in_context tvarname =
    "Type variable " ++ pp tvarname ++ " in context is not defined"
  undefined_tvar tvarname =
    "Type variable " ++ pp tvarname ++ "  is not defined"
  undefined_tcon tconname =
    "Type constructor " ++ pp tconname ++ "  is not defined"
  tysynonym_not_fully_applied tyconname =
    "Type synonym " ++ pp tyconname ++ "  is not fully applied"
  duplicate_type_vars x =
    "Duplicate type variables in definition: " ++ pp x
  
  non_tyvar_arg_in_pattern a c =
    "Argument in Type Pattern in " ++ show c ++ " is not a variable: "++ pp a
  type_former_is_not_constructor x c = 
    "Type pattern in " ++ show c ++ " is not an application of a type constructor: "++ pp x
  instance_required tp =
    "Instance of class " ++ pp tp ++ " required"
  instance_not_class_app tp = 
    "Instance is not an application of a class constructor: "++pp tp
  
  illformed_sclass t=
    "ill formed class "++pp t
  illformed_class t=
    "ill formed class in context "++pp t
  illformed_class_arg t=
    "ill formed argument " ++ pp t ++ " to class in context "
  
  not_a_method nm c =
    pp nm ++ " is not a method of class " ++ pp c
  
  {-
  
  showAst === pp
  
  showAst :: Printable a => a -> String
  showAst = render . ppi
  -}
  
  ----------------------------------------------------------------------------------
  -- some tests
  
  sh :: Printable b => b -> IO ()
  sh = putStr . render . ppi
  
  loc = SrcLoc "Scope tests" 0 0
  
  names2 @ [fn,gn,hn,kn,xn,yn,zn] = map UnQual ["f","g","h","k","x","y","z"]
  names3 @ [an,bn,cn,dn,en,tn,sn] = map UnQual ["A","B","C","D","E","T","S"]
  
  exps @  [fe,ge,he,ke,xe,ye,ze] = map hsEVar  names2
  pats @  [fp,gp,hp,kp,xp,yp,zp] = map hsPVar  names2
  typs @  [ft,gt,ht,kt,xt,yt,zt] = map hsTyVar names2
  
  cons @  [ac,bc,cc,dc,ec,tc,sc] = map hsECon  names3
  tcons @ [at,bt,ct,dt,et,tt,st] = map hsTyCon names3
  
  ap2 [x] = x
  ap2 (x:y:xs) = ap2((hsApp x y):xs)
  
  apt [x] = x
  apt (x:y:xs) = apt((hsTyApp x y):xs)
  
  arr = hsTyFun
  
  
  class1 = hsClassDecl loc [] (apt [ct,xt])
             [ hsTypeSig loc [fn] [] (xt `arr` xt) ]
  class2 = hsClassDecl loc [apt[ct,yt]] (apt [dt,yt])
             [ hsTypeSig loc [gn] [] (yt `arr` yt) ]
  class3 = hsClassDecl loc [apt[at,yt,xt]] (apt [et,yt,yt])
             [ hsTypeSig loc [zn] [] (yt `arr` yt) ]         
  
  inst0 = hsInstDecl loc [] (ct) []
  inst0'= hsInstDecl loc [] (xt) []
  inst1 = hsInstDecl loc [] (apt [ct,xt]) []
  inst2 = hsInstDecl loc [] (apt [ct,apt [dt,xt,xt]]) []
  inst3 = hsInstDecl loc [] (apt [ct,apt [dt,at]]) []
  inst4 = hsInstDecl loc [apt [dt,xt]] (apt [ct,tt]) []
  inst5 = hsInstDecl loc [] (apt [ct,at]) []
  inst6 = hsInstDecl loc [] (yt `arr` yt) []
  
  data1 = hsDataDecl loc [] [tt] [HsConDecl loc cn []] []
  data2 = hsDataDecl loc [] [tt,xt] [] []
  data3 = hsDataDecl loc [] [tt] [HsConDecl loc cn [HsBangedType yt]
                               ,HsConDecl loc dn [HsUnBangedType at]
                               ,HsConDecl loc dn []
                               ] []
  data4 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType st]] []
  data5 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt])]] []
  data6 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt,yt])]] []
  data7 = hsDataDecl loc [] [tt,xt] [HsConDecl loc dn [HsUnBangedType (apt [st,xt,yt,yt])]] []
  
  type1 = hsTypeDecl loc [st,xt,yt] (hsTyTuple [xt,yt])
  sig1  = hsTypeSig loc [zn] [] (apt [st,xt])
  
  p0 = [class1,class2,class3,inst1,inst2,inst3]
  p1 = [inst2]
  p2 = [class1,class1,data1,data2,inst4,inst5]
  
  run env prog  = let (f,x) = chDs TopDecl prog in x(f env)
  ss  = run env0 
  
  showErr (SrcLoc f n m, s) = "(" ++ show n ++ ", " ++ show m ++ ") " ++ s
  
  sck ds = (putStr . unlines . map showErr . ss) ds
          
  test prog = do {sh prog; putStr "\n------------\n"; sck prog}
  
  testDs :: (String,[HsDecl]) -> IO ()
  testDs (s, ds) = 
           do { putStr "\n==============================================\n"
              ; putStr s
              ; putStr "\n--- test code----------\n"
              ; sh ds
              ; putStr "\n--- errors ------------\n"
              ; (putStr . unlines . map showErr . run env0) ds
              }
  
  tests ts = sequence_ $ map testDs ts
  
  insts :: [(String, [HsDecl])]
  insts = [ ("Ill formed instance type", [ hsInstDecl loc [] (ct) [] ] )
          , ("Ill formed instance type", [ hsInstDecl loc [] (xt) [] ])
          , ("Ill formed instance type", [hsInstDecl loc [] (apt [ct,xt]) []])
          , ("Undefined class & type" , [hsInstDecl loc [] (apt [ct,dt]) []])
          , ("Duplicate type vars", 
                  [ hsDataDecl  loc [] [dt] [] []
                  , hsClassDecl loc [] (apt [ct,xt]) []
                  , hsInstDecl loc [] (apt [ct,apt [dt,xt,xt]]) []])
          , ("Argument to TyCon must be tyvar", [hsInstDecl loc [] (apt [ct,apt [dt,at]]) []])
          , ("Many undefined", [hsInstDecl loc [apt [dt,xt]] (apt [ct,tt]) []])
          , ("Type synonym illegal",   
                   [ hsTypeDecl  loc [at] bt
                   , hsDataDecl  loc [] [bt] [] []
                   , hsClassDecl loc [] (apt [ct,xt]) []
                   , hsInstDecl  loc [] (apt [ct,at]) []
                   ])
          , ("Context errors", 
                  [ hsDataDecl  loc [] [at] [] []
                  , hsDataDecl  loc [] [bt,xt] [] []
                  , hsClassDecl loc [] (apt [ct,xt]) []
                  , hsClassDecl loc [] (apt [dt,xt]) []
                  , hsInstDecl  loc [xt] (apt [ct,at]) []
                  , hsInstDecl  loc [dt] (apt [ct,at]) []
                  , hsInstDecl  loc [apt[dt,apt[xt,yt]]] (apt [ct,apt [bt,xt]]) []
                  ])
          , ("",
                  [ hsDataDecl  loc [] [at] [] []
                  , hsClassDecl loc [] (apt [ct,xt]) [ hsTypeSig loc [fn] [] (xt `arr` xt) ]
                  , hsInstDecl  loc [] (apt [ct,at]) 
                          [ hsTypeSig loc [fn] [] (xt `arr` xt) 
                          , hsFunBind loc [HsMatch loc fn [xp] (HsBody(hsEVar xn)) []] 
                          , hsFunBind loc [HsMatch loc gn [xp] (HsBody(hsEVar yn)) []] 
                          ]
                  ])
          , ("OK", [ hsDataDecl  loc [] [at] [] []
                   , hsDataDecl  loc [] [bt,xt] [] []
                   , hsClassDecl loc [] (apt [ct,xt]) []
                   , hsClassDecl loc [] (apt [dt,xt]) []
                   , hsInstDecl  loc [] (apt [ct,at]) []
                   , hsInstDecl  loc [apt [dt,xt]] (apt [ct,apt [bt,xt]]) []
                   ])
          , ("class/type name conflict", 
                   [ hsDataDecl  loc [] [at] [] []
                   , hsDataDecl  loc [] [bt] [] []
                   , hsInstDecl loc [] (apt [at,bt]) []
                   , hsInstDecl loc [] (apt [ct,bt]) []
                   ] )
                             
          ]
  
  dts  = [ ("", [ hsDataDecl  loc [] [at,bt] [] [] ] )
         , ("", [ hsDataDecl  loc [] [xt,yt] [] [] ] )
         ]
  
  clss = [ ("OK", [hsClassDecl loc [] (apt [ct,xt]) []])
         , ("ill formed class specification", [hsClassDecl loc [] (ct) []])
         , ("ill formed class specification", [hsClassDecl loc [] (xt) []])
         , ("class/type name conflict", 
                  [ hsDataDecl  loc [] [at] [] []
                  , hsDataDecl  loc [] [bt] [] []
                  , hsClassDecl loc [] (apt [at,xt]) []
                  , hsClassDecl loc [] (apt [bt,xt]) []
                  ] )
         , ("ill formed class specification", 
                  [  hsClassDecl loc [] (apt [ct,at]) []
                  ] )
         , ("ill formed class specification", 
                  [  hsClassDecl loc [] (apt [ct,at]) []
                  ,  hsClassDecl loc [] (apt [dt,at]) []
                  ] )
         , ("ill formed class specification", 
                  [ hsDataDecl  loc [] [at] [] []
                  , hsClassDecl loc [] (apt [ct,at]) []
                  ] )
         , ("",
                  [  hsClassDecl loc [] (apt [ct,xt])
                     [ hsTypeSig loc [fn] [] (arr xt xt)
                     , hsPatBind loc fp (HsBody (hsLambda [xp] xe)) []
                     , hsPatBind loc gp (HsBody (hsLambda [xp] xe)) []
                     ]
                  ] )
         ]
        
  patBind p e = hsPatBind loc p (HsBody e) []
  
  d1 = [patBind fp (hsLambda [xp] xe), patBind fp (hsLambda [xp] (xe))]
  {-
  p2 = [hsTypeSig loc [zn] (TypeUnQual$ hsTyCon (UnQual "Int"))]
  p3 = [hsTypeSig loc [yn,yn] (TypeUnQual $ Typ $ HsTyCon (UnQual "Int"))]
  p4 = [patBind fp (hsLet [patBind xp ye] xe)]
  p5 = [patBind fp (hsLambda [xp] (ye))]
  p6 = [patBind fp (hsLambda [hsPTuple [xp, xp], xp] ye)]
  p7 = [patBind fp (hsLambda [hsPTuple [xp, xp, xp], xp] ye)]
  
  runP p = let (envt,f) = chP loc p in f (envt env0)
  -}
  
  -----------------------------------------------------------------------------
  -- computing free variables
  -- Computing free variables is a tricky computation, because the same variable
  -- may be free in one spot and bound in another. We need an environment to
  -- determine what variables are bound at any particular point. We use a list
  -- of HsName as the environment
  
  -- Given an expression and an environment telling what vars are bound
  -- determine the free variables in the expression.
  
  freeE :: HsExp -> [HsName] -> [HsName]
  freeE (Exp x) env = 
    case scopE env (mapE freeE freeP freeD freeT freeC x) of
      HsId(HsVar s) -> if elem s env then [] else [s]
      HsInfixApp x (HsVar s) y -> if elem s env then [] else [s]
      HsLeftSection x (HsVar s) -> if elem s env then [] else [s]
      HsRightSection (HsVar s) x -> if elem s env then [] else [s]
      x -> accE (++) (++) (++) (++) (++) x []
              
  
  -- Return a pair of functions. The first is an env transformer, adding
  -- the vars in the pattern, the second is a function given an env, which
  -- determines the free vars in the pattern. The second is the constant []
  -- function since patterns only introduce variables, they only have binding
  -- occurences.
  
  freeP :: HsPat -> ([HsName]->[HsName],[HsName]->[HsName])
  freeP p = ((vs++),const [])
    where vs = boundInP p []
          
  -- Return a pair of functions. The first is an env transformer, adding
  -- the vars declared by the list of Decls, the second is a function which
  -- when given an env, determines the free vars in the Decls 
  
  freeD :: [HsDecl] -> ([HsName]->[HsName],[HsName]->[HsName])
  freeD ds = (ext,free)
    where bound = foldr add [] ds
          ext env = bound ++ env 
          add (Dec (HsPatBind s p rhs ds)) env = boundInP p env
          add (Dec (HsFunBind s ((HsMatch s2 nm ps rhs ds):_))) env  = nm : env
          add (Dec (HsDataDecl s ctx typats condecls derivings)) env =
             getTyName (head typats) : env
          add (Dec (HsTypeDecl s typats t)) env = getTyName (head typats) : env
          add d env = env
          getNameOfTypat (Typ x) = 
               case x of 
                 HsTyApp l _ -> getNameOfTypat l
                 HsTyCon n   -> n
                 HsTyVar n   -> n 
                 _           -> error "getNameOfTypat "
          free env = (foldr (f env) [] ds) \\ bound 
          f env (Dec d) ans = 
            accD (++)(++)(++)(++)(++)(++)
                 (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans
  ff env (Dec d) ans = 
            accD (++)(++)(++)(++)(++)(++)
                 (scopD env (mapD (\ x -> ( (freeE x))) freeP freeD freeT freeC freeTP d)) ans          
  
  
  instance Env [HsName] where
    extClass n l a args env = env
    extTconstr n l a b  env = n:env
    extTvar n           env = n:env
    extConstr n l a     env = n:env
    extVar n l          env = n:env
    extSig n l          env = env
    extMod n            env = env
    env0 = []
    restrictTvar env = env
  
  
  -- Given an environment holding bound variables, return the 
  -- free variables in the HsType
  
  freeT :: HsType -> [HsName] -> [HsName]
  freeT (Typ x) env = 
    case scopT env (mapT freeT x) of
      HsTyCon n -> if elem n env then [] else [n]    
      HsTyVar n -> if elem n env then [] else [n]
      x         -> accT (union) x []
  
  allFree :: HsType -> [HsName] -> [HsName]
  allFree (Typ x) ans = 
    case x of
      HsTyCon n -> union [n] ans
      HsTyVar n -> union [n] ans
      x         -> accT allFree x ans
  
  
  -- compute the free variables in a context.
  
  freeC :: [HsType] -> [HsName] -> [HsName]
  freeC x env = concat (map (\z -> freeT z env) x)
  
  -- Type patterns are HsTYpes which act as binding occurences. Hence
  -- they return a pair. First an env transformer, and Second a function
  -- that given an env, computes the TypePatterns free variables. Like patterns
  -- this always returns []
  
  freeTP :: HsType -> ([HsName] -> [HsName],[HsName] -> [HsName])
  freeTP x = (allFree x,const [])
  
  
  makeSCC ds env =
    let (envtrans,_) = freeD ds 
        bound = envtrans []
        oneD d = let (_,free) = freeD [d] in free env
        oneBind d = let (envt,_) = freeD [d] in envt []
        allFree  = map oneD ds
        allBound = map oneBind ds 
    in (allFree,allBound)
  
  --------------------------------------------------------------------------
  -- Contexts
  --------------------------------------------------------------------------
  
  -- type patterns appear in 4 different contexts
  
  data TPContext = DataLikeTP | ClassTP | InstTP | SigTP
  instance Show TPContext where
    show DataLikeTP = "type, data, or newtype declaration"
    show ClassTP    = "class declaration"
    show InstTP     = "instance declaration"
    show SigTP      = "type signature" 
  
  
  -----------------------------------------------------------------
  -- Lists of declarations can appear in four different contexts
  -- Only certain kinds of declarations are legal in some of these.
  
  data DeclContext = TopDecl | ClassDecl | InstDecl | WhereLikeDecl deriving (Eq)
  instance Show DeclContext where
    show TopDecl       = "top level"
    show ClassDecl     = "class declaration"
    show InstDecl      = "class declaration"
    show WhereLikeDecl = "local declaration"
  
  legal :: DeclContext -> HsDecl -> Maybe Error
  legal context (d @ (Dec x)) =
    let err context x = Just (srcloc x,
                  "Illegal "++ whatIs x ++" in " ++ show context)
    in  case (context,x) of
        (TopDecl,   any)                             -> Nothing
        (ClassDecl, HsTypeSig _ _ _ _)               -> Nothing
        (ClassDecl, HsFunBind _ _)                   -> Nothing
        (ClassDecl, HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing
        (ClassDecl, any)                             -> err context x
        (InstDecl,  HsFunBind _ _)                   -> Nothing
        (InstDecl,  HsPatBind _ (Pat(HsPId(HsVar _))) _ _) -> Nothing
        (InstDecl,  any)                             -> err context x
        (WhereLikeDecl, HsTypeSig _ _ _ _)           -> Nothing
        (WhereLikeDecl, HsFunBind _ _)               -> Nothing
        (WhereLikeDecl, HsPatBind _ _ _ _)           -> Nothing
        (WhereLikeDecl, any)                         -> err context x
  
  -----------------------------------------------------------------------
  -- MapD' is like mapD, except it know what kind of contexts are
  -- appropriate and passes this information downwards
  
  mapD' :: (a -> b) -> (c -> d) -> (DeclContext -> e -> f) -> (g -> h) -> (DeclContext -> i -> j)
                    -> (TPContext -> k -> l) -> D a c e g i k -> D b d f h j l
  mapD' ef pf df tf cf tpf decl =
     case decl of
      HsTypeDecl s tps t -> 
          HsTypeDecl s (map (tpf DataLikeTP) tps) (tf t)
      HsNewTypeDecl s cntxt tps cd names ->
          HsNewTypeDecl s (cf TopDecl cntxt)
                (map (tpf DataLikeTP) tps) (mapConDecl tf cd) names
      HsDataDecl s cntxt tps cds names   ->
          HsDataDecl s (cf TopDecl cntxt)
                 (map (tpf DataLikeTP) tps)
                 (map (mapConDecl tf) cds) names
      HsClassDecl s c tp ds                   ->
          HsClassDecl s (cf ClassDecl c) (tpf ClassTP tp) (df ClassDecl ds)
      HsInstDecl s c tp ds                    ->
          HsInstDecl s (cf InstDecl c) (tpf InstTP tp) (df InstDecl ds)
      HsDefaultDecl s t -> 
          HsDefaultDecl s (tf t)
      HsTypeSig s nms c t                  ->
          HsTypeSig s nms (cf TopDecl c) (tpf SigTP t)
      HsFunBind s matches                   ->
          HsFunBind s (map (mapMatch ef pf (df WhereLikeDecl)) matches)
      HsPatBind s p rhs ds                  ->
          HsPatBind s (pf p) (mapRhs ef rhs) (df WhereLikeDecl ds)
      HsPrimitiveTypeDecl s cntxt nm        -> 
          HsPrimitiveTypeDecl s (cf TopDecl cntxt) nm
      HsPrimitiveBind s nm t                ->
          HsPrimitiveBind s nm (tf t) -- Hugs compatibility
  
  
   
  -------------------------------------------------------------------
  -------------------------------------------------------------------
  -- Static Checking using Bind based scoping
  
  -------------------------------------------------------------------------
  -- Example extend function for the static env Senv of the static checker
  
  
  -- extTvar nm env = env {tvarNames = (nm) : tvarNames env}  
   
  extend :: Bind -> Senv -> Senv
  extend (Bpat loc pat) env = foldr extName env uniqueNames
          where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])
                extName nm env = env {varNames = (nm,loc) : varNames env}
  extend (Bpats loc ps) env = foldr extend env (map (Bpat loc) ps)
  extend (Bdecls ds) env = allNames ds env
  extend (Bname loc nm) env = env {varNames = (nm,loc) : varNames env}
  extend (Btypat tag tp) env = 
    case tag of
          ClassTag ->  -- (Env e x)         -- expects (C v1 ... vn)
            let (constr, tvs) = typePatToParts tp
            in foldr extTvar env tvs 
          InstTag  ->  -- (Env [Int] Bool)  -- expects (C t1 ... tn)
            let (classname, ts) = instPatToParts tp
                (tvs, cs) = foldr allTypNames ([], []) ts
            in foldr extTvar env tvs 
          SigTag   ->  -- (e : typ) 
            let (tvs, cs)     = allTypNames tp ([], [])             
            in foldr extTvar env tvs
  extend (Btypats tag (tps @ (constr : args))) env = 
     case tag of
       DataTPS -> foldr (\ t e -> extTvar (getTyName t) e) env tps
       TypeTPS -> foldr (\ t e -> extTvar (getTyName t) e) env args
      
  staticlib = Sc extend restrictTvar    
  
  ------------------------------------------------------------------
  -- Static checks for expressions 
  
  checkE :: SrcLoc -> HsExp -> Senv -> [Error]
  checkE loc (exp @ (Exp x)) env =
    case scopeE staticlib env 
           (mapE (checkE loc) (checkP loc)
                 (checkDs WhereLikeDecl) (checkT loc) (checkCnxt loc WhereLikeDecl)  x) of
      HsId (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsInfixApp x (HsVar n) y -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsLeftSection x (HsVar n) -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsRightSection (HsVar n) x -> chk loc (not (varDefined n env)) (undefined_variable n)
      HsLambda ps e -> e ++ (checkPList loc env ps)
      z -> accE (++) (\ (nm,err) a -> err ++ a) (++) (++) (++) z []
      
  -----------------------------------------------------------------------------
  -- When language constructs have a list of patterns like : (\ p1 ... pn -> e)
  -- or (case x of { C p1 ... pn -> e }), Haskell has the rule that no variable
  -- should appear more than once in the list. We can't check this, pattern by
  -- pattern, but have to observe the complete list. If we map (chP env) over a
  -- list of patterns we get [([unique_names],[error_messages])], from this we
  -- can compute additional error_messages dealing with duplicates.
  
  checkPList :: SrcLoc -> Senv -> [([HsName],[Error])] -> [Error]      
  checkPList loc env ps =
   let accumulate (ns,errs) (names,errors) = (ns++names,errs++errors)
       (allbound,internalerr) = foldr accumulate ([],[]) ps
       dups = duplicates allbound
       duperr = chk loc (not (null dups)) (repeated_pattern_variables dups)
   in internalerr ++ duperr
  
  --------------------------------------------
  -- Static checks for individual patterns
  
  checkP ::  SrcLoc -> HsPat -> (HsPat, Senv -> ([HsName],[Error]))
  checkP loc (pat @ (Pat x)) = (pat, f)
    where (uniqueNames,dups,constrArities) = patBound pat ([],[],[])
          duperr = chk loc (not (null dups)) (duplicate_vars_in_pattern dups)
          f env = (uniqueNames,allErrors env)
          allErrors env = foldr arityCheck duperr constrArities
            where arityCheck (c,n) ans = check c n (cArity c env) ++ ans
                  check c n Nothing  = [(loc,undefined_constr c)]
                  check c n (Just m) = chk loc (m /=n) (constr_wrong_arity n c)
  
  
  ------------------------------------------------------------------------------
  -- Static Check for Expressions
  
  -- checkDs assumes that all the names in the [Decl] have already been added
  -- to the environment which is passed to checkDs result function.
  -- e.g. in scopeE for HsLet we say:
  --    HsLet (ds,f) e -> 
  --       let env2 = ext (Bdecls ds) env 
  --       in  HsLet (f env2) (e env2)
  -- note how we compute the new env, and pass it to both the ds and the f
  
  checkDs ::  DeclContext -> [HsDecl] -> ([HsDecl],Senv -> [Error])
  checkDs contxt ds = (ds,errorfun)
    where env      = allNames ds env0
          errorfun env = foldr (\ d ans -> (check env d) ++ ans) allErrors ds
          sameName (x,y) (a,b) = compare x a
          contextErrors = catMaybes $ map (legal contxt) ds
          dupErr k message = collect_duplicate_info (dupErrs message) sameName (locations k env)
          dupValErrors  = dupErr Var    "value definitions"
          dupSigErrors  = dupErr Sig    "type signatures"
          dupClsErrors  = dupErr Class  "class definitions"
          dupTypErrors  = dupErr TyCons "type definitions"
          dupConsErrors = dupErr Cons   "constructor functions"
  
          allErrors = contextErrors++dupValErrors++dupSigErrors++dupClsErrors
                      ++ dupTypErrors ++ dupConsErrors ++ nmConflict env ++ clsMethodErr
          sigerr loc name = chk loc ((not $ elem name (map fst (varNames env))) && contxt/=ClassDecl)
                                    (signature_without_definition name)
          methodErr c (nm,loc) = chk loc (not $ isMethod nm c env) (not_a_method nm c)
          clsMethodErr = case contxt of 
                         ClassDecl -> classMethodErr env
                         other     -> []
          check env (Dec x) =
            let loc = srcloc x
                methodErrs (HsInstDecl loc c tp ds) = 
                  let nms = varNames $ allNames ds env0
                  in  case getClass tp of
                       Nothing -> []
                       Just c  -> concat $ map (methodErr c) nms
            in
             case scopeD staticlib env 
                    (mapD' (checkE loc) (checkP loc) (checkDs) 
                           (checkT loc) (checkCnxt loc) (checkTp loc) x) of
               HsTypeSig loc nms c t  -> (concat $ map (sigerr loc) nms)++c++t
               HsInstDecl loc c tp ds -> methodErrs x ++ c ++ tp ++ ds
               z -> accD (++) (\ (ns,errs) a -> (errs)++a) (++) (++) (++) (++) z []
  
  ---------------------------------------------------------------------------
  -- static checks for types
  
  checkT ::  SrcLoc -> HsType -> Senv -> [Error]
  checkT loc (typ @ (Typ t)) env = 
    case t of 
     HsTyVar nm -> chk loc (not (tvarDefined nm env)) (undefined_tvar nm)
     HsTyCon nm -> chk loc (not (tconDefined nm env)) (undefined_tcon nm)
     HsTyApp (y @ (Typ f)) x -> synArityCheck (checkT loc) env f x 1
     z -> accT (++) (scopeT env (mapT (checkT loc)  z)) []
  
  synArityCheck chf env typ arg n = 
    case typ of
      (HsTyCon c) -> 
         case synArity c env of
           Nothing -> chk loc (not (tconDefined c env)) (undefined_tcon c) ++ chf arg env 
           Just m  -> chk loc (m/=n) (tysynonym_not_fully_applied c) ++ chf arg env
      (HsTyApp (Typ f) x) -> synArityCheck chf env f x (n+1) ++ chf arg env
      t -> chf (Typ t) env ++ chf arg env
     
  ----------------------------------------------------------------------
  -- Static Checking for contexts
  
  checkCnxt :: SrcLoc -> DeclContext -> [HsType] -> Senv -> [Error]
  
  checkCnxt loc c ts env = foldr (check c) [] ts
    where inscope (Typ (HsTyVar x)) ans = 
              chk loc (not $ tvarDefined x env) (undefined_tvar_in_context x) ++ ans
          inscope (Typ (HsTyCon c)) ans = 
              chk loc (not $ classDefined c env) (undefined_class_in_context c) ++ ans 
          inscope (Typ x) ans  = accT inscope x ans 
  
          -- class: C (x t*)+
          wfClass t (Typ (HsTyApp (Typ (HsTyCon c)) x )) xs =
             wfClassArg x x xs
          wfClass t (Typ (HsTyApp x y ))                 xs =
             wfClass t x $ wfClassArg x x xs
          wfClass t (Typ x)                              xs =
             (loc, illformed_class t) : xs
  
          -- class arg: x t*
          wfClassArg t (Typ (HsTyVar y))   xs = xs
          wfClassArg t (Typ (HsTyApp x _)) xs = wfClassArg t x xs 
          wfClassArg t (Typ x)             xs = (loc, illformed_class_arg t) : xs
  
          check ClassDecl x ans = wfSclass loc x (inscope x ans)
          check InstDecl  x ans = wfSclass loc x (inscope x ans)
          check _         x ans = wfClass  x x   (inscope x ans)
  
  
  ---------------------------------------------------------------------
  -- Static checks for type-patterns
  
  --checkTp ::  SrcLoc -> TPContext -> HsType -> (HsType,Senv -> [Error])
  checkTp :: SrcLoc ->  TPContext -> HsType -> (HsType, Senv -> [Error])
  
  checkTp srcloc InstTP x =
    let errors = wf x []
        -- well formed instance: C (C x*)+
  
        wf (Typ(HsTyApp (Typ(HsTyCon c)) arg)) xs =
           wfTp srcloc InstTP arg xs
        wf (Typ(HsTyCon c)) xs                 =
           (srcloc, instance_required c) : xs 
        wf (Typ(HsTyApp y arg)) xs             =
           wf y (wfTp srcloc InstTP arg xs)
        wf tp xs                               =
           (srcloc, instance_not_class_app tp) : xs
  
        (classname, ts) = instPatToParts x
        (tvs, cs) = foldr allTypNames ([], []) ts
        clsError env = chk srcloc (not $ classDefined classname env) 
                                  (undefined_class_in_instance classname)
        cdef env c ans = 
           if tconDefined c env 
           then case synArity c env of
                Nothing   -> ans
                Just _    -> (srcloc, synonym_illegal_in_instance c):ans
           else (srcloc,undefined_tcon_in_instance c):ans
        dupErrs = collect_duplicate_info (dupTvErr srcloc) compare tvs
        tpf env = if null errors
                  then foldr (cdef env) (dupErrs ++ clsError env) cs
                  else errors
    in (x, tpf)                
  
  checkTp srcloc SigTP x =
    let (_, cs)     = allTypNames x ([], [])
        cdef env c ans = 
           if tconDefined c env 
           then ans
           else (srcloc, undefined_tcon_in_signature c):ans
        tpf env = foldr (cdef env) [] cs
    in  (x, tpf)
  
  checkTp srcloc cntxt x =
    let (_, tvs) = typePatToParts x
        errors = case cntxt of DataLikeTP ->  wfTp     srcloc cntxt x []
                               ClassTP    ->  wfSclass srcloc       x []
        tpf env   = if null errors 
                    then collect_duplicate_info (dupTvErr srcloc) compare tvs
                    else errors
    in (x, tpf)
  
  -----------------------------------------------------------------
  -- Running the basic tests
  
  run2 env prog  = let (ds,f) = checkDs TopDecl prog in (f (allNames ds env))
  
  new (_,x) = run2 env0 x
  old (_,x) = run env0 x
  
  test2 :: (String,[HsDecl]) -> IO ()
  test2 (s, ds) = 
           do { putStr "\n==============================================\n"
              ; putStr s
              ; putStr "\n--- test code----------\n"
              ; sh ds
              ; putStr "\n--- errors ------------\n"
              ; (putStr . unlines . map showErr . run2 env0) ds
              }
  
  tests2 ts = sequence_ (map test2 ts)
  
  errors1 ts = map (run2 env0) (map snd ts) 
  errors2 ts = map (run env0) (map snd ts)        
               
  new1 = errors1 insts       
  old1 = errors2 insts
  
  oks = zipWith (==) old1 new1
  
  
  [x0,x1,x2,x3,x4,x5,x6,x7,x8,x9,x10,x11] = insts
  
  gg x = concat(map (\ (y,_,_,_) -> show y) (classNames x))
  ------------------------------------------------------------------
  -- extra stuff
  
  
  
  -- supply a unique integer string
  count :: IORef Int
  count = unsafePerformIO $ newIORef 0
  initCount = writeIORef count 10
  incCount a = unsafePerformIO $ do { c <- readIORef count
                                    ; writeIORef count $! (c+1)
                                    ; return c
                                    }
  
  uniqueStr a = show $ incCount ()
  