{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module MakeSymTab( mkSymTab, cConvInst, convCQType, convCQTypeWithAssumps, convCType, ) where #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 804) import Prelude hiding ((<>)) #endif import Data.List import ErrorTCompat import Control.Monad(when) import qualified Data.Set as S import qualified Data.Map as M import Data.Either(partitionEithers) import FStringCompat(concatFString) import PFPrint import PreStrings(fsTilde) import PreIds import Id -- for PPrint and PVPrint Id instances import IdPrint() import Error(internalError, EMsg, EMsgs(..), ErrMsg(..), ErrorHandle, bsError, bsErrorUnsafe) import CSyntax import CSyntaxUtil(isEnum) import SymTab import CType import CFreeVars(getFTCDn, getVDefIds, getFTyCons) import StdPrel import InferKind(inferKinds) import Type(fn, tArrow, HasKind(..)) import Pred import Scheme import Pragma import Assump import Subst import qualified KIMisc as K import Data.Maybe import Unify import IOUtil(progArgs) import Util import SCC(tsort) import ListUtil(mapFst, mapSnd) import Debug.Trace(traceM) doTraceKI :: Bool doTraceKI = "-trace-kind-inference" `elem` progArgs doTraceOverlap :: Bool doTraceOverlap = "-trace-instance-overlap" `elem` progArgs mkSymTab :: ErrorHandle -> CPackage -> IO SymTab mkSymTab errh (CPackage mi _ imps _ ds _) = let mmi = Just mi -- --------------- -- initial symbol table -- the types which are built into the compiler -- (not defined in the Prelude etc) -- (filtering out numeric and string types is ok because all of the -- prelude types have identifiers) preTypes' = [(i, ti) | ti@(TypeInfo (Just i) _ _ _) <- preTypes] -- populate an initial symbol table with the pre-defined items -- (note that Prelude classes have recursive access to other classes) spre = emptySymtab `addTypesUQ` preTypes' -- pre-defined types `addVarsUQ` preValues -- pre-defined values `addClassesUQ` (preClasses symT) -- pre-defined classes -- instances from the imported packages iinstqs = nub [ (i, qt) | CImpSign _ _ (CSignature _ _ _ ds) <- imps, CIinstance i qt <- ds ] qconv qt = case convCQType symT qt of Left msg -> bsErrorUnsafe errh [msg] Right pt -> pt cls_fd = -- classes are exported both concretely and abstractly [ (iKName ik, vs, fds) | CImpSign _ _ (CSignature _ _ _ ids) <- imps, Cclass _ _ ik vs fds _ <- ids ] ++ [ (iKName ik, vs, fds) | CImpSign _ _ (CSignature _ _ _ ids) <- imps, CIclass _ _ ik vs fds _ <- ids ] ++ [ (qualId mi (iKName ik), vs, fds) | Cclass _ _ ik vs fds _ <- ds ] -- XXX imported fundeps don't need to be checked -- but it is simpler to check them while converting to bss fundepErrs = concatMap chkFunDeps cls_fd -- instances from this package and from the imports -- unsorted because we handle this at the class level insts :: QInsts insts = [ QInst mi (qconv qt) | Cinstance qt _ <- ds ] ++ [ QInst mi (qconv qt) | (mi, qt) <- iinstqs ] -- a symbol table containing all pre-defined items and all items -- from imported packages (except instances and classes) -- instances and classes are handled later because of error-handling (simp, impClsErrs) = foldl (addImpSyms errh insts) (spre, []) imps -- all types available to this packaged (predefined and imported) preIds = S.fromList (map fst (getAllTypes simp)) -- --------------- -- Errors -- the type definitions tdefs = filter isTDef ds -- the qualified and unqualified names of the types defined here, -- plus types already defined dids = S.unions (map (getVD mi) tdefs) `S.union` preIds -- multiple definitions for the same Id dis = filter ((> 1) . length) . group . sort . concatMap getVDefIds $ ds -- undefined type references uids = S.toList (S.unions (map getFTCDn ds) `S.difference` dids) -- check for recursive type synonyms type_syn_map = [ (iKName i, S.toList $ getFTyCons t) | (Ctype i _ t) <- tdefs ] rec_type_syn_sccs = case (tsort type_syn_map) of Right _ -> [] Left sccs -> sccs errMultipleDef (i:i':_) = let [pos1, pos2] = sort [getIdPosition i, getIdPosition i'] in (pos2, EMultipleDecl (pfpString i) pos1) errMultipleDef is = internalError ("MakeSymTab.mkSymTab.errMultipleDef: " ++ show is) errUnboundTyCon i = (getIdPosition i, EUnboundTyCon (pfpString i)) errRecTypeSyn :: [Id] -> EMsg errRecTypeSyn scc = (getPosition scc, ETypeSynRecursive (map pfpString scc)) -- --------------- -- Build the symbol table -- kind inference miks = inferKinds mi simp ds iks = case miks of Left msg -> bsErrorUnsafe errh [msg] Right iks -> tracep doTraceKI ("iks: " ++ ppReadable iks) $ iks mkQuals = mkDefaultQuals -- always unqualify -- previous symbol table with types and classes added (symT, clsErrs) = mkTypeSyms errh mkQuals mmi iks ds insts simp allClsErrs = impClsErrs ++ clsErrs -- finally, add constructors, fields, and variables -- XXX and something about top vars? -- XXX and something about instances? final_symT = let s1 = symAddCons mkQuals mmi symT ds s2 = symAddFields mkQuals mmi s1 ds s3 = symAddVars mkQuals mmi s2 ds in case (getTopVars s3 mmi ds) of Left msgs -> bsError errh (errmsgs msgs) Right vs -> let ivs = [ let i = mkInstId mi (updTypes s3 t) a = i :>: mustConvCQType s3 [] qt in (i, VarInfo VarDefn a Nothing) | (mi, qt@(CQType _ t)) <- iinstqs ] in return $ s3 `addVarsUQ` vs `addVarsUQ` ivs -- --------------- in --trace (ppReadable (S.toList dids)) $ -- XXX consider reporting multiple error groups at the same time if not (null dis) then bsError errh (map errMultipleDef dis) else if not (null uids) then bsError errh (map errUnboundTyCon uids) else if not (null rec_type_syn_sccs) then bsError errh (map errRecTypeSyn rec_type_syn_sccs) else if not (null fundepErrs) then bsError errh fundepErrs else if not (null allClsErrs) then bsError errh allClsErrs else -- report the kind inference error safely case miks of Left msg -> bsError errh [msg] Right iks -> final_symT updTypes :: SymTab -> Type -> Type updTypes r (TCon (TyCon i _ _)) = case findType r i of Just (TypeInfo (Just i') k _ ti) -> TCon (TyCon i' (Just k) ti) Just (TypeInfo Nothing k _ ti) -> internalError ("updTypes: unexpected numeric or string type:" ++ ppReadable i) Nothing -> internalError ("updTypes " ++ ppReadable i) updTypes r (TAp f a) = TAp (updTypes r f) (updTypes r a) updTypes r t = t data QInst = QInst Id (Qual CType) -- QInsts are directly associated with the instances they name -- via mkInstId (modulo duplicate instance errors) instance Eq QInst where (QInst mi1 (_ :=> t1)) == (QInst mi2 (_ :=> t2)) = mkInstId mi1 t1 == mkInstId mi2 t2 instance Ord QInst where compare (QInst mi1 (_ :=> t1)) (QInst mi2 (_ :=> t2)) = compare (mkInstId mi1 t1) (mkInstId mi2 t2) type QInsts = [QInst] instance PPrint QInst where pPrint d p (QInst i qt) = text "(QInst" <+> pPrint d p i <+> pPrint d p qt <> text ")" instance Show QInst where show qi = ppReadable qi -- typeclass instance head partial order -- to handle overlapping instances -- Left LT means ts1 strictly more specific than ts2 -- (should come earlier in instance list) -- Left EQ means ts1 == ts2 -- (modulo alpha renaming and the like) -- (i.e. duplicate instance error if not ordered on other fundeps) -- Left GT means ts2 strictly less specific than ts1 -- (should come later in the instance list) -- Right False means no overlap -- (no contribution to partial order) -- Right True means bad overlap -- (report an error) orderInstHead :: [Type] -> [Type] -> Either Ordering Bool orderInstHead ts1 ts2 = case (mu1, mu2) of (Nothing, Nothing) -> Right False -- ts1 substitution instance of ts2 only (Nothing, Just _) -> Left GT -- ts2 substitution instance of ts1 only (Just _, Nothing) -> Left LT (Just s1, Just s2) -> case (okSubst vs1 s1, okSubst vs2 s2) of (True, True) -> Left EQ (False, True) -> Left GT (True, False) -> Left LT (False, False) -> Right True where vs1 = tv ts1 vs2 = tv ts2 mu1 = mgu vs1 ts1 ts2 mu2 = mgu vs2 ts2 ts1 okSubst vs (s,eqs) = not (any (flip elem $ vs) (getSubstDomain s)) && null eqs cmpQInsts :: [[Bool]] -> QInst -> QInst -> Either EMsg (Maybe Ordering) cmpQInsts bss q1@(QInst _ (_ :=> t1)) q2@(QInst _ (_ :=> t2)) = do let t1' = expandSyn t1 let t1_vs = tv t1' let t2' = expandSyn t2 let t2_vs = tv t2' let (Forall t1_ks (_ :=> sc1)) = quantify t1_vs ([] :=> t1') let (Forall t2_ks (_ :=> sc2)) = quantify t2_vs ([] :=> t2') -- replace all the tvs to avoid accidental tv overlap -- don't use tmpTyVarIds since they might be in t1_vs or t2_vs let tvs = zipWith tVarKind tmpVarIds (t1_ks ++ t2_ks) let t1_vs'' = take (length t1_vs) tvs let t2_vs'' = take (length t2_vs) (drop (length t1_vs) tvs) let t1'' = inst (map TVar t1_vs'') sc1 let t2'' = inst (map TVar t2_vs'') sc2 case (splitTAp t1'', splitTAp t2'') of ((TCon (TyCon cls1 _ _), ts1), (TCon (TyCon cls2 _ _), ts2))| cls1 == cls2 -> do when (length ts1 /= length ts2) $ internalError ("inconsistent class instances: " ++ ppReadable ((t1, t1', cls1, ts1), (t2, t2', cls2, ts2))) let fd_heads ts = map (flip boolCompress $ ts) (map (map not) bss) orders = zipWith orderInstHead (fd_heads ts1) (fd_heads ts2) instsPP = ppReadable ((t1, t1', t1''), (t2, t2', t2'')) succ ord = do when doTraceOverlap $ traceM("inst overlap ok (" ++ show ord ++ "): " ++ instsPP) Right $ Just ord fail err = do when doTraceOverlap $ traceM ("inst overlap bad: " ++ instsPP) Left err case (partitionEithers orders) of (ords, []) | any (== LT) ords && not (any (== GT) ords) -> succ LT | any (== GT) ords && not (any (== LT) ords) -> succ GT -- XXX duplicate instance error vs overlap error? | all (== EQ) ords -> fail (mkDuplicateError q1 q2) | otherwise -> fail (mkOverlapError q1 q2) ([], bads) | or bads -> fail (mkOverlapError q1 q2) | otherwise -> return Nothing -- XXX unify with some fundeps but not others? otherwise -> fail (mkOverlapError q1 q2) -- different classes, so error (we sort on class level now) _ -> internalError ("cmpQInsts (different classes): " ++ ppReadable (q1, q2)) -- equally specific instance heads are the same after alpha-renaming mkDuplicateError :: QInst -> QInst -> EMsg mkDuplicateError q1@(QInst _ (_ :=> t1)) q2@(QInst _ (_ :=> t2)) = (getPosition t2, EDuplicateInstance (pfpReadable t1) (getPosition t1)) -- bad overlapping instances (i.e. cannot be ordered) mkOverlapError :: QInst -> QInst -> EMsg mkOverlapError q1@(QInst _ (_ :=> t1)) q2@(QInst _ (_ :=> t2)) = (getPosition t1, EBadInstanceOverlap (pfpReadable t1) (pfpReadable t2) (getPosition t2)) chkFunDeps :: (Id, [Id], CFunDeps) -> [EMsg] chkFunDeps (cls, vs, fds) = let -- since we want to report several fds in one error message, -- return a tuple: (not full, overlap, extra vars, empty) chkOne fd@(as0, bs0) = let -- XXX warn if one side has duplicates? as = nub as0 bs = nub bs0 fd_vars = as ++ bs missing = any (\v -> v `notElem` fd_vars) vs overlap = as `intersect` bs extra = filter (\v -> v `notElem` vs) fd_vars empty = (null as) || (null bs) in (fd, (missing, overlap, extra, empty)) chks = map chkOne fds cls_pos = getPosition cls cls_str = pfpString (unQualId cls) v_strs = map pfpString vs notfull_errs = let notfull_fds = [ fd | (fd, (True, _, _, _)) <- chks ] notfull_fd_strs = mapFst (map pfpString) $ mapSnd (map pfpString) notfull_fds in if (null notfull_fds) then [] else [(cls_pos, EClassFundepsNotFull cls_str v_strs notfull_fd_strs)] overlap_errs = let overlap_fds = [ (fd, badvs) | (fd, (_, badvs, _, _)) <- chks , not (null badvs) ] in if (null overlap_fds) then [] else [(cls_pos, EClassFundepsOverlap cls_str)] extra_errs = let extra_vs = nub $ concat [ badvs | (_, (_, _, badvs, _)) <- chks ] extra_v_strs = map pfpString extra_vs in if (null extra_vs) then [] else [(cls_pos, EClassFundepsExtra cls_str extra_v_strs)] empty_errs = let empty_fds = [ fd | (fd, (_, _, _, True)) <- chks ] in if (null empty_fds) then [] else [(cls_pos, EClassFundepsEmpty cls_str)] in notfull_errs ++ overlap_errs ++ extra_errs ++ empty_errs symAddCons :: (Id -> [Id]) -> Maybe Id -> SymTab -> [CDefn] -> SymTab symAddCons mkQuals mi s ds = addCons mkQuals s $ concatMap (getCons mi s) ds symAddFields :: (Id -> [Id]) -> Maybe Id -> SymTab -> [CDefn] -> SymTab symAddFields mkQuals mi s ds = addFields mkQuals s [(i, FieldInfo si vis n a ifcPragmas def_cs mOrigType) | (si, n, a@(i :>: _), vis, ifcPragmas, def_cs, mOrigType) <- concatMap (getFields mi s) ds] symAddVars :: (Id -> [Id]) -> Maybe Id -> SymTab -> [CDefn] -> SymTab symAddVars mkQuals mi s ds = addVars mkQuals s [(i, VarInfo VarMeth a Nothing) | a@(i :>: _) <- concatMap (getMethods mi s) ds] cConvInst :: ErrorHandle -> SymTab -> CPackage -> CPackage cConvInst errh r (CPackage mi exps imps fixs ds includes) = CPackage mi exps imps fixs (map (convInst errh mi r) ds) includes convInst :: ErrorHandle -> Id -> SymTab -> CDefn -> CDefn convInst errh mi r di@(Cinstance qt@(CQType _ t) ds) = let Just c = leftCon t cls = mustFindClass r (CTypeclass c) instanceArgs = tyConArgs t clsMethType i = case schemes of -- relying on the class arguments being the first variables in the scheme [(Forall ks qt)] -> let ks' = drop (length instanceArgs) ks extraTypeVars = zipWith cTVarKind tmpVarIds ks' ts = instanceArgs ++ extraTypeVars in -- drop first argument because it is the dictionary -- which is not part of the class method type case (qualTypeToCQType (inst ts qt)) of CQType ps (TAp (TAp (TCon arr) a) r) | isTConArrow arr -> CQType ps r qt -> internalError("MakeSymTab.clsMethType 4" ++ ppReadable(i,c,qt)) [] -> -- either no type has a field by this name -- or some type has a field by this name, just -- not this type bsErrorUnsafe errh [(getPosition i, ENotField (pfpReadable c) (pfpReadable i))] _ -> -- this should not occur because there should -- only be one FieldInfo entry for a given type internalError("MakeSymTab.clsMethType: " ++ "multiple FieldInfo entries: " ++ ppReadable (i, c)) where schemes = case findField r i of Just fs -> [ sc | FieldInfo { fi_id = ty_id , fi_assump = (_ :>: sc) } <- fs, ty_id `qualEq` c ] Nothing -> -- no type has a field by this name, -- let clsMethType error about it [] altId (CLValue i cs me) = CLValueSign (CDef (mkUId i) (clsMethType i) cs) me altId (CLValueSign (CDef i qt cs) me) = CLValueSign (CDef (mkUId i) qt cs) me altId _ = internalError "MakeSymTab.convInst altId" mkf d = (i, CVar (mkUId i)) where i = getLName d sds = {-trace (ppReadable supsi)-} supsi where sups = super cls -- keep the position of the subclass contexts around (s_ids, s_preds) = unzip sups s_poss = map getPosition s_ids ats = tyConArgs t s_preds' = map mkinst s_preds -- once the predicates are made, zip them with the positions -- to be used for the position of the field in the CStruct supsi = map bnd (zip s_poss s_preds') vs = csig cls mkinst p = -- This definition doesn't work because "quantify" throws -- away elements of vs which are not in the base type -- let mkgen = let Forall _ (_ :=> t) = quantify vs ([] :=> predToType p) in t -- in inst ats gen let s = mkSubst (zip vs ats) in apSub s (predToType p) bnd (pos, t) = let Just tc = leftCon t ts = tyConArgs t cqt = CQType [CPred (CTypeclass tc) ts] noType in (setIdPosition pos (unQualId tc), -- XXX Lennart's comment: hacky encoding of dict -- XXX "tiExpr" looks for this construction CHasType (anyExprAt (getPosition di)) cqt) body = Cletrec (map altId ds) (CStruct (Just True) c (map mkf ds ++ sds)) in (CValueSign (CDef (mkInstId mi t) qt [CClause [] [] body])) convInst _ _ _ d = d mkInstId :: Id -> CType -> Id mkInstId mi t = -- trace ("mkInstId " ++ ppReadable (mi,t, expandSyn t)) $ mkQId (getPosition t) (getIdFString mi) (concatFString (intersperse fsTilde (map getIdFStringP (flat (expandSyn t))))) where flat (TVar (TyVar i _ _)) = [i] flat (TCon (TyCon i _ _)) = [i] flat (TCon (TyNum n _)) = [mkNumId n] flat (TCon (TyStr s _)) = [mkStrId s] flat (TAp t1 t2) = flat t1 ++ flat t2 flat _ = internalError "MakeSymTab.mkInstId flat" getCons :: Maybe Id -> SymTab -> CDefn -> [(Id, ConInfo)] getCons mi s data_decl@(Cdata { cd_internal_summands = summands }) = concat (zipWith getInfos summands [0..]) where rt = cTApplys (cTCon i) (map cTVar (cd_type_vars data_decl)) i = iKName (cd_name data_decl) n = genericLength summands tagSize = log2 $ maximum (map cis_tag_encoding summands) + 1 getInfos summand m = map f_aux cns where cns = cis_names summand -- make one for each constructor name cti = ConTagInfo { conNo = m, numCon = n, conTag = cis_tag_encoding summand, tagSize = tagSize } f_aux cn = (assump_id, info) where assump_id = qual mi cn cqt = CQType [] (cis_arg_type summand `fn` rt) sc = mustConvCQType s (cd_type_vars data_decl) cqt info = ConInfo { ci_id = qual mi i, ci_visible = cd_visible data_decl, ci_assump = assump_id :>: sc, ci_taginfo = cti } getCons _ _ _ = [] -- With a declaration -- struct S as = { f :: forall bs . C => t } -- the real type should be -- f :: forall as . S as -> forall bs . C => t -- we encode this (since CType lackes nested quantifiers) as -- f :: forall as bs . C => S as -> t -- Bool in the result is whether struct is visible to the user. getFields :: Maybe Id -> SymTab -> CDefn -> [(Id, Int, Assump, Bool, [IfcPragma], [CClause], Maybe CType)] getFields mi s (Cstruct vis _ ik vs ifs fieldNames) = let -- In "getMethods", the class is turned into a new context. -- Here, the struct is turned into a new argument: at = cTApplys (cTCon i) (map cTVar vs) i = iKName ik n = genericLength vs -- We need a quantify which will reorder the type variables, to put -- the struct type variables first (because moveForAll will later -- assume they are first and move the struct argument immediately -- following them) quantifyWithStructArgument ps at t = let tvs = tv at `union` tv ps `union` tv t ks = map kind tvs s = mkSubst (zipWith (\ v n -> (v, TGen (getPosition v) n)) tvs [0..]) in Forall ks (apSub s (ps :=> (at `fn` t))) generatorf :: CField -> (Id, Int, Assump, Bool, [IfcPragma], [CClause], Maybe CType) generatorf field@(CField { cf_type = CQType ps t }) = -- We re-implement "mustConvCQType" on cqt in steps here, -- because the cqt could have contexts whose type variables -- will be ordered before those of "at" if we just called -- "mustConvCQType" as is. case (convCQType s (CQType ps (at `fn` t))) of Left msg -> internalError ("MakeSymTab.getFields:\n" ++ ppReadable msg) Right (ps' :=> TAp (TAp arr at') t') | arr == tArrow -> (qual mi i, n, qual mi (cf_name field) :>: quantifyWithStructArgument ps' at' t', vis, fromMaybe [] (cf_pragmas field), cf_default field, cf_orig_type field ) qt -> internalError ("MakeSymTab.getFields: " ++ "converted type changed form:\n" ++ ppReadable qt) in -- traces ("getFields: " ++ ppReadable fieldNames ++ "\nn2: " ) $ map generatorf ifs getFields mi s (Cclass _ ps ik vs _ ifs) = let cls = mustFindClass s i i = CTypeclass (iKName ik) zfunc :: (CTypeclass,Pred) -> CPred -> CField zfunc (f,_) (CPred (CTypeclass c) ts) = CField { cf_name = typeclassId f, cf_pragmas = Nothing, cf_type = CQType [] (cTApplys (cTCon c) ts), cf_default = [], cf_orig_type = Nothing } sifs = zipWith zfunc (super cls) ps in getFields mi s (Cstruct True SClass ik vs (ifs ++ sifs) []) getFields _ _ _ = [] -- For a method of a class, this first produces the type signature with -- a new first context for the typeclass of which the method is a member: -- CQType (CPred i (map cTVar vs):ps) t -- And then it uses mustConvCQType to convert that into a type which -- first takes in all the type variables (and those of the typeclass -- will be first) and then takes in the dictionaries for each context. getMethods :: Maybe Id -> SymTab -> CDefn -> [Assump] getMethods mi s (Cclass _ _ ik vs _ ifs) = let f (CField { cf_name = fi, cf_type = CQType ps t }) = qual mi fi :>: mustConvCQType s vs (CQType (CPred (CTypeclass i) (map cTVar vs):ps) t) i = iKName ik in map f ifs getMethods _ _ _ = [] getTopVars :: SymTab -> Maybe Id -> [CDefn] -> Either EMsgs [(Id, VarInfo)] getTopVars r mi ds = do -- if we want to deprecate top-level types, then this would need to -- be lifted out of this function and into "mkSymTab" and "addImpSyms" let isDeprecated = makeDeprecatedLookup ds let (errs, ass) = partitionEithers $ map (chkTopDef r mi isDeprecated) ds if null errs then return (concat ass) else throwError (EMsgs errs) chkTopDef :: SymTab -> Maybe Id -> (Id -> Maybe String) -> CDefn -> Either EMsg [(Id, VarInfo)] chkTopDef r mi isDep (Cprimitive i ct) = do sc <- mkSchemeWithSymTab r ct let i' = qual mi i return [(i', VarInfo VarPrim (i' :>: sc) (isDep i))] chkTopDef r mi isDep (CIValueSign i ct) = do sc <- mkSchemeWithSymTab r ct return [(i, VarInfo VarDefn (i :>: sc) (isDep i))] chkTopDef r mi isDep (Cforeign i qt on ops) = do sc@(Forall _ (_ :=> t)) <- mkSchemeWithSymTab r qt let name = case on of Just s -> s Nothing -> getIdString i -- We accept functions whose arguments are bits/string and whose -- return result is either bits/string or is a -- primitive action/actionvalue isGoodResult :: CType -> Bool isGoodResult t = (isTypeBit t) || (isTypeString t) || (isTypeActionValue_ t) || (isTypePrimAction t) isGoodArg :: CType -> Bool isGoodArg t = (isTypeBit t) || (isTypeString t) isGoodType :: CType -> Bool isGoodType t = let (args, res) = getArrows t in (all isGoodArg args) && (isGoodResult res) let i' = qual mi i if isGoodType (expandSyn t) then return [(i', VarInfo (VarForg name ops) (i' :>: sc) (isDep i))] else throwError (getPosition i, EForeignNotBit (pfpString i)) chkTopDef r mi isDep (CValueSign (CDef v t _)) = do sc <- mkSchemeWithSymTab r t let v' = qual mi v return [(v', VarInfo VarDefn (v' :>: sc) (isDep v))] chkTopDef r mi isDep (CValueSign d@(CDefT {})) = -- we know that typechecking has not happened yet internalError ("getTopVars: " ++ ppReadable d) chkTopDef _ _ _ _ = return [] mkSchemeWithSymTab :: SymTab -> CQType -> Either EMsg Scheme mkSchemeWithSymTab s cqt = case convCQType s cqt of Left emsg -> Left emsg Right qt -> Right (quantify (tv qt) qt) mustConvCQType :: SymTab -> [Id] -> CQType -> Scheme mustConvCQType r _ qt = case convCQType r qt of Right t -> quantify (tv t) t Left msg -> internalError ("mustConvCQType:\n" ++ ppReadable msg) mkTypeSyms :: ErrorHandle -> (Id -> [Id]) -> Maybe Id -> M.Map Id Kind -> [CDefn] -> QInsts -> SymTab -> (SymTab, [EMsg]) mkTypeSyms errh mkQuals maybePackageName iks defs qts s = let importedTypeInfos = concatMap (getTI errh maybePackageName r iks) defs (cls, errss) = unzip $ [ getCls errh maybePackageName iks r incoh ps ik vs fds ifs qts | Cclass incoh ps ik vs fds ifs <- defs ] ++ [ getCls errh maybePackageName iks r incoh ps ik vs fds [] qts | CIclass incoh ps ik vs fds _ <- defs ] r = addClasses mkQuals (addTypes mkQuals s importedTypeInfos) cls in (r, concat errss) getTI :: ErrorHandle -> Maybe Id -> SymTab -> M.Map Id Kind -> CDefn -> [(Id, TypeInfo)] getTI errh mi r iks (Ctype ik vs ct) = [(i, TypeInfo (Just i) k vs (TItype n ct'))] where i = qual mi (iKName ik) k = getK iks ik n = genericLength vs ks = getNK n k ct' = case convCTypeAssumps r (zip vs ks) ct of Left msg -> bsErrorUnsafe errh [msg] Right t -> apSub (mkSubst (zip (zipWith tVarKind vs ks) (zipWith TGen (map getPosition vs) [0..]))) t getTI _ mi _ iks data_decl@(Cdata {}) = -- use getCISName so TIdata only contains the primary constructor names [(i, TypeInfo (Just i) k vs ti)] where i = qual mi (iKName (cd_name data_decl)) k = getK iks (cd_name data_decl) vs = cd_type_vars data_decl ti = TIdata { tidata_cons = (map getCISName (cd_internal_summands data_decl)) , tidata_enum = (isEnum (cd_original_summands data_decl)) } getTI _ mi _ iks (Cstruct _ ss ik vs fs _) = [(i, TypeInfo (Just i) (getK iks ik) vs (TIstruct ss (map cf_name fs)))] where i = qual mi (iKName ik) getTI _ mi _ iks (Cclass _ ps ik vs _ fs) = [(i, TypeInfo (Just i) k vs ti)] where i = qual mi (iKName ik) k = getK iks ik ti = TIstruct SClass (map cf_name fs ++ map (\ (CPred (CTypeclass i) _) -> i) ps) -- XXX super getTI _ mi _ iks (CItype ik vs _) = [(i, TypeInfo (Just i) (getK iks ik) vs TIabstract)] where i = qual mi (iKName ik) getTI _ mi _ iks (CIclass _ ps ik vs _ _) = [(i, TypeInfo (Just i) k vs ti)] where i = qual mi (iKName ik) k = getK iks ik ti = TIstruct SClass (map (\ (CPred (CTypeclass i) _) -> i) ps) getTI _ mi _ iks (CprimType ik) = [(i, TypeInfo (Just i) (getK iks ik) vs TIabstract)] where i = qual mi (iKName ik) -- the CSyntax doesn't provide type var names vs = [] getTI _ _ _ iks _ = [] qual :: Maybe Id -> Id -> Id qual Nothing i = i qual (Just mi) i = qualId mi i getK :: M.Map Id Kind -> IdK -> Kind getK iks ik = case M.lookup (iKName ik) iks of Just k -> k Nothing -> case ik of IdKind _ k -> k _ -> internalError ("getK " ++ ppReadable iks ++ show ik) getQInsts :: Id -> [[Bool]] -> QInsts -> (QInsts, [EMsg]) -- Exempt classes that are auto-derived for every type from overlap-checking. -- This limits the impact of the O(n^2) scaling issues because of -- the O(n^2) instance sort / overlap check. Unfortunately, it -- isn't an asymptotic fix. getQInsts ci _ qts | ci `elem` autoderivedClasses = ([ qi | qi@(QInst _ ( _ :=> t)) <- qts, leftCon t == Just ci ], []) getQInsts ci bss qts = (cls_qts', errs) where cls_qts = [ qi | qi@(QInst _ ( _ :=> t)) <- qts, leftCon t == Just ci ] cls_qt_g = [ (qi, lt_qis) | qi <- cls_qts, let more_specific qi' = cmpQInsts bss qi' qi == Right (Just LT), let lt_qis = filter more_specific cls_qts ] cls_qts' = case (tsort cls_qt_g) of Left cycles -> internalError ("getQInsts cycles? " ++ ppReadable (cycles, cls_qt_g)) Right sorted -> sorted -- XXX another O(n^2) traversal complicated by duplicate instance checking chk_pairs = uniquePairs cls_qts errs = fst $ partitionEithers $ map (uncurry (cmpQInsts bss)) chk_pairs doInst :: SymTab -> Class -> QInst -> Inst doInst r c (QInst mi p@(ps :=> t)) = let args (TAp f a) = args f ++ [a] args _ = [] vs = tv p i = setIdPosition (getPosition t) $ mkInstId mi t r = CTApply (CVar i) (map TVar vs) in mkInst r (ps :=> IsIn c (args t)) -- The list bss is used for determining whether a predicate is -- satisfied by some instance, by matching against the False -- entries and then unifying with the True entries. Thus, a -- list of all False is needed when there are no fundeps. genBss :: [Id] -> CFunDeps -> [[Bool]] genBss vs [] = [ replicate (length vs) False ] genBss vs fds = [ map (`elem` rs) vs | (_, rs) <- fds ] getCls :: ErrorHandle -> Maybe Id -> M.Map Id Kind -> SymTab -> -- class components Maybe Bool -> [CPred] -> IdK -> [Id] -> CFunDeps -> CFields -> QInsts -> (Class, [EMsg]) getCls errh mi iks r incoh ps ik vs fds ifs qts = let k = getK iks ik i = iKName ik ks = getNK (genericLength vs) k tvs = zipWith tVarKind vs ks conv ct = case convCTypeAssumps r (zip vs ks) ct of Left msg -> bsErrorUnsafe errh [msg] Right t -> t bss = genBss vs fds mkFunDep2 as bs v = if (elem v as) then (Just False) else if (elem v bs) then (Just True) else Nothing -- XXX this isn't really meaningful now that fundeps must be full -- XXX only being retained in case we change our mind -- The list bss2 is used to propagate fundeps for predicates -- which are not yet satisfied by an instance. In this case, -- a list of all False leads to useless work. bss2 = [ map (mkFunDep2 rs1 rs2) vs | (rs1, rs2) <- fds ] qi = qual mi i (qinsts, errs) = getQInsts qi bss qts c = Class { name = CTypeclass qi, csig = tvs, super = [ (c, IsIn (mustFindClass r c) (map conv ts)) | CPred c ts <- ps ], genInsts = \ _ _ _ -> map (doInst r c) qinsts, tyConOf = TyCon qi (Just k) (TIstruct SClass (map cf_name ifs ++ map (\ (CPred (CTypeclass i) _) -> i) ps)), funDeps = bss, funDeps2 = bss2, allowIncoherent = incoh, isComm = False } in (c, errs) -- --------------- trCType :: SymTab -> [(Id, Kind)] -> CType -> K.KI (Type, Kind) trCType r as ct = --trace ("trCType " ++ ppReadable ct) $ trCTypeN r as 0 ct {- Unused: isTypish :: TISort -> Bool isTypish (TIstruct SClass _) = False isTypish _ = True -} trCTypeN :: SymTab -> [(Id, Kind)] -> Integer -> CType -> K.KI (Type, Kind) trCTypeN r as _ (TVar (TyVar i n _)) = case lookup i as of Just k -> return $ (TVar (TyVar i n k), k) Nothing -> --trace ("trCTypeN "++ ppReadable(i,as)) $ K.err (getPosition i, EUnboundTyVar (pfpString i)) trCTypeN r as _ t@(TCon (TyNum _ _)) = return (t, KNum) trCTypeN r as _ t@(TCon (TyStr _ _)) = return (t, KStr) trCTypeN r as _ (TCon (TyCon i _ _)) = let pos = getPosition i in case findType r i of -- Disable check if it really is a type for now (was | isTypish ti). Just (TypeInfo (Just i') k _ ti) -> return $ (TCon (TyCon (setIdPosition pos i') (Just k) ti), k) Just (TypeInfo Nothing k _ ti) -> internalError("trCTypeN: unexpected numeric type: " ++ ppReadable i) _ -> K.err (pos, EUnboundTyCon (pfpString i)) trCTypeN r as n ct@(TAp f a) = do (f', fk) <- trCTypeN r as (n+1) f (a', ak) <- trCTypeN r as 0 a v <- K.unifyFunc f fk a ak t' <- chkTAp (n+1) f' a' return $ (t', v) trCTypeN _ _ _ t@(TGen _ _) = return (t, KStar) trCTypeN _ _ _ t@(TDefMonad _) = internalError "trCTypeN: TDefMonad" chkTAp :: Integer -> Type -> Type -> K.KI Type chkTAp n (TCon (TyCon i _ (TItype n' _))) _ | n < n' = K.err (getPosition i, EPartialTypeApp (pfpString i)) chkTAp _ f a = return $ TAp f a -- ----- convCQType :: SymTab -> CQType -> Either EMsg (Qual Type) convCQType r ct = --trace ("convCQType " ++ ppReadable ct) $ convCQTypeVars r (tv ct) ct convCQTypeWithAssumps :: SymTab -> [(Id, Kind)] -> CQType -> Either EMsg (Qual Type) convCQTypeWithAssumps r as ct = let tvs = tv ct adjKind tv@(TyVar i n k) = case (lookup i as) of Nothing -> tv Just k' -> TyVar i n k' tvs' = map adjKind tvs in convCQTypeVars r tvs' ct convCQTypeVars :: SymTab -> [TyVar] -> CQType -> Either EMsg (Qual Type) convCQTypeVars r tvs (CQType ps ct) = K.run $ do as <- mkTyVarAssumps tvs -- convert the preds, first -- (this way, we collect the kind info from the preds first) let trPred :: CPred -> K.KI (Class, [Type]) trPred (CPred c ts) = do -- Lookup the kinds of the predicate's arguments c' <- findClass r c let ks = map kind (csig c') when (length ks /= length ts) $ K.err (getPosition c, EKindArg (pfpString $ typeclassId c)) -- given an argument and it's expected type, convert the type -- (unifying the inferred type with the expected type) let trPredArg (t, k_expected) = do (t', k_inferred) <- trCType r as t K.unifyType t k_inferred k_expected return t' ts' <- mapM trPredArg (zip ts ks) return (c', ts') ps' <- mapM trPred ps -- now convert the base type, unifying with Star -- (reporting any kind errors, with what we now know from the preds) (ct', k) <- trCType r as ct K.unifyType ct k KStar -- now put it all together s <- K.getKSubst let ps'' = map (\ (c, ts) -> IsIn c (map (groundT s) ts)) ps' -- trace ("conv: " ++ show (vs, ground s t)) $ return () return (map (mkPredWithPositions []) ps'' :=> groundT s ct') -- ----- convCType :: SymTab -> CType -> Either EMsg Type convCType r ct = convCTypeVars r (tv ct) ct convCTypeVars :: SymTab -> [TyVar] -> CType -> Either EMsg Type convCTypeVars r tvs ct = K.run $ do as <- mkTyVarAssumps tvs (ct', _) <- trCType r as ct return ct' convCTypeAssumps :: SymTab -> [(Id, Kind)] -> CType -> Either EMsg Type convCTypeAssumps r as ct = K.run $ do (ct', _) <- trCType r as ct return ct' -- ----- mkTyVarAssumps :: [TyVar] -> K.KI [(Id, Kind)] mkTyVarAssumps tvs = do let (nokind_tvs, kind_tvs) = partition (isKVar . kind) tvs let known_kinds = [ (getTyVarId tv, kind tv) | tv <- kind_tvs ] new_as <- mapM (\ tv -> do v <- K.newKVar (Just (getTyVarId tv)); return (getTyVarId tv, v) ) nokind_tvs let as = known_kinds ++ new_as return as -- --------------- findClass :: SymTab -> CTypeclass -> K.KI Class findClass r i = do case findSClass r i of Just cl -> return cl Nothing -> K.err (getPosition i, EUnboundClCon (pfpString $ typeclassId i)) -- Turn free kind variables into * groundT :: K.KSubst -> Type -> Type groundT s (TVar (TyVar i n k)) = TVar (TyVar i n (K.groundK (K.apKSu s k))) groundT s c@(TCon _) = c groundT s (TAp l r) = TAp (groundT s l) (groundT s r) groundT _ _ = internalError "MakeSymTab.groundT" ----- addImpSyms :: ErrorHandle -> QInsts -> (SymTab, [EMsg]) -> CImport -> (SymTab, [EMsg]) addImpSyms _ _ (s, _) (CImpId _ _) = internalError "addImpSyms" addImpSyms errh insts (s, errs0) (CImpSign name qf (CSignature pkgName _ _ ds)) = -- trace ("DEBUG: addImpSyms: " ++ name ++ "\n") $ let mi = Nothing mkQuals name = -- if the package is imported qualified, -- only use the qualified name if qf then [name] else mkDefaultQuals name (s1, errs1) = mkTypeSyms errh mkQuals Nothing M.empty ds insts s s2 = symAddFields mkQuals mi s1 ds s3 = symAddVars mkQuals mi s2 ds in case (getTopVars s3 mi ds) of Left msgs -> bsErrorUnsafe errh (errmsgs msgs) Right vs -> (symAddCons mkQuals mi (addVars mkQuals s3 vs) ds, errs0 ++ errs1) ----- -- Get defined variables getVD :: Id -> CDefn -> S.Set Id getVD mi d = S.fromList (is ++ map (qualId mi) is) where is = getVDefIds d ----- -- XXX could this be done by embedding the pragma in CValueSign, -- XXX for instance, rather than by having to match a CPragma with -- XXX its CValueSign? makeDeprecatedLookup :: [CDefn] -> (Id -> Maybe String) makeDeprecatedLookup ds i = let deps = [(i,s) | CPragma (Pproperties i props) <- ds, PPdeprecate s <- props] in lookup (unQualId i) deps -----