shaniqua-plugins/Language/Hi/Parser.hs

{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds -fno-warn-name-shadowing #-}
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
-- 
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
-- 
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
-- Lesser General Public License for more details.
-- 
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
-- USA
--

--
-- Based on $fptools/ghc/compiler/iface/BinIface.hs
--
--  (c) The University of Glasgow 2002
-- 
-- Binary interface file support.
--

--
-- This provides the "Binary" instances for the Iface type such that we
-- can parse binary representations of that type. i.e. from .hi files
--
-- The main problem we have is that all the stuff we don't care about,
-- we just want to read in to a string. So this has to be hand-hacked
-- somewhat.
--
-- The "Binary" class for hs-plugins only includes a get method. We
-- don't do any writing. Saves us having to properly reconstruct the
-- abstract syntax, which would pull in *way* too much of GHC.
--



module Language.Hi.Parser ( readIface, module Language.Hi.Syntax ) where

import Language.Hi.Syntax
import Language.Hi.Binary
import Language.Hi.FastString

#include "../../config.h"

-- ---------------------------------------------------------------------------
-- how to get there from here

readIface :: FilePath -> IO Iface
readIface hi_path = getBinFileWithDict hi_path

-- ---------------------------------------------------------------------
-- All the Binary instances
--
-- Reading a binary interface into ParsedIface
--
-- We pull the trick of only reading up to the point we need
--

instance Binary Iface where
    get bh = do
            version   <- get bh :: IO String
            build_tag <- get bh :: IO String     -- 'way' flag

#if __GLASGOW_HASKELL__ >= 604
            mod_name  <- get bh :: IO FastString
            _is_boot  <- get bh :: IO Bool
            let pkg_name = mkFastString "unknown"  -- >=604 has no package field
#elif CABAL == 1 && __GLASGOW_HASKELL__ == 603
            mod_name <- get bh :: IO FastString
            let pkg_name = mkFastString "unknown"
#else /* <= 622 */
            mod_name  <- get bh :: IO FastString
            pkg_name  <- get bh :: IO FastString
#endif
            mod_vers  <- get bh :: IO Version
            orphan    <- get bh :: IO Bool
            deps      <- get bh :: IO Dependencies

            get bh :: IO (Bin Int) -- fake a lazyGet for [Usage]
            usages    <- get bh :: IO [Usage]

            exports   <- get bh :: IO [IfaceExport]

--      (exp_vers  :: Version)              <- get bh
--      (fixities  :: [(OccName,Fixity)])   <- get bh
--      (deprecs   :: [IfaceDeprec])        <- get bh

--      (decls     :: [(Version,IfaceDecl)])<- get bh

--      (insts     :: [IfaceInst])          <- get bh
--      (rules     :: [IfaceRule])          <- get bh
--      (rule_vers :: Version)              <- get bh

            return $ Iface {
                 mi_package   = unpackFS pkg_name,
                 mi_module    = unpackFS mod_name,
                 mi_deps      = deps ,
                 mi_usages    = usages,
                 mi_exports   = exports {-,-} 

--              mi_mod_vers  = mod_vers,
--              mi_boot      = False,  -- .hi files are never .hi-boot files!
--              mi_orphan    = orphan,
--              mi_usages    = usages,
--              mi_exports   = exports,
--              mi_exp_vers  = exp_vers,
--              mi_fixities  = fixities,
--              mi_deprecs   = deprecs,
--              mi_decls     = decls,
--              mi_insts     = insts,
--              mi_rules     = rules,
--              mi_rule_vers = rule_vers 
            }

------------------------------------------------------------------------
--
--        Types from: Iface.hs, HscTypes
--

-- fake a lazyGet
instance Binary Dependencies where
    get bh = do get bh :: IO (Bin Int)  -- really a BinPtr Int
                ms <- get bh :: IO [(FastString,Bool)]
                ps <- get bh :: IO [FastString]
                _  <- get bh :: IO [FastString]         -- !!orphans
                return Deps { dep_mods  = map unpackFS $! map fst ms, 
                              dep_pkgs  = map unpackFS ps {-,-}
                       }

------------------------------------------------------------------------
-- Usages
------------------------------------------------------------------------

instance Binary OccName where
        get bh = do aa <- get bh :: IO NameSpace
                    ab <- get bh :: IO FastString
                    return $ OccName aa (unpackFS ab)

instance Binary NameSpace where
        get bh = do h <- getByte bh
                    case h of
                      0 -> return VarName
                      1 -> return DataName
                      2 -> return TvName
                      _ -> return TcClsName

instance Binary Usage where
    get bh = do (nm   :: FastString)                <- get bh
                (mod  :: Version)                   <- get bh
                (exps :: Maybe Version)             <- get bh
                (ents :: [(OccName,Version)])       <- get bh
                (rules :: Version)                  <- get bh
                return $ Usage {usg_name = (unpackFS nm), 
                                usg_mod = mod,
                                usg_exports = exps, 
                                usg_entities = ents,
                                usg_rules = rules }

------------------------------------------------------------------------
-- Exports

instance (Binary name) => Binary (GenAvailInfo name) where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: name) <- get bh
                  return $ Avail aa
          _ -> do (ab :: name)   <- get bh
                  (ac :: [name]) <- get bh
                  return $ AvailTC ab ac

