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, compileIface ) where
21 import Module ( mkHomeModule )
22 import Name ( Name, nameOccName )
23 import NameEnv ( NameEnv, lookupNameEnv, nameEnvElts )
24 import OccName ( OccName )
25 import RnMonad ( ParsedIface(..) )
27 import DriverState ( v_Build_tag )
28 import DriverUtil ( newsuf )
30 import CmdLineOpts ( opt_IgnoreIfacePragmas, opt_HiVersion )
31 import StringBuffer ( hGetStringBuffer )
32 import ParseIface ( parseIface )
39 import IOExts ( readIORef )
41 import Exception ( throwDyn )
43 #include "HsVersions.h"
46 {-! for IPName derive: Binary !-}
47 {-! for Fixity derive: Binary !-}
48 {-! for FixityDirection derive: Binary !-}
49 {-! for NewOrData derive: Binary !-}
50 {-! for Boxity derive: Binary !-}
51 {-! for StrictnessMark derive: Binary !-}
52 {-! for Activation derive: Binary !-}
55 {-! for Demand derive: Binary !-}
56 {-! for Demands derive: Binary !-}
57 {-! for DmdResult derive: Binary !-}
58 {-! for StrictSig derive: Binary !-}
60 instance Binary DmdType where
61 -- ignore DmdEnv when spitting out the DmdType
62 put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
63 get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
66 {-! for DataConDetails derive: Binary !-}
69 {-! for DefMeth derive: Binary !-}
72 {-! for HsPred derive: Binary !-}
73 {-! for HsType derive: Binary !-}
74 {-! for HsTupCon derive: Binary !-}
75 {-! for HsTyVarBndr derive: Binary !-}
78 {-! for UfExpr derive: Binary !-}
79 {-! for UfConAlt derive: Binary !-}
80 {-! for UfBinding derive: Binary !-}
81 {-! for UfBinder derive: Binary !-}
82 {-! for HsIdInfo derive: Binary !-}
83 {-! for UfNote derive: Binary !-}
86 {-! for ConDetails derive: Binary !-}
87 {-! for BangType derive: Binary !-}
89 instance (Binary name) => Binary (TyClDecl name pat) where
90 put_ bh (IfaceSig name ty idinfo _) = do
95 put_ bh (ForeignType ae af ag ah) =
96 error "Binary.put_(TyClDecl): ForeignType"
97 put_ bh (TyData ai aj ak al am an ao _) = do
105 put_ bh ao -- store the SysNames for now (later: derive them)
106 put_ bh (TySynonym aq ar as _) = do
111 put_ bh c@(ClassDecl ctxt nm tyvars fds sigs _ sysnames _) = do
118 -- ignore methods (there should be none)
128 let idinfo' | opt_IgnoreIfacePragmas = []
130 return (IfaceSig name ty idinfo' noSrcLoc)
131 1 -> error "Binary.get(TyClDecl): ForeignType"
139 return (TyData n_or_d ctx nm tyvars cons
140 Nothing sysnames noSrcLoc)
145 return (TySynonym aq ar as noSrcLoc)
153 return (ClassDecl ctxt nm tyvars fds sigs
154 Nothing sysnames noSrcLoc)
156 instance (Binary name) => Binary (ConDecl name) where
157 put_ bh (ConDecl aa ab ac ad ae _) = do
170 return (ConDecl aa ab ac ad ae noSrcLoc)
172 instance (Binary name) => Binary (InstDecl name pat) where
173 put_ bh (InstDecl aa _ _ ad _) = do
182 return (InstDecl aa EmptyMonoBinds [{-no sigs-}] ad noSrcLoc)
184 instance (Binary name) => Binary (RuleDecl name pat) where
185 put_ bh (IfaceRule ag ah ai aj ak al _) = do
193 get bh = do ag <- get bh
199 return (IfaceRule ag ah ai aj ak al noSrcLoc)
201 instance (Binary name) => Binary (DeprecDecl name) where
202 put_ bh (Deprecation aa ab _) = do
209 return (Deprecation aa ab noSrcLoc)
212 instance Binary name => Binary (Sig name) where
213 put_ bh (ClassOpSig n def ty _) = do put_ bh n; put_ bh def; put_ bh ty
218 return (ClassOpSig n def ty noSrcLoc)
221 {-! for IsCafCC derive: Binary !-}
222 {-! for IsDupdCC derive: Binary !-}
223 {-! for CostCentre derive: Binary !-}
225 -- ---------------------------------------------------------------------------
228 -- NB. we write out a ModIface, but read it in as a ParsedIface.
229 -- There are some big differences, and some subtle ones. We do most
230 -- of the conversion on the way out, so there is minimal fuss when we
231 -- read it back in again (see RnMonad.lhs)
233 -- The main difference is that all Names in a ModIface are RdrNames in
234 -- a ParsedIface, so when writing out a Name in binary we make sure it
235 -- is binary-compatible with a RdrName.
237 -- Other subtle differences:
238 -- - pi_mod is a ModuleName, but mi_mod is a Module. Hence we put
239 -- Modules as ModuleNames.
240 -- - pi_exports and pi_usages, Names have
241 -- to be converted to OccNames.
242 -- - pi_fixity is a NameEnv in ModIface,
243 -- but a list of (Name,Fixity) pairs in ParsedIface.
244 -- - versioning is totally different.
245 -- - deprecations are different.
247 instance Binary ModIface where
249 build_tag <- readIORef v_Build_tag
250 put_ bh (show opt_HiVersion ++ build_tag)
251 p <- put_ bh (mi_module iface)
252 put_ bh (mi_package iface)
253 put_ bh (vers_module (mi_version iface))
254 put_ bh (mi_orphan iface)
256 put_ bh (map importVersionNameToOccName (mi_usages iface))
257 put_ bh (vers_exports (mi_version iface),
258 map exportItemToRdrExportItem (mi_exports iface))
259 put_ bh (declsToVersionedDecls (dcl_tycl (mi_decls iface))
260 (vers_decls (mi_version iface)))
262 put_ bh (collectFixities (mi_fixities iface)
263 (dcl_tycl (mi_decls iface)))
264 put_ bh (dcl_insts (mi_decls iface))
265 lazyPut bh (vers_rules (mi_version iface), dcl_rules (mi_decls iface))
266 lazyPut bh (deprecsToIfaceDeprecs (mi_deprecs iface))
268 -- Read in an a ParsedIface, not a ModIface. See above.
269 get bh = error "Binary.get: ModIface"
271 declsToVersionedDecls :: [RenamedTyClDecl] -> NameEnv Version
272 -> [(Version, RenamedTyClDecl)]
273 declsToVersionedDecls decls env
276 case lookupNameEnv env (tyClDeclName d) of
277 Nothing -> (initialVersion, d)
281 --NOT REALLY: deprecsToIfaceDeprecs :: Deprecations -> IfaceDeprecs
282 deprecsToIfaceDeprecs NoDeprecs = Nothing
283 deprecsToIfaceDeprecs (DeprecAll txt) = Just (Left txt)
284 deprecsToIfaceDeprecs (DeprecSome env) = Just (Right (nameEnvElts env))
287 {-! for GenAvailInfo derive: Binary !-}
288 {-! for WhatsImported derive: Binary !-}
290 -- For binary interfaces we need to convert the ImportVersion Names to OccNames
291 importVersionNameToOccName :: ImportVersion Name -> ImportVersion OccName
292 importVersionNameToOccName (mod, orphans, boot, what)
293 = (mod, orphans, boot, fiddle_with what)
294 where fiddle_with NothingAtAll = NothingAtAll
295 fiddle_with (Everything v) = Everything v
296 fiddle_with (Specifically v ev ns rv) = Specifically v ev ns' rv
297 where ns' = [ (nameOccName n, v) | (n,v) <- ns ]
300 exportItemToRdrExportItem (mn, avails)
301 = (mn, map availInfoToRdrAvailInfo avails)
303 availInfoToRdrAvailInfo :: AvailInfo -> RdrAvailInfo
304 availInfoToRdrAvailInfo (Avail n)
305 = Avail (nameOccName n)
306 availInfoToRdrAvailInfo (AvailTC n ns)
307 = AvailTC (nameOccName n) (map nameOccName ns)
309 -- ---------------------------------------------------------------------------
310 -- Reading a binary interface into ParsedIface
312 instance Binary ParsedIface where
314 pi_mod = module_name,
316 pi_vers = module_ver,
319 pi_exports = exports,
320 pi_decls = tycl_decls,
321 pi_fixity = fixities,
324 pi_deprecs = deprecs } = do
325 build_tag <- readIORef v_Build_tag
326 put_ bh (show opt_HiVersion ++ build_tag)
340 build_tag <- readIORef v_Build_tag
341 let our_ver = show opt_HiVersion ++ build_tag
342 when (check_ver /= our_ver) $
343 -- use userError because this will be caught by readIface
344 -- which will emit an error msg containing the iface module name.
345 throwDyn (ProgramError (
346 "mismatched interface file versions: expected "
347 ++ our_ver ++ ", found " ++ check_ver))
348 module_name <- get bh -- same rep. as Module, so that's ok
358 deprecs <- lazyGet bh
359 return (ParsedIface {
360 pi_mod = module_name,
362 pi_vers = module_ver,
365 pi_exports = exports,
366 pi_decls = tycl_decls,
367 pi_fixity = fixities,
368 pi_insts = reverse insts,
370 pi_deprecs = deprecs })
372 -- ----------------------------------------------------------------------------
373 -- Writing a binary interface
375 writeBinIface :: FilePath -> ModIface -> IO ()
376 writeBinIface hi_path mod_iface =
377 putBinFileWithDict hi_path (mi_module mod_iface) mod_iface
379 -- ----------------------------------------------------------------------------
380 -- Compile an interface from text into binary
382 compileIface :: FilePath -> IO ()
383 compileIface infile = do
384 let outfile = newsuf "hi" infile -- make it a .hi file
385 buf <- hGetStringBuffer False infile
386 case parseIface buf (mkPState loc exts) of
387 PFailed err -> throwDyn (ProgramError (showSDoc err))
389 putBinFileWithDict outfile (mkHomeModule (pi_mod iface)) iface
391 exts = ExtFlags {glasgowExtsEF = True,
393 loc = mkSrcLoc (FastString.mkFastString infile) 1
395 {-* Generated by DrIFT-v1.0 : Look, but Don't Touch. *-}
397 -- Imported from other files :-
399 instance (Binary name) => Binary (GenAvailInfo name) where
400 put_ bh (Avail aa) = do
403 put_ bh (AvailTC ab ac) = do
414 return (AvailTC ab ac)
416 instance (Binary name) => Binary (WhatsImported name) where
417 put_ bh NothingAtAll = do
419 put_ bh (Everything aa) = do
422 put_ bh (Specifically ab ac ad ae) = do
431 0 -> do return NothingAtAll
433 return (Everything aa)
438 return (Specifically ab ac ad ae)
440 instance Binary Activation where
441 put_ bh NeverActive = do
443 put_ bh AlwaysActive = do
445 put_ bh (ActiveBefore aa) = do
448 put_ bh (ActiveAfter ab) = do
454 0 -> do return NeverActive
455 1 -> do return AlwaysActive
457 return (ActiveBefore aa)
459 return (ActiveAfter ab)
461 instance Binary StrictnessMark where
462 put_ bh MarkedUserStrict = do
464 put_ bh MarkedStrict = do
466 put_ bh MarkedUnboxed = do
468 put_ bh NotMarkedStrict = do
473 0 -> do return MarkedUserStrict
474 1 -> do return MarkedStrict
475 2 -> do return MarkedUnboxed
476 _ -> do return NotMarkedStrict
478 instance Binary Boxity where
487 _ -> do return Unboxed
489 instance Binary NewOrData where
492 put_ bh DataType = do
497 0 -> do return NewType
498 _ -> do return DataType
500 instance Binary FixityDirection where
510 0 -> do return InfixL
511 1 -> do return InfixR
512 _ -> do return InfixN
514 instance Binary Fixity where
515 put_ bh (Fixity aa ab) = do
521 return (Fixity aa ab)
523 instance (Binary name) => Binary (IPName name) where
524 put_ bh (Dupable aa) = do
527 put_ bh (Linear ab) = do
538 instance Binary Demand where
543 put_ bh (Call aa) = do
546 put_ bh (Eval ab) = do
549 put_ bh (Defer ac) = do
552 put_ bh (Box ad) = do
572 instance Binary Demands where
573 put_ bh (Poly aa) = do
576 put_ bh (Prod ab) = do
587 instance Binary DmdResult where
597 0 -> do return TopRes
598 1 -> do return RetCPR
599 _ -> do return BotRes
601 instance Binary StrictSig where
602 put_ bh (StrictSig aa) = do
606 return (StrictSig aa)
608 instance (Binary name) => Binary (HsTyVarBndr name) where
609 put_ bh (UserTyVar aa) = do
612 put_ bh (IfaceTyVar ab ac) = do
620 return (UserTyVar aa)
623 return (IfaceTyVar ab ac)
625 instance (Binary name) => Binary (HsTupCon name) where
626 put_ bh (HsTupCon aa ab ac) = do
634 return (HsTupCon aa ab ac)
636 instance (Binary name) => Binary (HsType name) where
637 put_ bh (HsForAllTy aa ab ac) = do
642 put_ bh (HsTyVar ad) = do
645 put_ bh (HsAppTy ae af) = do
649 put_ bh (HsFunTy ag ah) = do
653 put_ bh (HsListTy ai) = do
656 put_ bh (HsPArrTy aj) = do
659 put_ bh (HsTupleTy ak al) = do
663 put_ bh (HsOpTy am an ao) = do
668 put_ bh (HsNumTy ap) = do
671 put_ bh (HsPredTy aq) = do
674 put_ bh (HsKindSig ar as) = do
684 return (HsForAllTy aa ab ac)
689 return (HsAppTy ae af)
692 return (HsFunTy ag ah)
699 return (HsTupleTy ak al)
703 return (HsOpTy am an ao)
710 return (HsKindSig ar as)
712 instance (Binary name) => Binary (HsPred name) where
713 put_ bh (HsClassP aa ab) = do
717 put_ bh (HsIParam ac ad) = do
726 return (HsClassP aa ab)
729 return (HsIParam ac ad)
731 instance (Binary name) => Binary (UfExpr name) where
732 put_ bh (UfVar aa) = do
735 put_ bh (UfType ab) = do
738 put_ bh (UfTuple ac ad) = do
742 put_ bh (UfLam ae af) = do
746 put_ bh (UfApp ag ah) = do
750 put_ bh (UfCase ai aj ak) = do
755 put_ bh (UfLet al am) = do
759 put_ bh (UfNote an ao) = do
763 put_ bh (UfLit ap) = do
766 put_ bh (UfLitLit aq ar) = do
770 put_ bh (UfFCall as at) = do
783 return (UfTuple ac ad)
793 return (UfCase ai aj ak)
799 return (UfNote an ao)
804 return (UfLitLit aq ar)
807 return (UfFCall as at)
809 instance (Binary name) => Binary (UfConAlt name) where
810 put_ bh UfDefault = do
812 put_ bh (UfDataAlt aa) = do
815 put_ bh (UfTupleAlt ab) = do
818 put_ bh (UfLitAlt ac) = do
821 put_ bh (UfLitLitAlt ad ae) = do
828 0 -> do return UfDefault
830 return (UfDataAlt aa)
832 return (UfTupleAlt ab)
837 return (UfLitLitAlt ad ae)
839 instance (Binary name) => Binary (UfBinding name) where
840 put_ bh (UfNonRec aa ab) = do
844 put_ bh (UfRec ac) = do
852 return (UfNonRec aa ab)
856 instance (Binary name) => Binary (UfBinder name) where
857 put_ bh (UfValBinder aa ab) = do
861 put_ bh (UfTyBinder ac ad) = do
870 return (UfValBinder aa ab)
873 return (UfTyBinder ac ad)
875 instance (Binary name) => Binary (HsIdInfo name) where
876 put_ bh (HsArity aa) = do
879 put_ bh (HsStrictness ab) = do
882 put_ bh (HsUnfold ac ad) = do
886 put_ bh HsNoCafRefs = do
888 put_ bh (HsWorker ae af) = do
898 return (HsStrictness ab)
901 return (HsUnfold ac ad)
902 3 -> do return HsNoCafRefs
905 return (HsWorker ae af)
907 instance (Binary name) => Binary (UfNote name) where
908 put_ bh (UfSCC aa) = do
911 put_ bh (UfCoerce ab) = do
914 put_ bh UfInlineCall = do
916 put_ bh UfInlineMe = do
925 2 -> do return UfInlineCall
926 _ -> do return UfInlineMe
928 instance (Binary name) => Binary (BangType name) where
929 put_ bh (BangType aa ab) = do
935 return (BangType aa ab)
937 instance (Binary name) => Binary (ConDetails name) where
938 put_ bh (VanillaCon aa) = do
941 put_ bh (InfixCon ab ac) = do
945 put_ bh (RecCon ad) = do
952 return (VanillaCon aa)
955 return (InfixCon ab ac)
959 instance (Binary datacon) => Binary (DataConDetails datacon) where
960 put_ bh (DataCons aa) = do
965 put_ bh (HasCons ab) = do
973 1 -> do return Unknown
977 instance (Binary id) => Binary (DefMeth id) where
978 put_ bh NoDefMeth = do
980 put_ bh (DefMeth aa) = do
983 put_ bh GenDefMeth = do
988 0 -> do return NoDefMeth
991 _ -> do return GenDefMeth
993 instance Binary IsCafCC where
996 put_ bh NotCafCC = do
1001 0 -> do return CafCC
1002 _ -> do return NotCafCC
1004 instance Binary IsDupdCC where
1005 put_ bh OriginalCC = do
1012 0 -> do return OriginalCC
1013 _ -> do return DupdCC
1015 instance Binary CostCentre where
1016 put_ bh NoCostCentre = do
1018 put_ bh (NormalCC aa ab ac ad) = do
1024 put_ bh (AllCafsCC ae) = do
1030 0 -> do return NoCostCentre
1031 1 -> do aa <- get bh
1035 return (NormalCC aa ab ac ad)
1036 _ -> do ae <- get bh
1037 return (AllCafsCC ae)