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 (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 (map importVersionNameToOccName (mi_usages iface))
278 put_ bh (vers_exports (mi_version iface),
279 map exportItemToRdrExportItem (mi_exports iface))
280 put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
281 (vers_decls (mi_version iface)))
283 put_ bh (collectFixities (mi_fixities iface)
284 (dcl_tycl (mi_decls iface)))
285 put_ bh (dcl_insts (mi_decls iface))
286 lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
287 lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))
289 -- Read in as a ParsedIface, not a ModIface. See above.
290 get bh = error "Binary.get: ModIface"
292 declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
293 -> [(Version, RenamedTyClDecl)]
294 declsToVersionedDecls decls env
297 case lookupNameEnv env (tyClDeclName d) of
298 Nothing -> (initialVersion, d)
302 --NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs
303 deprecsToIfaceDeprecs NoDeprecs = Nothing
304 deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt)
305 deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))
308 {-! for GenAvailInfo derive: Binary !-}
309 {-! for WhatsImported derive: Binary !-}
311 -- For binary interfaces we need to convert the ImportVersion Names to OccNames
312 importVersionNameToOccName :: ImportVersion Name -> ImportVersion OccName
313 importVersionNameToOccName (mod, orphans, boot, what)
314 = (mod, orphans, boot, fiddle_with what)
315 where fiddle_with NothingAtAll = NothingAtAll
316 fiddle_with (Everything v) = Everything v
317 fiddle_with (Specifically v ev ns rv) = Specifically v ev ns' rv
318 where ns' = [ (nameOccName n, v) | (n,v) <- ns ]
321 exportItemToRdrExportItem (mn, avails)
322 = (mn, map availInfoToRdrAvailInfo avails)
324 availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo
325 availInfoToRdrAvailInfo (Avail n)
326 = Avail (nameOccName n)
327 availInfoToRdrAvailInfo (AvailTC n ns)
328 = AvailTC (nameOccName n) (map nameOccName ns)
330 -- ---------------------------------------------------------------------------
331 -- Reading a binary interface into ParsedIface
333 instance Binary ParsedIface where
335 pi_mod = module_name,
337 pi_vers = module_ver,
340 pi_exports = exports,
341 pi_decls = tycl_decls,
342 pi_fixity = fixities,
345 pi_deprecs = deprecs } = do
346 build_tag <- readIORef v_Build_tag
347 put_ bh (show opt_HiVersion ++ build_tag)
361 build_tag <- readIORef v_Build_tag
362 let our_ver = show opt_HiVersion ++ build_tag
363 when (check_ver /= our_ver) $
364 -- use userError because this will be caught by readIface
365 -- which will emit an error msg containing the iface module name.
366 throwDyn (ProgramError (
367 "mismatched interface file versions: expected "
368 ++ our_ver ++ ", found " ++ check_ver))
369 module_name <- get bh -- same rep. as Module, so that's ok
373 usages <- {-# SCC "bin_usages" #-} lazyGet bh
374 exports <- {-# SCC "bin_exports" #-} get bh
375 tycl_decls <- {-# SCC "bin_tycldecls" #-} get bh
376 fixities <- {-# SCC "bin_fixities" #-} get bh
377 insts <- {-# SCC "bin_insts" #-} get bh
378 rules <- {-# SCC "bin_rules" #-} lazyGet bh
379 deprecs <- {-# SCC "bin_deprecs" #-} lazyGet bh
380 return (ParsedIface {
381 pi_mod = module_name,
383 pi_vers = module_ver,
386 pi_exports = exports,
387 pi_decls = tycl_decls,
388 pi_fixity = fixities,
389 pi_insts = reverse insts,
391 pi_deprecs = deprecs })
393 -- ----------------------------------------------------------------------------
394 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
396 -- Imported from other files :-
398 instance (Binary name) => Binary (GenAvailInfo name) where
399 put_ bh (Avail aa) = do
402 put_ bh (AvailTC ab ac) = do
413 return (AvailTC ab ac)
415 instance (Binary name) => Binary (WhatsImported name) where
416 put_ bh NothingAtAll = do
418 put_ bh (Everything aa) = do
421 put_ bh (Specifically ab ac ad ae) = do
430 0 -> do return NothingAtAll
432 return (Everything aa)
437 return (Specifically ab ac ad ae)
439 instance Binary Activation where
440 put_ bh NeverActive = do
442 put_ bh AlwaysActive = do
444 put_ bh (ActiveBefore aa) = do
447 put_ bh (ActiveAfter ab) = do
453 0 -> do return NeverActive
454 1 -> do return AlwaysActive
456 return (ActiveBefore aa)
458 return (ActiveAfter ab)
460 instance Binary StrictnessMark where
461 put_ bh MarkedUserStrict = do
463 put_ bh MarkedStrict = do
465 put_ bh MarkedUnboxed = do
467 put_ bh NotMarkedStrict = do
472 0 -> do return MarkedUserStrict
473 1 -> do return MarkedStrict
474 2 -> do return MarkedUnboxed
475 _ -> do return NotMarkedStrict
477 instance Binary Boxity where
486 _ -> do return Unboxed
488 instance Binary NewOrData where
491 put_ bh DataType = do
496 0 -> do return NewType
497 _ -> do return DataType
499 instance Binary FixityDirection where
509 0 -> do return InfixL
510 1 -> do return InfixR
511 _ -> do return InfixN
513 instance Binary Fixity where
514 put_ bh (Fixity aa ab) = do
520 return (Fixity aa ab)
522 instance (Binary name) => Binary (FixitySig name) where
523 put_ bh (FixitySig aa ab _) = do
529 return (FixitySig aa ab noSrcLoc)
531 instance (Binary name) => Binary (IPName name) where
532 put_ bh (Dupable aa) = do
535 put_ bh (Linear ab) = do
546 instance Binary Demand where
551 put_ bh (Call aa) = do
554 put_ bh (Eval ab) = do
557 put_ bh (Defer ac) = do
560 put_ bh (Box ad) = do
580 instance Binary Demands where
581 put_ bh (Poly aa) = do
584 put_ bh (Prod ab) = do
595 instance Binary DmdResult where
605 0 -> do return TopRes
606 1 -> do return RetCPR -- Really use RetCPR even if -fcpr-off
607 -- The wrapper was generated for CPR in
608 -- the imported module!
609 _ -> do return BotRes
611 instance Binary StrictSig where
612 put_ bh (StrictSig aa) = do
616 return (StrictSig aa)
618 instance (Binary name) => Binary (HsTyVarBndr name) where
619 put_ bh (UserTyVar aa) = do
622 put_ bh (IfaceTyVar ab ac) = do
630 return (UserTyVar aa)
633 return (IfaceTyVar ab ac)
635 instance Binary HsTupCon where
636 put_ bh (HsTupCon ab ac) = do
642 return (HsTupCon ab ac)
644 instance (Binary name) => Binary (HsTyOp name) where
645 put_ bh HsArrow = putByte bh 0
646 put_ bh (HsTyOp n) = do putByte bh 1
649 get bh = do h <- getByte bh
655 instance (Binary name) => Binary (HsType name) where
656 put_ bh (HsForAllTy aa ab ac) = do
661 put_ bh (HsTyVar ad) = do
664 put_ bh (HsAppTy ae af) = do
668 put_ bh (HsFunTy ag ah) = do
672 put_ bh (HsListTy ai) = do
675 put_ bh (HsPArrTy aj) = do
678 put_ bh (HsTupleTy ak al) = do
682 put_ bh (HsOpTy am an ao) = do
687 put_ bh (HsNumTy ap) = do
690 put_ bh (HsPredTy aq) = do
693 put_ bh (HsKindSig ar as) = do
703 return (HsForAllTy aa ab ac)
708 return (HsAppTy ae af)
711 return (HsFunTy ag ah)
718 return (HsTupleTy ak al)
722 return (HsOpTy am an ao)
729 return (HsKindSig ar as)
731 instance (Binary name) => Binary (HsPred name) where
732 put_ bh (HsClassP aa ab) = do
736 put_ bh (HsIParam ac ad) = do
745 return (HsClassP aa ab)
748 return (HsIParam ac ad)
750 instance (Binary name) => Binary (UfExpr name) where
751 put_ bh (UfVar aa) = do
754 put_ bh (UfType ab) = do
757 put_ bh (UfTuple ac ad) = do
761 put_ bh (UfLam ae af) = do
765 put_ bh (UfApp ag ah) = do
769 put_ bh (UfCase ai aj ak) = do
774 put_ bh (UfLet al am) = do
778 put_ bh (UfNote an ao) = do
782 put_ bh (UfLit ap) = do
785 put_ bh (UfLitLit aq ar) = do
789 put_ bh (UfFCall as at) = do
802 return (UfTuple ac ad)
812 return (UfCase ai aj ak)
818 return (UfNote an ao)
823 return (UfLitLit aq ar)
826 return (UfFCall as at)
828 instance (Binary name) => Binary (UfConAlt name) where
829 put_ bh UfDefault = do
831 put_ bh (UfDataAlt aa) = do
834 put_ bh (UfTupleAlt ab) = do
837 put_ bh (UfLitAlt ac) = do
840 put_ bh (UfLitLitAlt ad ae) = do
847 0 -> do return UfDefault
849 return (UfDataAlt aa)
851 return (UfTupleAlt ab)
856 return (UfLitLitAlt ad ae)
858 instance (Binary name) => Binary (UfBinding name) where
859 put_ bh (UfNonRec aa ab) = do
863 put_ bh (UfRec ac) = do
871 return (UfNonRec aa ab)
875 instance (Binary name) => Binary (UfBinder name) where
876 put_ bh (UfValBinder aa ab) = do
880 put_ bh (UfTyBinder ac ad) = do
889 return (UfValBinder aa ab)
892 return (UfTyBinder ac ad)
894 instance (Binary name) => Binary (HsIdInfo name) where
895 put_ bh (HsArity aa) = do
898 put_ bh (HsStrictness ab) = do
901 put_ bh (HsUnfold ac ad) = do
905 put_ bh HsNoCafRefs = do
907 put_ bh (HsWorker ae af) = do
917 return (HsStrictness ab)
920 return (HsUnfold ac ad)
921 3 -> do return HsNoCafRefs
924 return (HsWorker ae af)
926 instance (Binary name) => Binary (UfNote name) where
927 put_ bh (UfSCC aa) = do
930 put_ bh (UfCoerce ab) = do
933 put_ bh UfInlineCall = do
935 put_ bh UfInlineMe = do
944 2 -> do return UfInlineCall
945 _ -> do return UfInlineMe
947 instance (Binary name) => Binary (BangType name) where
948 put_ bh (BangType aa ab) = do
954 return (BangType aa ab)
956 instance (Binary name, Binary arg) => Binary (HsConDetails name arg) where
957 put_ bh (PrefixCon aa) = do
960 put_ bh (InfixCon ab ac) = do
964 put_ bh (RecCon ad) = do
971 return (PrefixCon aa)
974 return (InfixCon ab ac)
978 instance (Binary datacon) => Binary (DataConDetails datacon) where
979 put_ bh (DataCons aa) = do
984 put_ bh (HasCons ab) = do
992 1 -> do return Unknown
996 instance (Binary id) => Binary (DefMeth id) where
997 put_ bh NoDefMeth = do
999 put_ bh (DefMeth aa) = do
1002 put_ bh GenDefMeth = do
1007 0 -> do return NoDefMeth
1008 1 -> do aa <- get bh
1010 _ -> do return GenDefMeth
1012 instance Binary IsCafCC where
1015 put_ bh NotCafCC = do
1020 0 -> do return CafCC
1021 _ -> do return NotCafCC
1023 instance Binary IsDupdCC where
1024 put_ bh OriginalCC = do
1031 0 -> do return OriginalCC
1032 _ -> do return DupdCC
1034 instance Binary CostCentre where
1035 put_ bh NoCostCentre = do
1037 put_ bh (NormalCC aa ab ac ad) = do
1043 put_ bh (AllCafsCC ae) = do
1049 0 -> do return NoCostCentre
1050 1 -> do aa <- get bh
1054 return (NormalCC aa ab ac ad)
1055 _ -> do ae <- get bh
1056 return (AllCafsCC ae)