module DefinedNamesBaseStruct where import BaseSyntaxStruct import DefinedNames value qn = (HsVar qn,Value) con n t = (HsCon n,ConstrOf t) field n t = (HsVar n,MemberOf t) tcon n = (HsCon n,Type) mkclass c = (HsCon c, Class) instance ( DefinedNames i tp, DefinedNames i ds , DefinedNames i p ) => DefinedNames i (DI i e p ds t c tp) where classMethods cname d = case d of (HsTypeSig s nms _ _) -> [field m cname|m<-nms] _ -> [] definedNames d = case d of HsTypeDecl s (tp:_) t -> definedNames tp HsNewTypeDecl s ctx (tp:_) cd drv -> dataNames tp [cd] HsDataDecl s ctx (tp:_) cds drv -> dataNames tp cds HsClassDecl s c tp fd ds -> classNames tp ds HsInstDecl s c tp ds -> [] HsDefaultDecl s t -> [] HsTypeSig s nms c t -> [] HsFunBind s (match:_) -> [matchName match] HsPatBind s p rhs ds -> definedNames p HsInfixDecl s fixity names -> [] HsPrimitiveTypeDecl s cntxt nm -> [tcon nm] HsPrimitiveBind s nm t -> [value nm] _ -> [] where dataNames tp cds = tname:concatMap conNames cds where (tname,t) = case definedNames tp of [tname@(HsCon s,_)] -> (tname,s) _ -> error "definedNames@DI...: static check here(tname,t)" conNames c = case c of HsConDecl s n types -> [con n t] HsRecDecl s n fields -> con n t:[field f t|(fs,_)<-fields,f<-fs] classNames tp ds = mkclass c:classMethods c ds where c = case definedNames tp of [(HsCon d,_)] -> d _ -> error "definedNames@DI...: static check here(c)" matchName (HsMatch s n _ _ _) = value n -- Meningful for type patterns (types on the lhs in definitions) only: instance DefinedNames i tp => DefinedNames i (TI i tp) where -- no need to define classMethods definedNames t = case t of HsTyApp f x -> definedNames f HsTyCon nm -> [tcon nm] _ -> [] -- hmm, report error? instance DefinedNames i p => DefinedNames i (PI i p) where -- no need to define classMethods definedNames p = case p of HsPId (HsVar n) -> [value n] HsPId (HsCon n) -> [] HsPLit _ -> [] HsPInfixApp x op z -> definedNames x++definedNames z HsPApp nm ps -> definedNames ps HsPTuple ps -> definedNames ps HsPList ps -> definedNames ps HsPParen p -> definedNames p HsPRec nm fields -> concatMap fieldNames fields -- HsPRecUpdate nm fields -> HsPAsPat nm p -> value nm:definedNames p HsPWildCard -> [] HsPIrrPat p -> definedNames p where fieldNames fields = case fields of HsPFieldPun n -> [value n] HsPFieldPat n p -> definedNames p