DefinedNamesBaseStruct.hs

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