{-
instance Binary a => Binary (Deprecs a) where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return Deprecs
          1 -> do (aa :: FastString) <- get bh
                  return Deprecs
          _ -> do (ab :: a) <- get bh
                  return Deprecs
-}

-------------------------------------------------------------------------
--        Types from: BasicTypes
-------------------------------------------------------------------------

{-
instance Binary Activation where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return Activation
          1 -> return Activation
          2 -> do (aa :: Int) <- get bh ; return Activation
          _ -> do (ab :: Int) <- get bh ; return Activation

instance Binary StrictnessMark where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return StrictnessMark
          1 -> return StrictnessMark
          _ -> return StrictnessMark

instance Binary Boxity where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return Boxity
          _ -> return Boxity

instance Binary TupCon where
    get bh = do
      (ab :: Boxity) <- get bh
      (ac :: Arity)  <- get bh
      return TupCon

instance Binary RecFlag where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return RecFlag
          _ -> return RecFlag

instance Binary DefMeth where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return DefMeth
          1 -> return DefMeth
          _ -> return DefMeth

instance Binary FixityDirection where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return FixityDirection
          1 -> return FixityDirection
          _ -> return FixityDirection

instance Binary Fixity where
    get bh = do
      (aa :: Int)             <- get bh
      (ab :: FixityDirection) <- get bh
      return Fixity

instance (Binary name) => Binary (IPName name) where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: name) <- get bh ; return IPName
          _ -> do (ab :: name) <- get bh ; return IPName

-------------------------------------------------------------------------
--        Types from: basicTypes/NewDemand
-------------------------------------------------------------------------

instance Binary DmdType where
    -- Ignore DmdEnv when spitting out the DmdType
    get bh = do (ds :: [Demand])  <- get bh
                (dr :: DmdResult) <- get bh
                return DmdType

instance Binary Demand where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return Demand
          1 -> return Demand
          2 -> do (aa :: Demand)  <- get bh ; return Demand
          3 -> do (ab :: Demands) <- get bh ; return Demand
          4 -> do (ac :: Demands) <- get bh ; return Demand
          5 -> do (ad :: Demand)  <- get bh ; return Demand
          _ -> return Demand

instance Binary Demands where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: Demand)   <- get bh
                  return Demands
          _ -> do (ab :: [Demand]) <- get bh
                  return Demands

instance Binary DmdResult where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return DmdResult
          1 -> return DmdResult
          _ -> return DmdResult

instance Binary StrictSig where
        get bh = do (aa :: DmdType) <- get bh ; return StrictSig
-}

-------------------------------------------------------------------------
--        Types from: CostCentre, from profiling/CostCentre.lhs
-------------------------------------------------------------------------

