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 (HsTyOp name) where
619 put_ bh HsArrow = putByte bh 0
620 put_ bh (HsTyOp n) = do putByte bh 1
623 get bh = do h <- getByte bh
629 instance (Binary name) => Binary (HsType name) where
630 put_ bh (HsForAllTy aa ab ac) = do
635 put_ bh (HsTyVar ad) = do
638 put_ bh (HsAppTy ae af) = do
642 put_ bh (HsFunTy ag ah) = do
646 put_ bh (HsListTy ai) = do
649 put_ bh (HsPArrTy aj) = do
652 put_ bh (HsTupleTy ak al) = do
656 put_ bh (HsOpTy am an ao) = do
661 put_ bh (HsNumTy ap) = do
664 put_ bh (HsPredTy aq) = do
667 put_ bh (HsKindSig ar as) = do
677 return (HsForAllTy aa ab ac)
682 return (HsAppTy ae af)
685 return (HsFunTy ag ah)
692 return (HsTupleTy ak al)
696 return (HsOpTy am an ao)
703 return (HsKindSig ar as)
705 instance (Binary name) => Binary (HsPred name) where
706 put_ bh (HsClassP aa ab) = do
710 put_ bh (HsIParam ac ad) = do
719 return (HsClassP aa ab)
722 return (HsIParam ac ad)
724 instance (Binary name) => Binary (UfExpr name) where
725 put_ bh (UfVar aa) = do
728 put_ bh (UfType ab) = do
731 put_ bh (UfTuple ac ad) = do
735 put_ bh (UfLam ae af) = do
739 put_ bh (UfApp ag ah) = do
743 put_ bh (UfCase ai aj ak) = do
748 put_ bh (UfLet al am) = do
752 put_ bh (UfNote an ao) = do
756 put_ bh (UfLit ap) = do
759 put_ bh (UfLitLit aq ar) = do
763 put_ bh (UfFCall as at) = do
776 return (UfTuple ac ad)
786 return (UfCase ai aj ak)
792 return (UfNote an ao)
797 return (UfLitLit aq ar)
800 return (UfFCall as at)
802 instance (Binary name) => Binary (UfConAlt name) where
803 put_ bh UfDefault = do
805 put_ bh (UfDataAlt aa) = do
808 put_ bh (UfTupleAlt ab) = do
811 put_ bh (UfLitAlt ac) = do
814 put_ bh (UfLitLitAlt ad ae) = do
821 0 -> do return UfDefault
823 return (UfDataAlt aa)
825 return (UfTupleAlt ab)
830 return (UfLitLitAlt ad ae)
832 instance (Binary name) => Binary (UfBinding name) where
833 put_ bh (UfNonRec aa ab) = do
837 put_ bh (UfRec ac) = do
845 return (UfNonRec aa ab)
849 instance (Binary name) => Binary (UfBinder name) where
850 put_ bh (UfValBinder aa ab) = do
854 put_ bh (UfTyBinder ac ad) = do
863 return (UfValBinder aa ab)
866 return (UfTyBinder ac ad)
868 instance (Binary name) => Binary (HsIdInfo name) where
869 put_ bh (HsArity aa) = do
872 put_ bh (HsStrictness ab) = do
875 put_ bh (HsUnfold ac ad) = do
879 put_ bh HsNoCafRefs = do
881 put_ bh (HsWorker ae af) = do
891 return (HsStrictness ab)
894 return (HsUnfold ac ad)
895 3 -> do return HsNoCafRefs
898 return (HsWorker ae af)
900 instance (Binary name) => Binary (UfNote name) where
901 put_ bh (UfSCC aa) = do
904 put_ bh (UfCoerce ab) = do
907 put_ bh UfInlineCall = do
909 put_ bh UfInlineMe = do
918 2 -> do return UfInlineCall
919 _ -> do return UfInlineMe
921 instance (Binary name) => Binary (BangType name) where
922 put_ bh (BangType aa ab) = do
928 return (BangType aa ab)
930 instance (Binary name) => Binary (ConDetails name) where
931 put_ bh (VanillaCon aa) = do
934 put_ bh (InfixCon ab ac) = do
938 put_ bh (RecCon ad) = do
945 return (VanillaCon aa)
948 return (InfixCon ab ac)
952 instance (Binary datacon) => Binary (DataConDetails datacon) where
953 put_ bh (DataCons aa) = do
958 put_ bh (HasCons ab) = do
966 1 -> do return Unknown
970 instance (Binary id) => Binary (DefMeth id) where
971 put_ bh NoDefMeth = do
973 put_ bh (DefMeth aa) = do
976 put_ bh GenDefMeth = do
981 0 -> do return NoDefMeth
984 _ -> do return GenDefMeth
986 instance Binary IsCafCC where
989 put_ bh NotCafCC = do
995 _ -> do return NotCafCC
997 instance Binary IsDupdCC where
998 put_ bh OriginalCC = do
1005 0 -> do return OriginalCC
1006 _ -> do return DupdCC
1008 instance Binary CostCentre where
1009 put_ bh NoCostCentre = do
1011 put_ bh (NormalCC aa ab ac ad) = do
1017 put_ bh (AllCafsCC ae) = do
1023 0 -> do return NoCostCentre
1024 1 -> do aa <- get bh
1028 return (NormalCC aa ab ac ad)
1029 _ -> do ae <- get bh
1030 return (AllCafsCC ae)