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 ) where
21 import Name ( Name, nameOccName )
22 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts )
23 import OccName ( OccName )
24 import RnMonad ( ParsedIface(..) )
26 import DriverState ( v_Build_tag )
27 import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion )
28 import StringBuffer ( hGetStringBuffer )
34 import IOExts ( readIORef )
36 import Exception ( throwDyn )
38 #include "HsVersions.h"
41 {-! for IPName derive: Binary !-}
42 {-! for Fixity derive: Binary !-}
43 {-! for FixityDirection derive: Binary !-}
44 {-! for NewOrData derive: Binary !-}
45 {-! for Boxity derive: Binary !-}
46 {-! for StrictnessMark derive: Binary !-}
47 {-! for Activation derive: Binary !-}
50 {-! for Demand derive: Binary !-}
51 {-! for Demands derive: Binary !-}
52 {-! for DmdResult derive: Binary !-}
53 {-! for StrictSig derive: Binary !-}
55 instance Binary DmdType where
56 -- ignore DmdEnv when spitting out the DmdType
57 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
58 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
61 {-! for DataConDetails derive: Binary !-}
64 {-! for DefMeth derive: Binary !-}
67 {-! for HsPred derive: Binary !-}
68 {-! for HsType derive: Binary !-}
69 {-! for HsTupCon derive: Binary !-}
70 {-! for HsTyVarBndr derive: Binary !-}
73 {-! for UfExpr derive: Binary !-}
74 {-! for UfConAlt derive: Binary !-}
75 {-! for UfBinding derive: Binary !-}
76 {-! for UfBinder derive: Binary !-}
77 {-! for HsIdInfo derive: Binary !-}
78 {-! for UfNote derive: Binary !-}
81 {-! for ConDetails derive: Binary !-}
82 {-! for BangType derive: Binary !-}
84 instance (Binary name) => Binary (TyClDecl name pat) where
85 put_ bh (IfaceSig name ty idinfo _) = do
90 put_ bh (ForeignType ae af ag ah) =
91 error "Binary.put_(TyClDecl): ForeignType"
92 put_ bh (TyData ai aj ak al am an ao _) = do
100 put_ bh ao -- store the SysNames for now (later: derive them)
101 put_ bh (TySynonym aq ar as _) = do
106 put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ sysnames _) = do
113 -- ignore methods (there should be none)
123 let idinfo' | opt_IgnoreIfacePragmas = []
125 return (IfaceSig name ty idinfo' noSrcLoc)
126 1 -> error "Binary.get(TyClDecl): ForeignType"
134 return (TyData n_or_d ctx nm tyvars cons
135 Nothing sysnames noSrcLoc)
140 return (TySynonym aq ar as noSrcLoc)
148 return (ClassDecl ctxt nm tyvars fds sigs
149 Nothing sysnames noSrcLoc)
151 instance (Binary name) => Binary (ConDecl name) where
152 put_ bh (ConDecl aa ab ac ad ae _) = do
165 return (ConDecl aa ab ac ad ae noSrcLoc)
167 instance (Binary name) => Binary (InstDecl name pat) where
168 put_ bh (InstDecl aa _ _ ad _) = do
177 return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc)
179 instance (Binary name) => Binary (RuleDecl name pat) where
180 put_ bh (IfaceRule ag ah ai aj ak al _) = do
188 get bh = do ag <- get bh
194 return (IfaceRule ag ah ai aj ak al noSrcLoc)
196 instance (Binary name) => Binary (DeprecDecl name) where
197 put_ bh (Deprecation aa ab _) = do
204 return (Deprecation aa ab noSrcLoc)
207 instance Binary name => Binary (Sig name) where
208 put_ bh (ClassOpSig n def ty _) = do put_ bh n; put_ bh def; put_ bh ty
213 return (ClassOpSig n def ty noSrcLoc)
216 {-! for IsCafCC derive: Binary !-}
217 {-! for IsDupdCC derive: Binary !-}
218 {-! for CostCentre derive: Binary !-}
220 -- ---------------------------------------------------------------------------
223 -- NB. we write out a ModIface, but read it in as a ParsedIface.
224 -- There are some big differences, and some subtle ones. We do most
225 -- of the conversion on the way out, so there is minimal fuss when we
226 -- read it back in again (see RnMonad.lhs)
228 -- The main difference is that all Names in a ModIface are RdrNames in
229 -- a ParsedIface, so when writing out a Name in binary we make sure it
230 -- is binary-compatible with a RdrName.
232 -- Other subtle differences:
233 -- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put
234 -- Modules as ModuleNames.
235 -- - pi_exports and pi_usages, Names have
236 -- to be converted to OccNames.
237 -- - pi_fixity is a NameEnv in ModIface,
238 -- but a list of (Name,Fixity) pairs in ParsedIface.
239 -- - versioning is totally different.
240 -- - deprecations are different.
242 instance Binary ModIface where
244 build_tag <- readIORef v_Build_tag
245 put_ bh (show opt_HiVersion ++ build_tag)
246 p <- put_ bh (mi_module iface)
247 put_ bh (mi_package iface)
248 put_ bh (vers_module (mi_version iface))
249 put_ bh (mi_orphan iface)
251 lazyPut bh (map importVersionNameToOccName (mi_usages iface))
252 put_ bh (vers_exports (mi_version iface),
253 map exportItemToRdrExportItem (mi_exports iface))
254 put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
255 (vers_decls (mi_version iface)))
257 put_ bh (collectFixities (mi_fixities iface)
258 (dcl_tycl (mi_decls iface)))
259 put_ bh (dcl_insts (mi_decls iface))
260 lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
261 lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))
263 -- Read in as a ParsedIface, not a ModIface. See above.
264 get bh = error "Binary.get: ModIface"
266 declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
267 -> [(Version, RenamedTyClDecl)]
268 declsToVersionedDecls decls env
271 case lookupNameEnv env (tyClDeclName d) of
272 Nothing -> (initialVersion, d)
276 --NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs
277 deprecsToIfaceDeprecs NoDeprecs = Nothing
278 deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt)
279 deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))
282 {-! for GenAvailInfo derive: Binary !-}
283 {-! for WhatsImported derive: Binary !-}
285 -- For binary interfaces we need to convert the ImportVersion Names to OccNames
286 importVersionNameToOccName :: ImportVersion Name -> ImportVersion OccName
287 importVersionNameToOccName (mod, orphans, boot, what)
288 = (mod, orphans, boot, fiddle_with what)
289 where fiddle_with NothingAtAll = NothingAtAll
290 fiddle_with (Everything v) = Everything v
291 fiddle_with (Specifically v ev ns rv) = Specifically v ev ns' rv
292 where ns' = [ (nameOccName n, v) | (n,v) <- ns ]
295 exportItemToRdrExportItem (mn, avails)
296 = (mn, map availInfoToRdrAvailInfo avails)
298 availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo
299 availInfoToRdrAvailInfo (Avail n)
300 = Avail (nameOccName n)
301 availInfoToRdrAvailInfo (AvailTC n ns)
302 = AvailTC (nameOccName n) (map nameOccName ns)
304 -- ---------------------------------------------------------------------------
305 -- Reading a binary interface into ParsedIface
307 instance Binary ParsedIface where
309 pi_mod = module_name,
311 pi_vers = module_ver,
314 pi_exports = exports,
315 pi_decls = tycl_decls,
316 pi_fixity = fixities,
319 pi_deprecs = deprecs } = do
320 build_tag <- readIORef v_Build_tag
321 put_ bh (show opt_HiVersion ++ build_tag)
335 build_tag <- readIORef v_Build_tag
336 let our_ver = show opt_HiVersion ++ build_tag
337 when (check_ver /= our_ver) $
338 -- use userError because this will be caught by readIface
339 -- which will emit an error msg containing the iface module name.
340 throwDyn (ProgramError (
341 "mismatched interface file versions: expected "
342 ++ our_ver ++ ", found " ++ check_ver))
343 module_name <- get bh -- same rep. as Module, so that's ok
347 usages <- {-# SCC "bin_usages" #-} lazyGet bh
348 exports <- {-# SCC "bin_exports" #-} get bh
349 tycl_decls <- {-# SCC "bin_tycldecls" #-} get bh
350 fixities <- {-# SCC "bin_fixities" #-} get bh
351 insts <- {-# SCC "bin_insts" #-} get bh
352 rules <- {-# SCC "bin_rules" #-} lazyGet bh
353 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
354 return (ParsedIface {
355 pi_mod = module_name,
357 pi_vers = module_ver,
360 pi_exports = exports,
361 pi_decls = tycl_decls,
362 pi_fixity = fixities,
363 pi_insts = reverse insts,
365 pi_deprecs = deprecs })
367 -- ----------------------------------------------------------------------------
368 -- Writing a binary interface
370 writeBinIface :: FilePath -> ModIface -> IO ()
371 writeBinIface hi_path mod_iface =
372 putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
374 -- ----------------------------------------------------------------------------
375 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
377 -- Imported from other files :-
379 instance (Binary name) => Binary (GenAvailInfo name) where
380 put_ bh (Avail aa) = do
383 put_ bh (AvailTC ab ac) = do
394 return (AvailTC ab ac)
396 instance (Binary name) => Binary (WhatsImported name) where
397 put_ bh NothingAtAll = do
399 put_ bh (Everything aa) = do
402 put_ bh (Specifically ab ac ad ae) = do
411 0 -> do return NothingAtAll
413 return (Everything aa)
418 return (Specifically ab ac ad ae)
420 instance Binary Activation where
421 put_ bh NeverActive = do
423 put_ bh AlwaysActive = do
425 put_ bh (ActiveBefore aa) = do
428 put_ bh (ActiveAfter ab) = do
434 0 -> do return NeverActive
435 1 -> do return AlwaysActive
437 return (ActiveBefore aa)
439 return (ActiveAfter ab)
441 instance Binary StrictnessMark where
442 put_ bh MarkedUserStrict = do
444 put_ bh MarkedStrict = do
446 put_ bh MarkedUnboxed = do
448 put_ bh NotMarkedStrict = do
453 0 -> do return MarkedUserStrict
454 1 -> do return MarkedStrict
455 2 -> do return MarkedUnboxed
456 _ -> do return NotMarkedStrict
458 instance Binary Boxity where
467 _ -> do return Unboxed
469 instance Binary NewOrData where
472 put_ bh DataType = do
477 0 -> do return NewType
478 _ -> do return DataType
480 instance Binary FixityDirection where
490 0 -> do return InfixL
491 1 -> do return InfixR
492 _ -> do return InfixN
494 instance Binary Fixity where
495 put_ bh (Fixity aa ab) = do
501 return (Fixity aa ab)
503 instance (Binary name) => Binary (IPName name) where
504 put_ bh (Dupable aa) = do
507 put_ bh (Linear ab) = do
518 instance Binary Demand where
523 put_ bh (Call aa) = do
526 put_ bh (Eval ab) = do
529 put_ bh (Defer ac) = do
532 put_ bh (Box ad) = do
552 instance Binary Demands where
553 put_ bh (Poly aa) = do
556 put_ bh (Prod ab) = do
567 instance Binary DmdResult where
577 0 -> do return TopRes
578 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
579 -- The wrapper was generated for CPR in
580 -- the imported module!
581 _ -> do return BotRes
583 instance Binary StrictSig where
584 put_ bh (StrictSig aa) = do
588 return (StrictSig aa)
590 instance (Binary name) => Binary (HsTyVarBndr name) where
591 put_ bh (UserTyVar aa) = do
594 put_ bh (IfaceTyVar ab ac) = do
602 return (UserTyVar aa)
605 return (IfaceTyVar ab ac)
607 instance (Binary name) => Binary (HsTupCon name) where
608 put_ bh (HsTupCon aa ab ac) = do
616 return (HsTupCon aa ab ac)
618 instance (Binary name) => Binary (HsType name) where
619 put_ bh (HsForAllTy aa ab ac) = do
624 put_ bh (HsTyVar ad) = do
627 put_ bh (HsAppTy ae af) = do
631 put_ bh (HsFunTy ag ah) = do
635 put_ bh (HsListTy ai) = do
638 put_ bh (HsPArrTy aj) = do
641 put_ bh (HsTupleTy ak al) = do
645 put_ bh (HsOpTy am an ao) = do
650 put_ bh (HsNumTy ap) = do
653 put_ bh (HsPredTy aq) = do
656 put_ bh (HsKindSig ar as) = do
666 return (HsForAllTy aa ab ac)
671 return (HsAppTy ae af)
674 return (HsFunTy ag ah)
681 return (HsTupleTy ak al)
685 return (HsOpTy am an ao)
692 return (HsKindSig ar as)
694 instance (Binary name) => Binary (HsPred name) where
695 put_ bh (HsClassP aa ab) = do
699 put_ bh (HsIParam ac ad) = do
708 return (HsClassP aa ab)
711 return (HsIParam ac ad)
713 instance (Binary name) => Binary (UfExpr name) where
714 put_ bh (UfVar aa) = do
717 put_ bh (UfType ab) = do
720 put_ bh (UfTuple ac ad) = do
724 put_ bh (UfLam ae af) = do
728 put_ bh (UfApp ag ah) = do
732 put_ bh (UfCase ai aj ak) = do
737 put_ bh (UfLet al am) = do
741 put_ bh (UfNote an ao) = do
745 put_ bh (UfLit ap) = do
748 put_ bh (UfLitLit aq ar) = do
752 put_ bh (UfFCall as at) = do
765 return (UfTuple ac ad)
775 return (UfCase ai aj ak)
781 return (UfNote an ao)
786 return (UfLitLit aq ar)
789 return (UfFCall as at)
791 instance (Binary name) => Binary (UfConAlt name) where
792 put_ bh UfDefault = do
794 put_ bh (UfDataAlt aa) = do
797 put_ bh (UfTupleAlt ab) = do
800 put_ bh (UfLitAlt ac) = do
803 put_ bh (UfLitLitAlt ad ae) = do
810 0 -> do return UfDefault
812 return (UfDataAlt aa)
814 return (UfTupleAlt ab)
819 return (UfLitLitAlt ad ae)
821 instance (Binary name) => Binary (UfBinding name) where
822 put_ bh (UfNonRec aa ab) = do
826 put_ bh (UfRec ac) = do
834 return (UfNonRec aa ab)
838 instance (Binary name) => Binary (UfBinder name) where
839 put_ bh (UfValBinder aa ab) = do
843 put_ bh (UfTyBinder ac ad) = do
852 return (UfValBinder aa ab)
855 return (UfTyBinder ac ad)
857 instance (Binary name) => Binary (HsIdInfo name) where
858 put_ bh (HsArity aa) = do
861 put_ bh (HsStrictness ab) = do
864 put_ bh (HsUnfold ac ad) = do
868 put_ bh HsNoCafRefs = do
870 put_ bh (HsWorker ae af) = do
880 return (HsStrictness ab)
883 return (HsUnfold ac ad)
884 3 -> do return HsNoCafRefs
887 return (HsWorker ae af)
889 instance (Binary name) => Binary (UfNote name) where
890 put_ bh (UfSCC aa) = do
893 put_ bh (UfCoerce ab) = do
896 put_ bh UfInlineCall = do
898 put_ bh UfInlineMe = do
907 2 -> do return UfInlineCall
908 _ -> do return UfInlineMe
910 instance (Binary name) => Binary (BangType name) where
911 put_ bh (BangType aa ab) = do
917 return (BangType aa ab)
919 instance (Binary name) => Binary (ConDetails name) where
920 put_ bh (VanillaCon aa) = do
923 put_ bh (InfixCon ab ac) = do
927 put_ bh (RecCon ad) = do
934 return (VanillaCon aa)
937 return (InfixCon ab ac)
941 instance (Binary datacon) => Binary (DataConDetails datacon) where
942 put_ bh (DataCons aa) = do
947 put_ bh (HasCons ab) = do
955 1 -> do return Unknown
959 instance (Binary id) => Binary (DefMeth id) where
960 put_ bh NoDefMeth = do
962 put_ bh (DefMeth aa) = do
965 put_ bh GenDefMeth = do
970 0 -> do return NoDefMeth
973 _ -> do return GenDefMeth
975 instance Binary IsCafCC where
978 put_ bh NotCafCC = do
984 _ -> do return NotCafCC
986 instance Binary IsDupdCC where
987 put_ bh OriginalCC = do
994 0 -> do return OriginalCC
995 _ -> do return DupdCC
997 instance Binary CostCentre where
998 put_ bh NoCostCentre = do
1000 put_ bh (NormalCC aa ab ac ad) = do
1006 put_ bh (AllCafsCC ae) = do
1012 0 -> do return NoCostCentre
1013 1 -> do aa <- get bh
1017 return (NormalCC aa ab ac ad)
1018 _ -> do ae <- get bh
1019 return (AllCafsCC ae)