{-
instance Binary IsCafCC where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return IsCafCC
          _ -> return IsCafCC

instance Binary IsDupdCC where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return IsDupdCC
          _ -> return IsDupdCC

instance Binary CostCentre where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do return CostCentre
          1 -> do (aa :: CcName)        <- get bh
                  (ab :: ModuleName)    <- get bh
                  (ac :: IsDupdCC)      <- get bh
                  (ad :: IsCafCC)       <- get bh
                  return CostCentre
          _ -> do (ae :: ModuleName)    <- get bh
                  return CostCentre
-}

-------------------------------------------------------------------------
--        IfaceTypes and friends, from IfaceType.lhs
-------------------------------------------------------------------------

{-
instance Binary IfaceExtName where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (mod :: ModuleName) <- get bh
                  (occ :: OccName)    <- get bh
                  return IfaceExtName
          1 -> do (mod :: ModuleName) <- get bh
                  (occ :: OccName)    <- get bh
                  (vers :: Version)   <- get bh
                  return IfaceExtName
          _ -> do (occ :: OccName)    <- get bh
                  return IfaceExtName

instance Binary IfaceBndr where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: IfaceIdBndr) <- get bh ; return IfaceBndr
          _ -> do (ab :: IfaceTvBndr) <- get bh ; return IfaceBndr

instance Binary Kind where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return Kind
          1 -> return Kind
          2 -> return Kind
          3 -> return Kind
          4 -> return Kind
          _ -> do (k1 :: Kind) <- get bh
                  (k2 :: Kind) <- get bh
                  return Kind

instance Binary IfaceType where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: IfaceTvBndr)   <- get bh
                  (ab :: IfaceType)     <- get bh
                  return IfaceType
          1 -> do (ad :: OccName)       <- get bh
                  return IfaceType
          2 -> do (ae :: IfaceType)     <- get bh
                  (af :: IfaceType)     <- get bh
                  return IfaceType
          3 -> do (ag :: IfaceType)     <- get bh
                  (ah :: IfaceType)     <- get bh
                  return IfaceType
          5 -> do (ap :: IfacePredType) <- get bh
                  return IfaceType

        -- Now the special cases for TyConApp
          6 -> return IfaceType
          7 -> return IfaceType
          8 -> return IfaceType
          9 -> do (ty :: IfaceType)     <- get bh
                  return IfaceType
          10 -> return IfaceType
          11 -> do (t1 :: IfaceType)    <- get bh
                   (t2 :: IfaceType)    <- get bh
                   return IfaceType
          12 -> do (tc :: IfaceExtName) <- get bh
                   (tys :: [IfaceType]) <- get bh
                   return IfaceType
          _  -> do (tc :: IfaceTyCon)   <- get bh
                   (tys :: [IfaceType]) <- get bh
                   return IfaceType

instance Binary IfaceTyCon where
   get bh = do
    h <- getByte bh
    case h of
      1 -> return IfaceTyCon
      2 -> return IfaceTyCon
      _ -> do (bx :: Boxity) <- get bh
              (ar :: Arity)  <- get bh
              return IfaceTyCon

instance Binary IfacePredType where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: IfaceExtName) <- get bh
                  (ab :: [IfaceType])  <- get bh
                  return IfacePredType
          _ -> do (ac :: (IPName OccName))      <- get bh
                  (ad :: IfaceType)             <- get bh
                  return IfacePredType

