HaRe-0.6: tools/base/SA/ScopeRec.hs
-- $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 ()