content: module GenSign(genUserSign, genEverythingSign) where
  import Data.List((\\), sortBy, unionBy, groupBy, partition)
  import Data.Maybe(mapMaybe)
  import qualified Data.Map as M
  import qualified Data.Set as S
  import Control.Monad(when)
  
  import PFPrint
  
  import Util
  
  import PreStrings(fsPrelude)
  import Error(internalError, EMsg, WMsg, ErrMsg(..),
               ErrorHandle, bsError, bsWarning)
  import Id
  import FStringCompat(FString, getFString)
  import PreStrings(fsEmpty)
  import PreIds(tmpTyVarIds, idPrelude, idPreludeBSV)
  import Position(noPosition)
  import Pragma
  import CSyntax
  import CFreeVars
  import CType(leftTyCon, tyConArgs, isTConArrow, allTyCons)
  import Pred(Class(..), predToCPred, expandSyn)
  import SymTab
  import Assump(Assump(..))
  import Position(Position(..))
  import TypeCheck(qualifyClassDefaults)
  
  --import Util(traces)
  --import Debug.Trace
  
  
  -- ---------------
  
  -- only exports what the user asked to export
  -- (auto-exports everything if the user said nothing)
  genUserSign :: ErrorHandle -> SymTab -> CPackage -> IO CSignature
  genUserSign errh symtab cpkg =
      -- XXX should we internal error on any errors or warnings?
      case (genSign errh False symtab cpkg) of
          Left msgs -> bsError errh msgs
          Right (sign, warns) -> do
              when (not $ null warns) $ bsWarning errh warns
              return sign
  
  -- export everything as visible (for internal use in the evaluator)
  -- XXX eventually combine this with the above and just have one CSignature
  genEverythingSign :: ErrorHandle -> SymTab -> CPackage -> IO CSignature
  genEverythingSign errh symtab cpkg =
      case (genSign errh True symtab cpkg) of
          Left msgs -> internalError ("genEverythingSign")
          Right (sig, _) -> return sig
  
  
  -- XXX not quite baked -- attempt to use generics for signature file i/o
  -- genSignFileGeneric :: SymTab -> String -> CPackage -> IO ()
  -- genSignFileGeneric symtab fn cpack =
  --     case genSign symtab cpack of
  --      Left  msgs -> messageExit serror msgs
  --      Right sign -> writeFileCatch fn (gshow sign)
  
  genSign :: ErrorHandle -> Bool -> SymTab -> CPackage ->
             Either [EMsg] (CSignature, [WMsg])
  genSign errh exportAll symt
          pkg@(CPackage currentPkg exportList imps fixs ds0 includes) =
      let
          -- in the absence of typeclass defaults that are typechecked,
          -- at least record the scope by qualifying identifiers
          -- XXX see comment in tiOneDef for Cclass
          ds = qualifyClassDefaults errh symt ds0
  
          -- fsCurrentPkg: the FString name of the package being compiled
          fsCurrentPkg = getIdFString currentPkg
  
          -- exps = export clauses for specified exports or everything
          (exps0, badExports) =
              let all_exps_this_file = concatMap (defExport fsCurrentPkg) ds
              in  case exportList of
                    -- the user said nothing, so export everything
                    Right [] -> (all_exps_this_file, [])
                    Right excludes ->
                      let (excludes', errs) = qualifyExports True symt excludes
                          excludeSet = S.fromList excludes'
                          notExcluded i = i `S.notMember` excludeSet
                      in if exportAll
                         then (all_exps_this_file, errs)
                         else (filter notExcluded all_exps_this_file, errs)
                    -- the user specified exports, so return them (qualified)
                    -- and include everything in this file if writing .bo file
                    Left exports ->
                        let isSelfExport (CExpPkg p) = (p == currentPkg)
                            isSelfExport _           = False
                            (me, others) = partition isSelfExport exports
                            (qual_exports, errs) = qualifyExports False symt others
                            final_exports =
                                if (exportAll || not(null me))
                                then mergeExports all_exps_this_file qual_exports
                                else qual_exports
                        in  (final_exports, errs)
          (exps, packageErrors) = expandPkgExports symt imps exps0
  
          hasEmptyQual i = (getIdQual i == fsEmpty)
  
          -- a map containing entries for all (qualified) Ids to be exported,
          -- and indicating whether it was exported with (..)
          em = M.fromList (map mkExp exps)
          -- create the entries, and sanity check the exports
          mkExp e | hasEmptyQual (eName e) =
              internalError ("mkExp: not qualified: " ++ ppReadable (eName e))
          mkExp (CExpVar i) = (i, False)
          mkExp (CExpCon i) = (i, False)
          mkExp (CExpConAll i) = (i, True)
          mkExp (CExpPkg {}) = internalError "non-desugared package export"
  
          -- look: given an identifier, returns
          --         Nothing     (not exported)
          --         Just True   (exported with (..))
          --         Just False  (exported without (..))
          look i = M.lookup i em
  
          -- insts: imported typeclass instances
          --        (no longer necessary since we transitively close imports)
          --        (were included in ss below)
          -- insts = nub (getInsts pkg)
  
          -- ss: the signature file entry for exported defs in this package and
          --     all exported defs from imported packages
          (ss, warnss) = unzip $ concatMap (genDefSign symt look currentPkg) ds ++
                                   [ dw | CImpSign _ _ (CSignature ii _ _ ds) <- imps,
                                          d <- ds, dw <- genDefSign symt look ii d ]
  
          -- list of warnings produced while generating signatures
          -- currently only for orphan instances
          warns = concat warnss
  
          -- def: the names of the defs in ss (that have names)
          def = S.fromList [ i | (Right i) <- map getName ss ]
  
          -- ssFVs: pairing of each def in ss with
          --        the type constructors referenced in it
          ssFVs = map (\s -> (s, getFTCDn s)) ss
  
          -- use: set of the type constructors used in ss
          use = S.unions (map snd ssFVs)
  
          -- isHiddenDef: whether the constructors of the type def are visible
          isHiddenDef (Cdata { cd_visible =  vis }) = not vis
          isHiddenDef (CIclass _ _ _ _ _ _) = True
          isHiddenDef d = False
  
          -- useLoci: map from used variable to definitions where it's used
          --          (excepting data defs with non-visible constructors,
          --          and unnamed defs (like pragmas and instances))
          useLoci :: M.Map Id [Id]
          useLoci = M.fromList [ (var, def_names)
                                | var <- S.toList use
                                , let def_names = [ i | (def, fvs) <- ssFVs
                                                      , not (isHiddenDef def)
                                                      , var `S.member` fvs
                                                      , (Right i) <- [getName def] ]
                                , not (null def_names) ]
  
          -- udef: used but not defined types (and typeclasses)
          --       in the signature-file format (CItype and CIclass),
          --       from this package only
          --       (if it's in another package, the user of this package
          --       can import that other package; if it's in this package,
          --       nothing can be done, so we will error ... see below)
          udef :: [CDefn]
          udef = sortBy cmpName [ td |
                                  -- primitives which are available but
                                  -- not declared/exported should be ignored
                                  -- (idArrow, idAdd, idMax, idLog, idDiv, etc)
                                  -- for simplicity, we ignore all prelude
                                  -- qualified types
                                  fsCurrentPkg /= fsPrelude,
                                  i <- S.toList (S.difference use def),
                                  -- only consider Ids from this package
                                  getIdQFString i == Just fsCurrentPkg,
                                  {- not (isTCId i), -} td <- tdef i ]
              where cmpName t1 t2 = case (getName t1, getName t2) of
                                      (Right i1, Right i2) -> cmpIdByName i1 i2
                                      (Right _, Left _) -> GT
                                      (Left _, Right _) -> LT
                                      (Left _, Left _) -> EQ
  
          -- given a used type constructor, find the type that it belongs to
          -- and return it in signature-file form (CItype or CIclass)
          tdef i = case findType symt i of
                   Just x@(TypeInfo _ k vs (TIstruct SClass _)) ->
                       case (findSClass symt (CTypeclass i)) of
                         Nothing -> internalError ("GenSign.genSign: " ++
                                                   "couldn't find class " ++
                                                   ppReadable i)
                         Just cl ->
                             -- classToIClass doesn't need "vs" since the Class
                             -- stores the tyvars as well
                             [classToIClass i k cl (findPoss i)]
                   Just ti@(TypeInfo _ k vs (TItype _ _)) ->
                       --trace ("DEBUG ==> tdef " ++ ppString i ++ "\n" ++
                       --       ppString ti ++ "\n" ++
                       --       ppString (M.lookup i useLoci))
                       [CItype (IdKind i k) (varsk (mkTyVarIds vs) k) (findPoss i)]
                   Just ti@(TypeInfo _ k vs _) ->
                       --trace ("DEBUG ==> tdef " ++ ppString i ++ "\n" ++
                       --       ppString ti ++ "\n" ++
                       --       ppString (M.lookup i useLoci))
                       [CItype (IdKind i k) (varsk (mkTyVarIds vs) k) (findPoss i)]
                   Nothing -> internalError "genSign"
              where -- positions of the uses which necessitated exporting this def
                    -- XXX we could get rid of this
                    findPoss i = case (M.lookup i useLoci) of
                                   Just us -> map getIdPosition us
                                   Nothing -> [noPosition]
                                      -- XXX when not "exportAll",
                                      -- XXX some positions are not found
                                      --internalError ("GenSign tdef: " ++
                                      --               pfpString i)
                    -- use any user-given names, then continue with temp names
                    -- but not any that have already been used
                    mkTyVarIds vs = vs ++ (tmpTyVarIds \\ vs)
                    varsk (v:vs) (Kfun _ k) = v : varsk vs k
                    varsk _      _          = []
  
          -- ss': the def ss extended with type classes (CIclass)
          --      (any types CItype in udef will be reported as an error)
          ss' = ss ++ udef
  
          -- impids: the imported packages (not including the Preludes)
          impids = filter (\ x -> x /= idPrelude && x /= idPreludeBSV)
                          (map impName imps)
  
          -- sign: the signature file
          sign = CSignature currentPkg impids fixs ss'
  
          -- missingExportNames: types (defined in this package) which are
          --     used in exported signatures, but are not themselves exported
          --     (to be reported as an error)
          missingExportNames = ([name | (CItype (IdKind name _) _ _) <- udef] ++
                                [name | (CItype (IdK name ) _ _) <- udef])
          mkETypeNotExported name =
              let unexpName = pfpString (unQualId name)
                  err = internalError ("GenSign.genSign.mkTypeNotExported (" ++
                                       pfpString name ++ ")")
                  defIds = M.findWithDefault err name useLoci
                  defNamesPos = [(pfpString (unQualId name), getIdPosition name)
                                    | name <- defIds]
              in  ETypeNotExported unexpName defNamesPos
  
          -- missing exports: type errors for identifiers that
          --   - have not been exported
          --   - are defined in this package
          --   - are used in an exported definition (except hidden data defs)
          missingExports =
              [(getIdPosition name, mkETypeNotExported name)
                  | name <- missingExportNames,
                    -- has uses which aren't hidden
                    name `M.member` useLoci]
  
          errors = packageErrors ++ missingExports ++ badExports
  
          -- sanity check
          failedExports = ([] :: [Id])
           {- -- only needed for debugging
              let ss_names = [ i | (Right i) <- map getName ss ]
                  exp_names = map eName exps
              in  -- duplicates are OK because they are qualified
                  filter (`notElem` ss_names) exp_names
           -}
      in
  {-
          trace ("\nexps=\n" ++ ppReadable exps ++
                 "\n\ndefs=\n" ++ ppReadable ds ++
                 "\n\nem=\n" ++ ppReadable (M.toList em) ++
                 "\n\nss=\n" ++ ppReadable ss ++
                 "\n\nudef=\n" ++ ppReadable udef ++
                 "\n\nss'=\n" ++ ppReadable ss' ++ "\n\n") $
  -}
          case errors of
              [] -> if (not (null failedExports))
                    then internalError ("failed exports: " ++
                                        ppReadable failedExports)
                    else Right (sign, warns)
              errs -> Left errs
  
  -- ---------------
  
  -- get the name of an export
  eName :: CExport -> Id
  eName (CExpVar i) = i
  eName (CExpCon i) = i
  eName (CExpConAll i) = i
  eName (CExpPkg {}) = internalError "non-desugared package export"
  
  -- ---------------
  
  {- -- Unused
  getInsts (CPackage _ _ imps _ pds includes) =
          [ i | CImpSign _ _ (CSignature _ _ _ ds) <- imps, i@(CIinstance _ (CQType _ t)) <- ds,
                not (all (fromPrelude . leftTyCon) (t : tyConArgs t)) ]
  -- XXX Might break if a Prelude type was declared outside the Prelude to be an
  --        instance of a Prelude typeclass, and an attempt was made to use that
  --        instance in a third file.
  
  fromPrelude (Just (TyCon i _ _)) = (getIdQFString i == Just fsPrelude
                                      || getIdQFString i == Just fsPreludeBSV)
  fromPrelude _ = True
  -}
  
  -- ---------------
  
  -- XXX export from symbol table
  -- check export list
  genDefSign :: SymTab -> (Id -> Maybe Bool) -> Id -> CDefn -> [(CDefn, [WMsg])]
  genDefSign s look currentPkg d@(Ctype ik vs t) =
    let i = iKName ik
        qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
      Just _ -> [(Ctype (qualIdK currentPkg s ik) vs (qualType s t), [])]
  genDefSign s look currentPkg d@(Cdata { cd_visible = vis,
                                          cd_name = ik,
                                          cd_type_vars = vs,
                                          cd_original_summands = ocs,
                                          cd_internal_summands = cs }) =
    let i = iKName ik
        qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
  --    Just False -> [CItype (qualIdK currentPkg s ik) vs]
      Just vis' -> [(Cdata { cd_visible = vis && vis',
                            cd_name = qualIdK currentPkg s ik,
                            cd_type_vars = vs,
                            cd_original_summands = map qual_original_summand ocs,
                            cd_internal_summands = map qual_internal_summand cs,
                            cd_derivings = [] }, [])]
                   where qual_original_summand summand =
                             summand { cos_names = map (qualId currentPkg)
                                                    (cos_names summand) }
                         qual_internal_summand summand =
                             summand { cis_names = map (qualId currentPkg)
                                                    (cis_names summand),
                                       cis_arg_type = (qualType s
                                                       (cis_arg_type summand)) }
  
  genDefSign s look currentPkg d@(Cstruct vis ss@(SDataCon i _) ik vs fs _) =
    let qi = qualId currentPkg i
    in
      case look qi of
      Just True -> [(Cstruct vis ss (qualIdK currentPkg s ik) vs (qualFields currentPkg s fs) [], [])]
      _ -> []
  genDefSign s look currentPkg d@(Cstruct vis ss ik vs fs _) =
    let i = iKName ik
        qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
  --    Just False -> [CItype (qualIdK currentPkg s ik) vs]
      Just vis' -> [(Cstruct (vis && vis') ss (qualIdK currentPkg s ik) vs (qualFields currentPkg s fs) [], [])]
  genDefSign s look currentPkg (Cclass incoh ps ik vs fds fs) =
    let i = iKName ik
        qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
      Just True -> [(Cclass incoh (map (qualPred s) ps) (qualIdK currentPkg s ik) vs fds (qualFields currentPkg s fs),[])]
      Just False -> [(CIclass incoh (map (qualPred s) ps) (qualIdK currentPkg s ik) vs fds [getPosition ik], [])]
  genDefSign s look currentPkg d@(Cinstance qt@(CQType ps t) _) =
      -- trace (ppReadable (leftCon t, map leftCon (tyConArgs t))) $
      let tcs = leftTyCons (t : tyConArgs t) in
      if all (\c -> exported c || imported c) tcs then
          [(CIinstance currentPkg (qualCQType s qt), [(getPosition d, WOrphanInst (pfpString (expandSyn t))) | orphan_inst ])]
      else
          []
    where leftTyCons = mapMaybe leftTyCon
          addQual i = if (getIdQual i == fsEmpty)
                      then qualId currentPkg i
                      else i
          exported (TyCon _ _ (TIstruct (SDataCon i _) _)) =
              look (addQual i) == Just True
          -- there's a special case since we can't export -> from the Prelude
          exported c@(TyCon i _ _) =
              look (addQual i) /= Nothing ||
                                  (isTConArrow c && getIdFString currentPkg == fsPrelude)
          exported (TyStr _ _) = False
          exported (TyNum _ _) = False
          imported (TyCon i _ _) = getIdQual i /= getIdFString currentPkg
          -- TyNum/TyStr are imported for the purposes of the "orphan check"
          imported (TyNum _ _) = True
          imported (TyStr _ _) = True
          fj1 = fromJustOrErr ("bad instance con: " ++ ppReadable qt)
          cls_tcon = fj1 $ leftTyCon t
          cls_con_name = CTypeclass $ fj1 $ leftCon t
          fj2 = fromJustOrErr ("missing instance class: " ++ ppReadable qt)
          cls = fj2 $ findSClass s cls_con_name
          inst_cls_args = map expandSyn (tyConArgs t)
          fd_sigs = map (map not) (funDeps cls)
          inst_heads = zipWith boolCompress fd_sigs (repeat inst_cls_args)
          orphan_head = not . (any exported) . (concatMap allTyCons)
          orphan_inst = imported (cls_tcon) && any orphan_head inst_heads
  
  genDefSign s look currentPkg (CValueSign (CDef i qt _)) =
    let qi = qualId currentPkg i
    in  case look qi of
          Nothing -> []
          Just _ -> [(CIValueSign qi (qualCQType s qt), [])]
  genDefSign s look currentPkg (Cforeign i qt ms mps) =
    let qi = qualId currentPkg i
    in  case look qi of
          Nothing -> []
          Just _ -> [(Cforeign qi (qualCQType s qt) ms mps, [])]
  genDefSign s look currentPkg (Cprimitive i qt) =
    let qi = qualId currentPkg i
    in  case look qi of
          Nothing -> []
          Just _ -> [(Cprimitive qi (qualCQType s qt), [])]
  genDefSign s look currentPkg (CprimType ik) =
    let i = iKName ik
        qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
      Just _ -> [(CprimType (qualIdK currentPkg s ik), [])]
  genDefSign s look currentPkg (CIValueSign i qt) =
    let qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
      Just _ -> [(CIValueSign i qt, [])]
  genDefSign s look currentPkg (CItype ik vs poss) =
    let i = iKName ik
        qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
      Just _ -> [(CItype ik vs poss, [])]
  genDefSign s look currentPkg (CPragma (Pproperties i props)) =
    let qi = qualId currentPkg i
    in
      case look qi of
      Nothing -> []
      Just _ ->
          -- preserve certain pragmas
          -- (so far, just the "deprecate" pprop)
          let props' = [ p | p@(PPdeprecate _) <- props ]
          in  if (null props')
              then []
              else [(CPragma (Pproperties i props'), [])]
  genDefSign s look currentPkg d = []
  
  -- ---------------
  
  qualIdK :: Id -> SymTab -> IdK -> IdK
  qualIdK currentPkg s (IdKind i k) = IdKind (qualId currentPkg i) k
  qualIdK currentPkg s idk =
      let i = iKName idk
      in  case findType s i of
            Just (TypeInfo (Just i') k _ _) -> IdKind i' k
            Nothing -> IdK (qualId currentPkg i)
            Just (TypeInfo Nothing k _ _) ->
              internalError ("qualIdK: unexpected numeric type: " ++
                             ppReadable i)
  
  qualCQType :: SymTab -> CQType -> CQType
  qualCQType s (CQType ps t) = CQType (map (qualPred s) ps) (qualType s t)
  
  qualPred :: SymTab -> CPred -> CPred
  qualPred s (CPred (CTypeclass i) ts) = CPred (CTypeclass (qualTId s i)) (map (qualType s) ts)
  
  qualFields :: Id -> SymTab -> CFields -> CFields
  qualFields currentPkg s fs = [f { cf_name = qualId currentPkg (cf_name f),
                                    cf_type = qualCQType s (cf_type f) }
                                | f <- fs ]
  
  qualType :: SymTab -> CType -> CType
  qualType s (TCon (TyCon i k si)) = TCon (TyCon (qualTId s i) k si)
  qualType s t@(TCon (TyNum _ _)) = t
  qualType s t@(TCon (TyStr _ _)) = t
  qualType s t@(TVar _) = t
  qualType s (TAp t t') = TAp (qualType s t) (qualType s t')
  qualType s t@(TGen _ _) = t
  qualType s t@(TDefMonad _) = internalError "qualType: TDefMonad"
  
  qualTId :: SymTab -> Id -> Id
  qualTId s i =
      case findType s i of
      Just (TypeInfo (Just i') _ _ _) -> i'
      Just (TypeInfo Nothing _ _ _) ->
          internalError ("qualTId: unexpected numeric type: " ++ ppReadable i)
      Nothing -> i
  
  -- ---------------
  
  -- Given a def, return its (qualified) export if it should be exported
  -- (dummies and generated ifc should not).
  -- This is mapped over the defs in a package in order to force export of
  -- all definitions.
  defExport :: FString -> CDefn -> [CExport]
  defExport pkgName def =
      case (getName def) of
        Left _ -> []
        Right i ->
            let qual_i = setIdQual i pkgName
            in  if (hasIdProp i IdPGeneratedIfc) then []
                else if (isTDef def)             then [CExpConAll qual_i]
                                                 else [CExpVar qual_i]
  
  -- given full expors of everything in this file and a list of explicit
  -- exports, union in any explicit exports not from this file.
  -- "union" doesn't work, because the user could have exported a local
  -- type without its constructors, and we want to throw that out in favor
  -- of exporting the type fully.
  mergeExports :: [CExport] -> [CExport] -> [CExport]
  mergeExports all_exps_this_file user_exps =
      let eq (CExpVar i)    (CExpVar i')    = (i == i')
          eq (CExpConAll i) (CExpCon i')    = (i == i')
          eq (CExpConAll i) (CExpConAll i') = (i == i')
          -- these two should never come up in the "union"
          eq (CExpCon i)    (CExpConAll i') = (i == i')
          eq (CExpPkg i)    (CExpPkg i')    = (i == i')
          eq _              _               = False
      in
          unionBy eq all_exps_this_file user_exps
  
  -- ---------------
  
  qualifyExports :: Bool -> SymTab -> [CExport] -> ([CExport], [EMsg])
  qualifyExports exclude symt exps =
      let
          mkUnboundExport i = (getIdPosition i, EUnboundExport (pfpString i) exclude)
          mkDupExport i = (getIdPosition i, EDuplicateExport (pfpString i) exclude)
          mkIdInPkgExport (i, p) =
              (getIdPosition i,
               EDuplicateDefInPackageExport (getFString p) (pfpString i))
  
          qualifyType c i =
              case (findType symt i) of
                -- if the name was unqualified, now it will be qualified
                Just (TypeInfo (Just i') _ _ _) -> Left (c i')
                Nothing -> Right (mkUnboundExport i)
                Just _ -> internalError ("qualifyPkgExports: " ++
                                         "unexpected numeric type: " ++
                                         ppReadable i)
  
          qualifyVar c i =
              case (findVar symt i) of
                -- if the name was unqualified, now it will be qualified
                Just (VarInfo _ (i' :>: _) _) -> Left (c i')
                Nothing -> Right (mkUnboundExport i)
  
          addId i (Left exp) = Left (i, exp)
          addId _ (Right msg) = Right msg
  
          -- * Either is used to identify error vs success
          -- * exports are paired with the original Id for better
          --   error messages (position and qualifier)
          qualifyExp e@(CExpVar i) = addId i $ qualifyVar CExpVar i
          qualifyExp e@(CExpCon i) = addId i $ qualifyType CExpCon i
          qualifyExp e@(CExpConAll i) = addId i $ qualifyType CExpConAll i
          -- when package exports are expanded, they will be qualified
          qualifyExp e@(CExpPkg p) = addId p $ Left e
  
          (qual_exp_pairs, unboundErrs) = separate $ map qualifyExp exps
          qual_exps = map snd qual_exp_pairs
  
          -- report duplicate identifiers, duplicate packages, and when
          -- an identifier is also covered by a package
          (exp_pkgs, exp_ids) =
              let isPkg (_, CExpPkg p) = Left p
                  isPkg (i, e) = Right (i, eName e)
              in  separate (map isPkg qual_exp_pairs)
          duplicate_pkgs =
              concatMap (tailOrErr "duplicate_pkgs") (findSame exp_pkgs)
          -- keep the qualified Ids for filtering id_vs_pkg duplicates
          duplicate_ids =
              let cmpSnd (_,x) (_,y) = x `compare` y
                  eqSnd  (_,x) (_,y) = x == y
              in  concatMap (map fst . tailOrErr "duplicate_exps") $
                      findSameBy cmpSnd eqSnd  exp_ids
          duplicate_id_vs_pkg =
              let pkgSet = S.fromList (map getIdBase exp_pkgs)
                  isDup (_,i) = S.member (getIdQual i) pkgSet
                  qual_dups = filter isDup exp_ids
                  -- only report one overlap
                  eqSnd  (_,x) (_,y) = x == y
                  unique_qual_dup = map (headOrErr "duplicate_id_vs_pkg") $
                                        groupBy eqSnd qual_dups
              in  map (\(i,e) -> (i, getIdQual e)) unique_qual_dup
          duplicateErrs =
              map mkDupExport duplicate_ids ++
              map mkDupExport duplicate_pkgs ++
              map mkIdInPkgExport duplicate_id_vs_pkg
     in
          (qual_exps, unboundErrs ++ duplicateErrs)
  
  -- ---------------
  
  -- replace the re-export of a package with re-export of its contents
  -- (we choose to not export those Ids which are shadowed by other defs,
  -- so this function takes the symbol table, as a way to check whether
  -- the unqualified name refers to the qualified name that we are exporting)
  expandPkgExports :: SymTab -> [CImport] -> [CExport] -> ([CExport], [EMsg])
  expandPkgExports symt imps exps =
      let
          unqualTypeIsThisOne i =
              case (findType symt (unQualId i)) of
                Just (TypeInfo (Just i') _ _ _) -> getIdQual i' == getIdQual i
                _ -> False
  
          unqualVarIsThisOne i =
              case (findVar symt (unQualId i)) of
                Just (VarInfo _ (i' :>: _) _) -> getIdQual i' == getIdQual i
                _ -> False
  
          expandOne :: CExport -> Either [CExport] EMsg
          expandOne (CExpPkg pkg) =
              let dss = [ ds | (CImpSign _ _ (CSignature i _ _ ds)) <- imps,
                               i == pkg ]
              in  case (dss) of
                      [] -> let pos = getPosition pkg
                            in  Right (pos, EUnboundPackage (pvpString pkg))
                      (ds:_) -> Left $ mapMaybe pkgExport ds
          expandOne e = Left [e]
  
          -- function to re-export a def
          pkgExport :: CDefn -> Maybe CExport
          pkgExport def =
              case (getName def) of
                -- don't export unnamed defs (instances, pragmas, etc)
                Left _ -> Nothing
                Right i ->
                    let isShadowed =
                            if (isTDef def)
                            then not (unqualTypeIsThisOne i)
                            else not (unqualVarIsThisOne i)
                        isAbstractTDef (CItype {}) = True
                        isAbstractTDef _           = False
                    in
                        -- don't declare shadowed or hidden names
                        -- XXX or do we only want to not declare those shadowed by
                        -- XXX other exports?
                        if isShadowed                then Nothing
                        -- types exported abstractly
                        else if (isAbstractTDef def) then Just $ CExpCon i
                        -- all other types export fully
                        else if (isTDef def)         then Just $ CExpConAll i
                        -- non-types
                                                     else Just $ CExpVar i
      in
          apFst concat $ separate $ map expandOne exps
  
  -- ---------------
  
  classToIClass :: Id -> Kind -> Class -> [Position] -> CDefn
  classToIClass i k (Class { csig=tvs, super=ps, funDeps2=bss2,
                             allowIncoherent = incoh}) poss =
      let getTVarId (TyVar i _ _) = i
          tvis = map getTVarId tvs
  
          -- This create CIclass with the user-given names for type vars.
          -- It uses the names from "csig" in the Class, but it could also
          -- have used the Ids from the TypeInfo.
  
          -- convert (Id,Pred) to CPred
          ps' = map (predToCPred . snd) ps
  
          -- reconstruct the fundeps from bss2
          bsToFd bs =
              let bis = zip bs tvis
                  foldFn (b,i) iss@(is1, is2) =
                      case b of
                          Nothing -> iss
                          Just True  -> (is1, i:is2)
                          Just False -> (i:is1, is2)
              in  foldr foldFn ([],[]) bis
          fds = map bsToFd bss2
      in
          CIclass incoh ps' (IdKind i k) tvis fds poss
  
  -- ---------------
  