instance Binary IfaceExpr where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: OccName)       <- get bh
                  return IfaceExpr
          1 -> do (ab :: IfaceType)     <- get bh
                  return IfaceExpr
          2 -> do (ac :: Boxity)        <- get bh
                  (ad :: [IfaceExpr])   <- get bh
                  return IfaceExpr
          3 -> do (ae :: IfaceBndr)     <- get bh
                  (af :: IfaceExpr)     <- get bh
                  return IfaceExpr
          4 -> do (ag :: IfaceExpr)     <- get bh
                  (ah :: IfaceExpr)     <- get bh
                  return IfaceExpr
          5 -> do (ai :: IfaceExpr)     <- get bh
                  (aj :: OccName)       <- get bh
                  (ak :: [IfaceAlt])    <- get bh
                  return IfaceExpr
          6 -> do (al :: IfaceBinding)  <- get bh
                  (am :: IfaceExpr)     <- get bh
                  return IfaceExpr
          7 -> do (an :: IfaceNote)     <- get bh
                  (ao :: IfaceExpr)     <- get bh
                  return IfaceExpr
          8 -> do (ap :: Literal)       <- get bh
                  return IfaceExpr
          9 -> do (as :: ForeignCall)   <- get bh
                  (at :: IfaceType)     <- get bh
                  return IfaceExpr
          _ -> do (aa :: IfaceExtName)  <- get bh
                  return IfaceExpr

instance Binary IfaceConAlt where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return IfaceConAlt
          1 -> do (aa :: OccName) <- get bh
                  return IfaceConAlt
          2 -> do (ab :: Boxity)  <- get bh
                  return IfaceConAlt
          _ -> do (ac :: Literal) <- get bh
                  return IfaceConAlt

instance Binary IfaceBinding where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: IfaceIdBndr) <- get bh
                  (ab :: IfaceExpr)   <- get bh
                  return IfaceBinding
          _ -> do (ac :: [(IfaceIdBndr,IfaceExpr)]) <- get bh
                  return IfaceBinding

instance Binary IfaceIdInfo where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return IfaceIdInfo
          _ -> do (info :: [IfaceInfoItem]) <- lazyGet bh
                  return IfaceIdInfo

instance Binary IfaceInfoItem where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: Arity)         <- get bh
                  return IfaceInfoItem
          1 -> do (ab :: StrictSig)     <- get bh
                  return IfaceInfoItem
          2 -> do (ac :: Activation)    <- get bh
                  (ad :: IfaceExpr)     <- get bh
                  return IfaceInfoItem
          3 -> return IfaceInfoItem
          _ -> do (ae :: IfaceExtName) <- get bh
                  (af :: Arity)        <- get bh
                  return IfaceInfoItem

instance Binary IfaceNote where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do (aa :: CostCentre) <- get bh
                  return IfaceNote
          1 -> do (ab :: IfaceType ) <- get bh
                  return IfaceNote
          2 -> return IfaceNote
          3 -> return IfaceNote
          _ -> do (ac :: String) <- get bh
                  return IfaceNote

instance Binary IfaceDecl where
    get bh = do
        h <- getByte bh
        case h of
          0 -> do 
            (name :: OccName)           <- get bh
            (ty :: IfaceType)           <- get bh
            (idinfo :: IfaceIdInfo)     <- get bh
            return IfaceDecl
          1 -> error "Binary.get(TyClDecl): ForeignType"
          2 -> do
            (a1 :: IfaceContext)  <- get bh
            (a2 :: OccName)       <- get bh
            (a3 :: [IfaceTvBndr]) <- get bh
            (a4 :: IfaceConDecls) <- get bh
            (a5 :: RecFlag)       <- get bh
            (a6 :: ArgVrcs)       <- get bh
            (a7 :: Bool)          <- get bh
            return IfaceDecl
          3 -> do
            (aq :: OccName)       <- get bh
            (ar :: [IfaceTvBndr]) <- get bh
            (as :: ArgVrcs)       <- get bh
            (at :: IfaceType)     <- get bh
            return IfaceDecl
          _ -> do
            (a1 :: IfaceContext)    <- get bh
            (a2 :: OccName)         <- get bh
            (a3 :: [IfaceTvBndr])   <- get bh
            (a4 :: [FunDep OccName])<- get bh
            (a5 :: [IfaceClassOp])  <- get bh
            (a6 :: RecFlag)         <- get bh
            (a7 :: ArgVrcs)         <- get bh
            return IfaceDecl

instance Binary IfaceInst where
    get bh = do 
        (ty :: IfaceType) <- get bh
        (dfun :: OccName) <- get bh
        return IfaceInst

