1 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
2 {-% DrIFT (Automatic class derivations for Haskell) v1.1 %-}
4 -- (c) The University of Glasgow 2002
6 -- Binary interface file support.
8 module BinIface ( writeBinIface, readBinIface ) where
10 #include "HsVersions.h"
19 import HsPat ( HsConDetails(..) )
24 import RdrName ( mkRdrUnqual, mkRdrQual )
25 import Name ( Name, nameOccName, nameModule_maybe )
26 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts )
27 import Module ( moduleName )
28 import OccName ( OccName )
30 import DriverState ( v_Build_tag )
31 import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion )
36 import DATA_IOREF ( readIORef )
37 import EXCEPTION ( throwDyn )
40 #include "HsVersions.h"
42 -- ---------------------------------------------------------------------------
43 -- We write out a ModIface, but read it in as a ParsedIface.
44 -- There are some big differences, and some subtle ones. We do most
45 -- of the conversion on the way out, so there is minimal fuss when we
46 -- read it back in again (see RnMonad.lhs)
48 -- The main difference is that all Names in a ModIface are RdrNames in
49 -- a ParsedIface, so when writing out a Name in binary we make sure it
50 -- is binary-compatible with a RdrName.
52 -- Other subtle differences:
53 -- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put
54 -- Modules as ModuleNames.
55 -- - pi_exports and pi_usages, Names have
56 -- to be converted to OccNames.
57 -- - pi_fixity is a NameEnv in ModIface,
58 -- but a list of (Name,Fixity) pairs in ParsedIface.
59 -- - versioning is totally different.
60 -- - deprecations are different.
62 writeBinIface :: FilePath -> ModIface -> IO ()
63 writeBinIface hi_path mod_iface
64 = putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
66 readBinIface :: FilePath -> IO ParsedIface
67 readBinIface hi_path = getBinFileWithDict hi_path
70 -- %*********************************************************
72 -- All the Binary instances
74 -- %*********************************************************
77 {-! for IPName derive: Binary !-}
78 {-! for Fixity derive: Binary !-}
79 {-! for FixityDirection derive: Binary !-}
80 {-! for NewOrData derive: Binary !-}
81 {-! for Boxity derive: Binary !-}
82 {-! for StrictnessMark derive: Binary !-}
83 {-! for Activation derive: Binary !-}
85 instance Binary Name where
86 -- we must print these as RdrNames, because that's how they will be read in
88 = case nameModule_maybe name of
90 | this_mod == mod -> put_ bh (mkRdrUnqual occ)
91 | otherwise -> put_ bh (mkRdrQual (moduleName mod) occ)
92 _ -> put_ bh (mkRdrUnqual occ)
94 occ = nameOccName name
95 (this_mod,_,_,_) = getUserData bh
97 get bh = error "can't Binary.get a Name"
100 {-! for Demand derive: Binary !-}
101 {-! for Demands derive: Binary !-}
102 {-! for DmdResult derive: Binary !-}
103 {-! for StrictSig derive: Binary !-}
105 instance Binary DmdType where
106 -- ignore DmdEnv when spitting out the DmdType
107 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
108 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
111 {-! for DataConDetails derive: Binary !-}
114 {-! for DefMeth derive: Binary !-}
117 {-! for HsPred derive: Binary !-}
118 {-! for HsType derive: Binary !-}
119 {-! for HsTupCon derive: Binary !-}
120 {-! for HsTyVarBndr derive: Binary !-}
123 {-! for UfExpr derive: Binary !-}
124 {-! for UfConAlt derive: Binary !-}
125 {-! for UfBinding derive: Binary !-}
126 {-! for UfBinder derive: Binary !-}
127 {-! for HsIdInfo derive: Binary !-}
128 {-! for UfNote derive: Binary !-}
131 {-! for ConDetails derive: Binary !-}
132 {-! for BangType derive: Binary !-}
134 instance (Binary name) => Binary (TyClDecl name) where
135 put_ bh (IfaceSig name ty idinfo _) = do
140 put_ bh (ForeignType ae af ag ah) =
141 error "Binary.put_(TyClDecl): ForeignType"
142 put_ bh (TyData ai aj ak al am _ (Just generics) _) = do
150 put_ bh generics -- Record whether generics needed or not
151 put_ bh (TySynonym aq ar as _) = do
156 put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ _) = do
163 -- ignore methods (there should be none)
172 let idinfo' | opt_IgnoreIfacePragmas = []
174 return (IfaceSig name ty idinfo' noSrcLoc)
175 1 -> error "Binary.get(TyClDecl): ForeignType"
183 return (TyData n_or_d ctx nm tyvars cons
184 Nothing (Just generics) noSrcLoc)
189 return (TySynonym aq ar as noSrcLoc)
196 return (ClassDecl ctxt nm tyvars fds sigs
199 instance (Binary name) => Binary (ConDecl name) where
200 put_ bh (ConDecl aa ac ad ae _) = do
211 return (ConDecl aa ac ad ae noSrcLoc)
213 instance (Binary name) => Binary (InstDecl name) where
214 put_ bh (InstDecl aa _ _ ad _) = do
223 return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc)
225 instance (Binary name) => Binary (RuleDecl name) where
226 put_ bh (IfaceRule ag ah ai aj ak al _) = do
234 get bh = do ag <- get bh
240 return (IfaceRule ag ah ai aj ak al noSrcLoc)
242 instance (Binary name) => Binary (DeprecDecl name) where
243 put_ bh (Deprecation aa ab _) = do
250 return (Deprecation aa ab noSrcLoc)
253 instance Binary name => Binary (Sig name) where
254 put_ bh (ClassOpSig n def ty _) = do put_ bh n; put_ bh def; put_ bh ty
259 return (ClassOpSig n def ty noSrcLoc)
262 {-! for IsCafCC derive: Binary !-}
263 {-! for IsDupdCC derive: Binary !-}
264 {-! for CostCentre derive: Binary !-}
268 instance Binary ModIface where
270 build_tag <- readIORef v_Build_tag
271 put_ bh (show opt_HiVersion ++ build_tag)
272 p <- put_ bh (moduleName (mi_module iface))
273 put_ bh (mi_package iface)
274 put_ bh (vers_module (mi_version iface))
275 put_ bh (mi_orphan iface)
277 lazyPut bh (mi_deps iface)
278 lazyPut bh (map usageToOccName (mi_usages iface))
279 put_ bh (vers_exports (mi_version iface),
280 map exportItemToRdrExportItem (mi_exports iface))
281 put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
282 (vers_decls (mi_version iface)))
284 put_ bh (collectFixities (mi_fixities iface)
285 (dcl_tycl (mi_decls iface)))
286 put_ bh (dcl_insts (mi_decls iface))
287 lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
288 lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))
290 -- Read in as a ParsedIface, not a ModIface. See above.
291 get bh = error "Binary.get: ModIface"
293 declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
294 -> [(Version, RenamedTyClDecl)]
295 declsToVersionedDecls decls env
298 case lookupNameEnv env (tyClDeclName d) of
299 Nothing -> (initialVersion, d)
303 --NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs
304 deprecsToIfaceDeprecs NoDeprecs = Nothing
305 deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt)
306 deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))
309 {-! for GenAvailInfo derive: Binary !-}
310 {-! for WhatsImported derive: Binary !-}
312 -- For binary interfaces we need to convert the ImportVersion Names to OccNames
313 usageToOccName :: Usage Name -> Usage OccName
315 = usg { usg_entities = [ (nameOccName n, v) | (n,v) <- usg_entities usg ] }
317 exportItemToRdrExportItem (mn, avails)
318 = (mn, map availInfoToRdrAvailInfo avails)
320 availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo
321 availInfoToRdrAvailInfo (Avail n)
322 = Avail (nameOccName n)
323 availInfoToRdrAvailInfo (AvailTC n ns)
324 = AvailTC (nameOccName n) (map nameOccName ns)
326 -- ---------------------------------------------------------------------------
327 -- Reading a binary interface into ParsedIface
329 instance Binary ParsedIface where
331 pi_mod = module_name,
333 pi_vers = module_ver,
336 pi_exports = exports,
337 pi_decls = tycl_decls,
338 pi_fixity = fixities,
341 pi_deprecs = deprecs } = do
342 build_tag <- readIORef v_Build_tag
343 put_ bh (show opt_HiVersion ++ build_tag)
357 build_tag <- readIORef v_Build_tag
358 let our_ver = show opt_HiVersion ++ build_tag
359 when (check_ver /= our_ver) $
360 -- use userError because this will be caught by readIface
361 -- which will emit an error msg containing the iface module name.
362 throwDyn (ProgramError (
363 "mismatched interface file versions: expected "
364 ++ our_ver ++ ", found " ++ check_ver))
365 module_name <- get bh -- same rep. as Module, so that's ok
370 usages <- {-# SCC "bin_usages" #-} lazyGet bh
371 exports <- {-# SCC "bin_exports" #-} get bh
372 tycl_decls <- {-# SCC "bin_tycldecls" #-} get bh
373 fixities <- {-# SCC "bin_fixities" #-} get bh
374 insts <- {-# SCC "bin_insts" #-} get bh
375 rules <- {-# SCC "bin_rules" #-} lazyGet bh
376 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
377 return (ParsedIface {
378 pi_mod = module_name,
380 pi_vers = module_ver,
384 pi_exports = exports,
385 pi_decls = tycl_decls,
386 pi_fixity = fixities,
387 pi_insts = reverse insts,
389 pi_deprecs = deprecs })
391 -- ----------------------------------------------------------------------------
392 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
394 -- Imported from other files :-
396 instance Binary Dependencies where
397 put_ bh deps = do put_ bh (dep_mods deps)
398 put_ bh (dep_pkgs deps)
399 put_ bh (dep_orphs deps)
401 get bh = do ms <- get bh
404 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
406 instance (Binary name) => Binary (GenAvailInfo name) where
407 put_ bh (Avail aa) = do
410 put_ bh (AvailTC ab ac) = do
421 return (AvailTC ab ac)
423 instance (Binary name) => Binary (Usage name) where
425 put_ bh (usg_name usg)
426 put_ bh (usg_mod usg)
427 put_ bh (usg_exports usg)
428 put_ bh (usg_entities usg)
429 put_ bh (usg_rules usg)
437 return (Usage { usg_name = nm, usg_mod = mod,
438 usg_exports = exps, usg_entities = ents,
441 instance Binary Activation where
442 put_ bh NeverActive = do
444 put_ bh AlwaysActive = do
446 put_ bh (ActiveBefore aa) = do
449 put_ bh (ActiveAfter ab) = do
455 0 -> do return NeverActive
456 1 -> do return AlwaysActive
458 return (ActiveBefore aa)
460 return (ActiveAfter ab)
462 instance Binary StrictnessMark where
463 put_ bh MarkedUserStrict = do
465 put_ bh MarkedStrict = do
467 put_ bh MarkedUnboxed = do
469 put_ bh NotMarkedStrict = do
474 0 -> do return MarkedUserStrict
475 1 -> do return MarkedStrict
476 2 -> do return MarkedUnboxed
477 _ -> do return NotMarkedStrict
479 instance Binary Boxity where
488 _ -> do return Unboxed
490 instance Binary NewOrData where
493 put_ bh DataType = do
498 0 -> do return NewType
499 _ -> do return DataType
501 instance Binary FixityDirection where
511 0 -> do return InfixL
512 1 -> do return InfixR
513 _ -> do return InfixN
515 instance Binary Fixity where
516 put_ bh (Fixity aa ab) = do
522 return (Fixity aa ab)
524 instance (Binary name) => Binary (FixitySig name) where
525 put_ bh (FixitySig aa ab _) = do
531 return (FixitySig aa ab noSrcLoc)
533 instance (Binary name) => Binary (IPName name) where
534 put_ bh (Dupable aa) = do
537 put_ bh (Linear ab) = do
548 instance Binary Demand where
553 put_ bh (Call aa) = do
556 put_ bh (Eval ab) = do
559 put_ bh (Defer ac) = do
562 put_ bh (Box ad) = do
582 instance Binary Demands where
583 put_ bh (Poly aa) = do
586 put_ bh (Prod ab) = do
597 instance Binary DmdResult where
607 0 -> do return TopRes
608 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
609 -- The wrapper was generated for CPR in
610 -- the imported module!
611 _ -> do return BotRes
613 instance Binary StrictSig where
614 put_ bh (StrictSig aa) = do
618 return (StrictSig aa)
620 instance (Binary name) => Binary (HsTyVarBndr name) where
621 put_ bh (UserTyVar aa) = do
624 put_ bh (IfaceTyVar ab ac) = do
632 return (UserTyVar aa)
635 return (IfaceTyVar ab ac)
637 instance Binary HsTupCon where
638 put_ bh (HsTupCon ab ac) = do
644 return (HsTupCon ab ac)
646 instance (Binary name) => Binary (HsTyOp name) where
647 put_ bh HsArrow = putByte bh 0
648 put_ bh (HsTyOp n) = do putByte bh 1
651 get bh = do h <- getByte bh
657 instance (Binary name) => Binary (HsType name) where
658 put_ bh (HsForAllTy aa ab ac) = do
663 put_ bh (HsTyVar ad) = do
666 put_ bh (HsAppTy ae af) = do
670 put_ bh (HsFunTy ag ah) = do
674 put_ bh (HsListTy ai) = do
677 put_ bh (HsPArrTy aj) = do
680 put_ bh (HsTupleTy ak al) = do
684 put_ bh (HsOpTy am an ao) = do
689 put_ bh (HsNumTy ap) = do
692 put_ bh (HsPredTy aq) = do
695 put_ bh (HsKindSig ar as) = do
705 return (HsForAllTy aa ab ac)
710 return (HsAppTy ae af)
713 return (HsFunTy ag ah)
720 return (HsTupleTy ak al)
724 return (HsOpTy am an ao)
731 return (HsKindSig ar as)
733 instance (Binary name) => Binary (HsPred name) where
734 put_ bh (HsClassP aa ab) = do
738 put_ bh (HsIParam ac ad) = do
747 return (HsClassP aa ab)
750 return (HsIParam ac ad)
752 instance (Binary name) => Binary (UfExpr name) where
753 put_ bh (UfVar aa) = do
756 put_ bh (UfType ab) = do
759 put_ bh (UfTuple ac ad) = do
763 put_ bh (UfLam ae af) = do
767 put_ bh (UfApp ag ah) = do
771 put_ bh (UfCase ai aj ak) = do
776 put_ bh (UfLet al am) = do
780 put_ bh (UfNote an ao) = do
784 put_ bh (UfLit ap) = do
787 put_ bh (UfLitLit aq ar) = do
791 put_ bh (UfFCall as at) = do
804 return (UfTuple ac ad)
814 return (UfCase ai aj ak)
820 return (UfNote an ao)
825 return (UfLitLit aq ar)
828 return (UfFCall as at)
830 instance (Binary name) => Binary (UfConAlt name) where
831 put_ bh UfDefault = do
833 put_ bh (UfDataAlt aa) = do
836 put_ bh (UfTupleAlt ab) = do
839 put_ bh (UfLitAlt ac) = do
842 put_ bh (UfLitLitAlt ad ae) = do
849 0 -> do return UfDefault
851 return (UfDataAlt aa)
853 return (UfTupleAlt ab)
858 return (UfLitLitAlt ad ae)
860 instance (Binary name) => Binary (UfBinding name) where
861 put_ bh (UfNonRec aa ab) = do
865 put_ bh (UfRec ac) = do
873 return (UfNonRec aa ab)
877 instance (Binary name) => Binary (UfBinder name) where
878 put_ bh (UfValBinder aa ab) = do
882 put_ bh (UfTyBinder ac ad) = do
891 return (UfValBinder aa ab)
894 return (UfTyBinder ac ad)
896 instance (Binary name) => Binary (HsIdInfo name) where
897 put_ bh (HsArity aa) = do
900 put_ bh (HsStrictness ab) = do
903 put_ bh (HsUnfold ac ad) = do
907 put_ bh HsNoCafRefs = do
909 put_ bh (HsWorker ae af) = do
919 return (HsStrictness ab)
922 return (HsUnfold ac ad)
923 3 -> do return HsNoCafRefs
926 return (HsWorker ae af)
928 instance (Binary name) => Binary (UfNote name) where
929 put_ bh (UfSCC aa) = do
932 put_ bh (UfCoerce ab) = do
935 put_ bh UfInlineCall = do
937 put_ bh UfInlineMe = do
946 2 -> do return UfInlineCall
947 _ -> do return UfInlineMe
949 instance (Binary name) => Binary (BangType name) where
950 put_ bh (BangType aa ab) = do
956 return (BangType aa ab)
958 instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
959 put_ bh (PrefixCon aa) = do
962 put_ bh (InfixCon ab ac) = do
966 put_ bh (RecCon ad) = do
973 return (PrefixCon aa)
976 return (InfixCon ab ac)
980 instance (Binary datacon) => Binary (DataConDetails datacon) where
981 put_ bh (DataCons aa) = do
986 put_ bh (HasCons ab) = do
994 1 -> do return Unknown
998 instance (Binary id) => Binary (DefMeth id) where
999 put_ bh NoDefMeth = do
1001 put_ bh (DefMeth aa) = do
1004 put_ bh GenDefMeth = do
1009 0 -> do return NoDefMeth
1010 1 -> do aa <- get bh
1012 _ -> do return GenDefMeth
1014 instance Binary IsCafCC where
1017 put_ bh NotCafCC = do
1022 0 -> do return CafCC
1023 _ -> do return NotCafCC
1025 instance Binary IsDupdCC where
1026 put_ bh OriginalCC = do
1033 0 -> do return OriginalCC
1034 _ -> do return DupdCC
1036 instance Binary CostCentre where
1037 put_ bh NoCostCentre = do
1039 put_ bh (NormalCC aa ab ac ad) = do
1045 put_ bh (AllCafsCC ae) = do
1051 0 -> do return NoCostCentre
1052 1 -> do aa <- get bh
1056 return (NormalCC aa ab ac ad)
1057 _ -> do ae <- get bh
1058 return (AllCafsCC ae)