instance Binary IfaceConDecls where
    get bh = do
        h <- getByte bh
        case h of
          0 -> return IfaceConDecls
          1 -> do (aa :: [IfaceConDecl]) <- get bh
                  return IfaceConDecls
          _ -> do (aa :: IfaceConDecl)   <- get bh
                  return IfaceConDecls

instance Binary IfaceConDecl where
    get bh = do
        (a1 :: OccName)         <- get bh
        (a2 :: [IfaceTvBndr])   <- get bh
        (a3 :: IfaceContext)    <- get bh
        (a4 :: [IfaceType])     <- get bh
        (a5 :: [StrictnessMark])<- get bh
        (a6 :: [OccName])       <- get bh
        return IfaceConDecl

instance Binary IfaceClassOp where
   get bh = do
        (n   :: OccName)   <- get bh
        (def :: DefMeth)   <- get bh
        (ty  :: IfaceType) <- get bh
        return IfaceClassOp

instance Binary IfaceRule where
    get bh = do
        (a1 :: RuleName)        <- get bh
        (a2 :: Activation)      <- get bh
        (a3 :: [IfaceBndr])     <- get bh
        (a4 :: IfaceExtName)    <- get bh
        (a5 :: [IfaceExpr])     <- get bh
        (a6 :: IfaceExpr)       <- get bh
        return IfaceRule

-}

------------------------------------------------------------------------
-- from Literal
------------------------------------------------------------------------

{-
instance Binary Literal where
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do
		    (aa :: Char) <- get bh
		    return Literal
	      1 -> do
		    (ab :: FastString) <- get bh
		    return Literal
	      2 -> do return Literal
	      3 -> do
		    (ad :: Integer) <- get bh
		    return Literal
	      4 -> do
		    (ae :: Integer) <- get bh
		    return Literal
	      5 -> do
		    (af :: Integer) <- get bh
		    return Literal
	      6 -> do
		    (ag :: Integer) <- get bh
		    return Literal
	      7 -> do
		    (ah :: Rational) <- get bh
		    return Literal
	      8 -> do
		    (ai :: Rational) <- get bh
		    return Literal
	      9 -> do
		    (aj :: FastString) <- get bh
		    (mb :: Maybe Int)  <- get bh
		    return Literal
              _ -> return Literal -- ?

-}

------------------------------------------------------------------------
-- prelude/ForeignCall.lhs
------------------------------------------------------------------------

{-
instance Binary ForeignCall where
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do (aa :: CCallSpec) <- get bh
		      return ForeignCall
	      _ -> do (ab :: DNCallSpec) <- get bh
		      return ForeignCall

instance Binary Safety where
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do (aa :: Bool) <- get bh
		      return Safety
	      _ -> return Safety

instance Binary CExportSpec where
    get bh = do
	  (aa :: CLabelString) <- get bh
	  (ab :: CCallConv)    <- get bh
	  return CExportSpec

instance Binary CCallSpec where
    get bh = do
	  (aa :: CCallTarget) <- get bh
	  (ab :: CCallConv)   <- get bh
	  (ac :: Safety)      <- get bh
	  return CCallSpec

instance Binary CCallTarget where
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> do (aa :: CLabelString) <- get bh
		      return CCallTarget
	      _ -> return CCallTarget

instance Binary CCallConv where
    get bh = do
	    h <- getByte bh
	    case h of
	      0 -> return CCallConv
	      _ -> return CCallConv

instance Binary DNCallSpec where
    get bh = do
          (isStatic :: Bool)  <- get bh
	  (kind   :: DNKind)  <- get bh
	  (ass   :: String)   <- get bh
	  (nm    :: String)   <- get bh
	  return DNCallSpec

instance Binary DNKind where
    get bh = do
	    h <- getByte bh
	    case h of
	      _ -> return DNKind

instance Binary DNType where
    get bh = do
	    h <- getByte bh
	    case h of
	      _ -> return DNType

-}