wrath/shaniqua-plugins
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Partially improve the cabalisation

Browse Source
This commit is contained in:
Don Stewart
2005-09-03 03:10:04 +00:00
parent 698e960ad4
commit 90d780cff8
35 changed files with 57 additions and 26 deletions
Download Patch File Download Diff File Expand all files Collapse all files

162
src/AltData/Dynamic.hs
View File

@ -1,162 +0,0 @@
{-# OPTIONS -fglasgow-exts -cpp #-}
-----------------------------------------------------------------------------
-- |
-- Module : Data.Dynamic
-- Copyright : (c) The University of Glasgow 2001
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- The Dynamic interface provides basic support for dynamic types.
--
-- Operations for injecting values of arbitrary type into
-- a dynamically typed value, Dynamic, are provided, together
-- with operations for converting dynamic values into a concrete
-- (monomorphic) type.
--
-----------------------------------------------------------------------------
module AltData.Dynamic (
-- Module Data.Typeable re-exported for convenience
module AltData.Typeable,
-- * The @Dynamic@ type
Dynamic, -- abstract, instance of: Show, Typeable
-- * Converting to and from @Dynamic@
toDyn, -- :: Typeable a => a -> Dynamic
fromDyn, -- :: Typeable a => Dynamic -> a -> a
fromDynamic, -- :: Typeable a => Dynamic -> Maybe a
#if __GLASGOW_HASKELL__ >= 603
-- * Applying functions of dynamic type
dynApply,
dynApp,
dynTypeRep
#endif
) where
import AltData.Typeable
import Data.Maybe
import System.IO.Unsafe (unsafePerformIO)
import GHC.Base
import GHC.Show
#if __GLASGOW_HASKELL__ >= 603
import GHC.Err
#endif
unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce#
-------------------------------------------------------------
--
-- The type Dynamic
--
-------------------------------------------------------------
{-|
A value of type 'Dynamic' is an object encapsulated together with its type.
A 'Dynamic' may only represent a monomorphic value; an attempt to
create a value of type 'Dynamic' from a polymorphically-typed
expression will result in an ambiguity error (see 'toDyn').
'Show'ing a value of type 'Dynamic' returns a pretty-printed representation
of the object\'s type; useful for debugging.
-}
data Dynamic = Dynamic TypeRep Obj
instance Typeable Dynamic where
#if __GLASGOW_HASKELL__ >= 603
typeOf _ = mkTyConApp (mkTyCon "AltData.Dynamic") []
#else
typeOf _ = mkAppTy (mkTyCon "AltData.Dynamic") []
#endif
instance Show Dynamic where
-- the instance just prints the type representation.
showsPrec _ (Dynamic t _) =
showString "<<" .
showsPrec 0 t .
showString ">>"
type Obj = forall a . a
-- Dummy type to hold the dynamically typed value.
--
-- In GHC's new eval/apply execution model this type must
-- be polymorphic. It can't be a constructor, because then
-- GHC will use the constructor convention when evaluating it,
-- and this will go wrong if the object is really a function. On
-- the other hand, if we use a polymorphic type, GHC will use
-- a fallback convention for evaluating it that works for all types.
-- (using a function type here would also work).
-- | Converts an arbitrary value into an object of type 'Dynamic'.
--
-- The type of the object must be an instance of 'Typeable', which
-- ensures that only monomorphically-typed objects may be converted to
-- 'Dynamic'. To convert a polymorphic object into 'Dynamic', give it
-- a monomorphic type signature. For example:
--
-- > toDyn (id :: Int -> Int)
--
toDyn :: Typeable a => a -> Dynamic
toDyn v = Dynamic (typeOf v) (unsafeCoerce v)
-- | Converts a 'Dynamic' object back into an ordinary Haskell value of
-- the correct type. See also 'fromDynamic'.
fromDyn :: Typeable a
=> Dynamic -- ^ the dynamically-typed object
-> a -- ^ a default value
-> a -- ^ returns: the value of the first argument, if
-- it has the correct type, otherwise the value of
-- the second argument.
fromDyn (Dynamic t v) def
| typeOf def == t = unsafeCoerce v
| otherwise = def
-- | Converts a 'Dynamic' object back into an ordinary Haskell value of
-- the correct type. See also 'fromDyn'.
fromDynamic
:: Typeable a
=> Dynamic -- ^ the dynamically-typed object
-> Maybe a -- ^ returns: @'Just' a@, if the dynamically-typed
-- object has the correct type (and @a@ is its value),
-- or 'Nothing' otherwise.
fromDynamic (Dynamic t v) =
case unsafeCoerce v of
r | t == typeOf r -> Just r
| otherwise -> unsafePerformIO (putStrLn $
"Couldn't match `" ++show(typeOf r) ++
"' against `" ++show t ++"'"++
"\n\tExpected type: " ++show(typeOf r) ++
"\n\tInferred type: " ++show t
) `seq` Nothing
#if __GLASGOW_HASKELL__ >= 603
-- (f::(a->b)) `dynApply` (x::a) = (f a)::b
dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
dynApply (Dynamic t1 f) (Dynamic t2 x) =
case funResultTy t1 t2 of
Just t3 -> Just (Dynamic t3 ((unsafeCoerce f) x))
Nothing -> Nothing
dynApp :: Dynamic -> Dynamic -> Dynamic
dynApp f x = case dynApply f x of
Just r -> r
Nothing -> error ("Type error in dynamic application.\n" ++
"Can't apply function " ++ show f ++
" to argument " ++ show x)
dynTypeRep :: Dynamic -> TypeRep
dynTypeRep (Dynamic tr _) = tr
#endif

958
src/AltData/Typeable.hs
View File

@ -1,958 +0,0 @@
{-# OPTIONS -cpp -fglasgow-exts -fno-implicit-prelude #-}
--
-- 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:
--
-- |
-- Module : Data.Typeable
-- Copyright : (c) The University of Glasgow, CWI 2001--2004
-- License : BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer : libraries@haskell.org
-- Stability : experimental
-- Portability : portable
--
-- The Typeable class reifies types to some extent by associating type
-- representations to types. These type representations can be compared,
-- and one can in turn define a type-safe cast operation. To this end,
-- an unsafe cast is guarded by a test for type (representation)
-- equivalence. The module Data.Dynamic uses Typeable for an
-- implementation of dynamics. The module Data.Generics uses Typeable
-- and type-safe cast (but not dynamics) to support the \"Scrap your
-- boilerplate\" style of generic programming.
--
module AltData.Typeable
#if __GLASGOW_HASKELL__ >= 603
(
-- * The Typeable class
Typeable( typeOf ), -- :: a -> TypeRep
-- * Type-safe cast
cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
gcast, -- a generalisation of cast
-- * Type representations
TypeRep, -- abstract, instance of: Eq, Show, Typeable
TyCon, -- abstract, instance of: Eq, Show, Typeable
-- * Construction of type representations
mkTyCon, -- :: String -> TyCon
mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep
mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep
mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
-- * Observation of type representations
splitTyConApp, -- :: TypeRep -> (TyCon, [TypeRep])
funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
typeRepTyCon, -- :: TypeRep -> TyCon
typeRepArgs, -- :: TypeRep -> [TypeRep]
tyConString, -- :: TyCon -> String
-- * The other Typeable classes
-- | /Note:/ The general instances are provided for GHC only.
Typeable1( typeOf1 ), -- :: t a -> TypeRep
Typeable2( typeOf2 ), -- :: t a b -> TypeRep
Typeable3( typeOf3 ), -- :: t a b c -> TypeRep
Typeable4( typeOf4 ), -- :: t a b c d -> TypeRep
Typeable5( typeOf5 ), -- :: t a b c d e -> TypeRep
Typeable6( typeOf6 ), -- :: t a b c d e f -> TypeRep
Typeable7( typeOf7 ), -- :: t a b c d e f g -> TypeRep
gcast1, -- :: ... => c (t a) -> Maybe (c (t' a))
gcast2, -- :: ... => c (t a b) -> Maybe (c (t' a b))
-- * Default instances
-- | /Note:/ These are not needed by GHC, for which these instances
-- are generated by general instance declarations.
typeOfDefault, -- :: (Typeable1 t, Typeable a) => t a -> TypeRep
typeOf1Default, -- :: (Typeable2 t, Typeable a) => t a b -> TypeRep
typeOf2Default, -- :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
typeOf3Default, -- :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
typeOf4Default, -- :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
typeOf5Default, -- :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
typeOf6Default -- :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
) where
import qualified Data.HashTable as HT
import Data.Maybe
import Data.Either
import Data.Int
import Data.Word
import Data.List( foldl )
import GHC.Base
import GHC.Show
import GHC.Err
import GHC.Num
import GHC.Float
import GHC.Real( rem, Ratio )
import GHC.IOBase
import GHC.Ptr -- So we can give Typeable instance for Ptr
import GHC.Stable -- So we can give Typeable instance for StablePtr
unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce#
#include "Typeable.h"
-------------------------------------------------------------
--
-- Type representations
--
-------------------------------------------------------------
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
-- supports reasonably efficient equality.
--
-- equality of keys doesn't work for dynamically loaded code, so we
-- revert back to canonical type names.
--
data TypeRep = TypeRep !Key TyCon [TypeRep]
-- Compare keys for equality
instance Eq TypeRep where
(TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2
-- | An abstract representation of a type constructor. 'TyCon' objects can
-- be built using 'mkTyCon'.
data TyCon = TyCon !Key String
instance Eq TyCon where
(TyCon _ s1) == (TyCon _ s2) = s1 == s2
--
-- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,")
-- [fTy,fTy,fTy])
--
-- returns "(Foo,Foo,Foo)"
--
-- The TypeRep Show instance promises to print tuple types
-- correctly. Tuple type constructors are specified by a
-- sequence of commas, e.g., (mkTyCon ",,,,") returns
-- the 5-tuple tycon.
----------------- Construction --------------------
-- | Applies a type constructor to a sequence of types
mkTyConApp :: TyCon -> [TypeRep] -> TypeRep
mkTyConApp tc@(TyCon tc_k _) args
= TypeRep (appKeys tc_k arg_ks) tc args
where
arg_ks = [k | TypeRep k _ _ <- args]
-- | A special case of 'mkTyConApp', which applies the function
-- type constructor to a pair of types.
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkTyConApp funTc [f,a]
-- | Splits a type constructor application
splitTyConApp :: TypeRep -> (TyCon,[TypeRep])
splitTyConApp (TypeRep _ tc trs) = (tc,trs)
-- | Applies a type to a function type. Returns: @'Just' u@ if the
-- first argument represents a function of type @t -> u@ and the
-- second argument represents a function of type @t@. Otherwise,
-- returns 'Nothing'.
funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep
funResultTy trFun trArg
= case splitTyConApp trFun of
(tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2
_ -> Nothing
-- | Adds a TypeRep argument to a TypeRep.
mkAppTy :: TypeRep -> TypeRep -> TypeRep
mkAppTy (TypeRep tr_k tc trs) arg_tr
= let (TypeRep arg_k _ _) = arg_tr
in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr])
-- If we enforce the restriction that there is only one
-- @TyCon@ for a type & it is shared among all its uses,
-- we can map them onto Ints very simply. The benefit is,
-- of course, that @TyCon@s can then be compared efficiently.
-- Provided the implementor of other @Typeable@ instances
-- takes care of making all the @TyCon@s CAFs (toplevel constants),
-- this will work.
-- If this constraint does turn out to be a sore thumb, changing
-- the Eq instance for TyCons is trivial.
-- | Builds a 'TyCon' object representing a type constructor. An
-- implementation of "Data.Typeable" should ensure that the following holds:
--
-- > mkTyCon "a" == mkTyCon "a"
--
mkTyCon :: String -- ^ the name of the type constructor (should be unique
-- in the program, so it might be wise to use the
-- fully qualified name).
-> TyCon -- ^ A unique 'TyCon' object
mkTyCon str = TyCon (mkTyConKey str) str
----------------- Observation ---------------------
-- | Observe the type constructor of a type representation
typeRepTyCon :: TypeRep -> TyCon
typeRepTyCon (TypeRep _ tc _) = tc
-- | Observe the argument types of a type representation
typeRepArgs :: TypeRep -> [TypeRep]
typeRepArgs (TypeRep _ _ args) = args
-- | Observe string encoding of a type representation
tyConString :: TyCon -> String
tyConString (TyCon _ str) = str
----------------- Showing TypeReps --------------------
instance Show TypeRep where
showsPrec p (TypeRep _ tycon tys) =
case tys of
[] -> showsPrec p tycon
[x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
[a,r] | tycon == funTc -> showParen (p > 8) $
showsPrec 9 a .
showString " -> " .
showsPrec 8 r
xs | isTupleTyCon tycon -> showTuple tycon xs
| otherwise ->
showParen (p > 9) $
showsPrec p tycon .
showChar ' ' .
showArgs tys
instance Show TyCon where
showsPrec _ (TyCon _ s) = showString s
isTupleTyCon :: TyCon -> Bool
isTupleTyCon (TyCon _ (',':_)) = True
isTupleTyCon _ = False
-- Some (Show.TypeRep) helpers:
showArgs :: Show a => [a] -> ShowS
showArgs [] = id
showArgs [a] = showsPrec 10 a
showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
showTuple :: TyCon -> [TypeRep] -> ShowS
showTuple (TyCon _ str) args = showChar '(' . go str args
where
go [] [a] = showsPrec 10 a . showChar ')'
go _ [] = showChar ')' -- a failure condition, really.
go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
go _ _ = showChar ')'
-------------------------------------------------------------
--
-- The Typeable class and friends
--
-------------------------------------------------------------
-- | The class 'Typeable' allows a concrete representation of a type to
-- be calculated.
class Typeable a where
typeOf :: a -> TypeRep
-- ^ Takes a value of type @a@ and returns a concrete representation
-- of that type. The /value/ of the argument should be ignored by
-- any instance of 'Typeable', so that it is safe to pass 'undefined' as
-- the argument.
-- | Variant for unary type constructors
class Typeable1 t where
typeOf1 :: t a -> TypeRep
-- | For defining a 'Typeable' instance from any 'Typeable1' instance.
typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep
typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x)
where
argType :: t a -> a
argType = undefined
-- | Variant for binary type constructors
class Typeable2 t where
typeOf2 :: t a b -> TypeRep
-- | For defining a 'Typeable1' instance from any 'Typeable2' instance.
typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep
typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x)
where
argType :: t a b -> a
argType = undefined
-- | Variant for 3-ary type constructors
class Typeable3 t where
typeOf3 :: t a b c -> TypeRep
-- | For defining a 'Typeable2' instance from any 'Typeable3' instance.
typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep
typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c -> a
argType = undefined
-- | Variant for 4-ary type constructors
class Typeable4 t where
typeOf4 :: t a b c d -> TypeRep
-- | For defining a 'Typeable3' instance from any 'Typeable4' instance.
typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep
typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d -> a
argType = undefined
-- | Variant for 5-ary type constructors
class Typeable5 t where
typeOf5 :: t a b c d e -> TypeRep
-- | For defining a 'Typeable4' instance from any 'Typeable5' instance.
typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep
typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d e -> a
argType = undefined
-- | Variant for 6-ary type constructors
class Typeable6 t where
typeOf6 :: t a b c d e f -> TypeRep
-- | For defining a 'Typeable5' instance from any 'Typeable6' instance.
typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep
typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d e f -> a
argType = undefined
-- | Variant for 7-ary type constructors
class Typeable7 t where
typeOf7 :: t a b c d e f g -> TypeRep
-- | For defining a 'Typeable6' instance from any 'Typeable7' instance.
typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep
typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x)
where
argType :: t a b c d e f g -> a
argType = undefined
-- Given a @Typeable@/n/ instance for an /n/-ary type constructor,
-- define the instances for partial applications.
-- Programmers using non-GHC implementations must do this manually
-- for each type constructor.
-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.)
-- | One Typeable instance for all Typeable1 instances
instance (Typeable1 s, Typeable a)
=> Typeable (s a) where
typeOf = typeOfDefault
-- | One Typeable1 instance for all Typeable2 instances
instance (Typeable2 s, Typeable a)
=> Typeable1 (s a) where
typeOf1 = typeOf1Default
-- | One Typeable2 instance for all Typeable3 instances
instance (Typeable3 s, Typeable a)
=> Typeable2 (s a) where
typeOf2 = typeOf2Default
-- | One Typeable3 instance for all Typeable4 instances
instance (Typeable4 s, Typeable a)
=> Typeable3 (s a) where
typeOf3 = typeOf3Default
-- | One Typeable4 instance for all Typeable5 instances
instance (Typeable5 s, Typeable a)
=> Typeable4 (s a) where
typeOf4 = typeOf4Default
-- | One Typeable5 instance for all Typeable6 instances
instance (Typeable6 s, Typeable a)
=> Typeable5 (s a) where
typeOf5 = typeOf5Default
-- | One Typeable6 instance for all Typeable7 instances
instance (Typeable7 s, Typeable a)
=> Typeable6 (s a) where
typeOf6 = typeOf6Default
-------------------------------------------------------------
--
-- Type-safe cast
--
-------------------------------------------------------------
-- | The type-safe cast operation
cast :: (Typeable a, Typeable b) => a -> Maybe b
cast x = r
where
r = if typeOf x == typeOf (fromJust r)
then Just $ unsafeCoerce x
else Nothing
-- | A flexible variation parameterised in a type constructor
gcast :: (Typeable a, Typeable b) => c a -> Maybe (c b)
gcast x = r
where
r = if typeOf (getArg x) == typeOf (getArg (fromJust r))
then Just $ unsafeCoerce x
else Nothing
getArg :: c x -> x
getArg = undefined
-- | Cast for * -> *
gcast1 :: (Typeable1 t, Typeable1 t') => c (t a) -> Maybe (c (t' a))
gcast1 x = r
where
r = if typeOf1 (getArg x) == typeOf1 (getArg (fromJust r))
then Just $ unsafeCoerce x
else Nothing
getArg :: c x -> x
getArg = undefined
-- | Cast for * -> * -> *
gcast2 :: (Typeable2 t, Typeable2 t') => c (t a b) -> Maybe (c (t' a b))
gcast2 x = r
where
r = if typeOf2 (getArg x) == typeOf2 (getArg (fromJust r))
then Just $ unsafeCoerce x
else Nothing
getArg :: c x -> x
getArg = undefined
-------------------------------------------------------------
--
-- Instances of the Typeable classes for Prelude types
--
-------------------------------------------------------------
INSTANCE_TYPEABLE1([],listTc,"[]")
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
INSTANCE_TYPEABLE2((->),funTc,"->")
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
INSTANCE_TYPEABLE0((),unitTc,"()")
INSTANCE_TYPEABLE2((,),pairTc,",")
INSTANCE_TYPEABLE3((,,),tup3Tc,",,")
tup4Tc :: TyCon
tup4Tc = mkTyCon ",,,"
instance Typeable4 (,,,) where
typeOf4 _ = mkTyConApp tup4Tc []
tup5Tc :: TyCon
tup5Tc = mkTyCon ",,,,"
instance Typeable5 (,,,,) where
typeOf5 _ = mkTyConApp tup5Tc []
tup6Tc :: TyCon
tup6Tc = mkTyCon ",,,,,"
instance Typeable6 (,,,,,) where
typeOf6 _ = mkTyConApp tup6Tc []
tup7Tc :: TyCon
tup7Tc = mkTyCon ",,,,,"
instance Typeable7 (,,,,,,) where
typeOf7 _ = mkTyConApp tup7Tc []
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Foreign.Ptr.Ptr")
INSTANCE_TYPEABLE1(StablePtr,stableptrTc,"Foreign.StablePtr.StablePtr")
INSTANCE_TYPEABLE1(IORef,iorefTc,"Data.IORef.IORef")
-------------------------------------------------------
--
-- Generate Typeable instances for standard datatypes
--
-------------------------------------------------------
INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
INSTANCE_TYPEABLE0(Char,charTc,"Char")
INSTANCE_TYPEABLE0(Float,floatTc,"Float")
INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
INSTANCE_TYPEABLE0(Int,intTc,"Int")
INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
INSTANCE_TYPEABLE0(Word,wordTc,"Word" )
#else /* GHC < 6.3 */
(
-- * The Typeable class
Typeable( typeOf ), -- :: a -> TypeRep
-- * Type-safe cast
cast, -- :: (Typeable a, Typeable b) => a -> Maybe b
castss, -- a cast for kind "* -> *"
castarr, -- another convenient variation
-- * Type representations
TypeRep, -- abstract, instance of: Eq, Show, Typeable
TyCon, -- abstract, instance of: Eq, Show, Typeable
-- * Construction of type representations
mkTyCon, -- :: String -> TyCon
mkAppTy, -- :: TyCon -> [TypeRep] -> TypeRep
mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep
applyTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep
-- * Observation of type representations
typerepTyCon, -- :: TypeRep -> TyCon
typerepArgs, -- :: TypeRep -> [TypeRep]
tyconString -- :: TyCon -> String
) where
import qualified Data.HashTable as HT
import Data.Maybe
import Data.Either
import Data.Int
import Data.Word
import Data.List( foldl )
import GHC.Base
import GHC.Show
import GHC.Err
import GHC.Num
import GHC.Float
import GHC.Real( rem, Ratio )
import GHC.IOBase
import GHC.Ptr -- So we can give Typeable instance for Ptr
import GHC.Stable -- So we can give Typeable instance for StablePtr
unsafeCoerce :: a -> b
unsafeCoerce = unsafeCoerce#
#include "Typeable.h"
-------------------------------------------------------------
--
-- Type representations
--
-------------------------------------------------------------
-- | A concrete representation of a (monomorphic) type. 'TypeRep'
-- supports reasonably efficient equality.
data TypeRep = TypeRep !Key TyCon [TypeRep]
-- Compare keys for equality
instance Eq TypeRep where
(TypeRep _ t1 a1) == (TypeRep _ t2 a2) = t1 == t2 && a1 == a2
-- | An abstract representation of a type constructor. 'TyCon' objects can
-- be built using 'mkTyCon'.
data TyCon = TyCon !Key String
instance Eq TyCon where
(TyCon _ s1) == (TyCon _ s2) = s1 == s2
--
-- let fTy = mkTyCon "Foo" in show (mkAppTy (mkTyCon ",,")
-- [fTy,fTy,fTy])
--
-- returns "(Foo,Foo,Foo)"
--
-- The TypeRep Show instance promises to print tuple types
-- correctly. Tuple type constructors are specified by a
-- sequence of commas, e.g., (mkTyCon ",,,,") returns
-- the 5-tuple tycon.
----------------- Construction --------------------
-- | Applies a type constructor to a sequence of types
mkAppTy :: TyCon -> [TypeRep] -> TypeRep
mkAppTy tc@(TyCon tc_k _) args
= TypeRep (appKeys tc_k arg_ks) tc args
where
arg_ks = [k | TypeRep k _ _ <- args]
funTc :: TyCon
funTc = mkTyCon "->"
-- | A special case of 'mkAppTy', which applies the function
-- type constructor to a pair of types.
mkFunTy :: TypeRep -> TypeRep -> TypeRep
mkFunTy f a = mkAppTy funTc [f,a]
-- | Applies a type to a function type. Returns: @'Just' u@ if the
-- first argument represents a function of type @t -> u@ and the
-- second argument represents a function of type @t@. Otherwise,
-- returns 'Nothing'.
applyTy :: TypeRep -> TypeRep -> Maybe TypeRep
applyTy (TypeRep _ tc [t1,t2]) t3
| tc == funTc && t1 == t3 = Just t2
applyTy _ _ = Nothing
-- If we enforce the restriction that there is only one
-- @TyCon@ for a type & it is shared among all its uses,
-- we can map them onto Ints very simply. The benefit is,
-- of course, that @TyCon@s can then be compared efficiently.
-- Provided the implementor of other @Typeable@ instances
-- takes care of making all the @TyCon@s CAFs (toplevel constants),
-- this will work.
-- If this constraint does turn out to be a sore thumb, changing
-- the Eq instance for TyCons is trivial.
-- | Builds a 'TyCon' object representing a type constructor. An
-- implementation of "Data.Typeable" should ensure that the following holds:
--
-- > mkTyCon "a" == mkTyCon "a"
--
mkTyCon :: String -- ^ the name of the type constructor (should be unique
-- in the program, so it might be wise to use the
-- fully qualified name).
-> TyCon -- ^ A unique 'TyCon' object
mkTyCon str = TyCon (mkTyConKey str) str
----------------- Observation ---------------------
-- | Observe the type constructor of a type representation
typerepTyCon :: TypeRep -> TyCon
typerepTyCon (TypeRep _ tc _) = tc
-- | Observe the argument types of a type representation
typerepArgs :: TypeRep -> [TypeRep]
typerepArgs (TypeRep _ _ args) = args
-- | Observe string encoding of a type representation
tyconString :: TyCon -> String
tyconString (TyCon _ str) = str
----------------- Showing TypeReps --------------------
instance Show TypeRep where
showsPrec p (TypeRep _ tycon tys) =
case tys of
[] -> showsPrec p tycon
[x] | tycon == listTc -> showChar '[' . shows x . showChar ']'
[a,r] | tycon == funTc -> showParen (p > 8) $
showsPrec 9 a . showString " -> " . showsPrec 8 r
xs | isTupleTyCon tycon -> showTuple tycon xs
| otherwise ->
showParen (p > 9) $
showsPrec p tycon .
showChar ' ' .
showArgs tys
instance Show TyCon where
showsPrec _ (TyCon _ s) = showString s
isTupleTyCon :: TyCon -> Bool
isTupleTyCon (TyCon _ (',':_)) = True
isTupleTyCon _ = False
-- Some (Show.TypeRep) helpers:
showArgs :: Show a => [a] -> ShowS
showArgs [] = id
showArgs [a] = showsPrec 10 a
showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as
showTuple :: TyCon -> [TypeRep] -> ShowS
showTuple (TyCon _ str) args = showChar '(' . go str args
where
go [] [a] = showsPrec 10 a . showChar ')'
go _ [] = showChar ')' -- a failure condition, really.
go (',':xs) (a:as) = showsPrec 10 a . showChar ',' . go xs as
go _ _ = showChar ')'
-------------------------------------------------------------
--
-- The Typeable class
--
-------------------------------------------------------------
-- | The class 'Typeable' allows a concrete representation of a type to
-- be calculated.
class Typeable a where
typeOf :: a -> TypeRep
-- ^ Takes a value of type @a@ and returns a concrete representation
-- of that type. The /value/ of the argument should be ignored by
-- any instance of 'Typeable', so that it is safe to pass 'undefined' as
-- the argument.
-------------------------------------------------------------
--
-- Type-safe cast
--
-------------------------------------------------------------
-- | The type-safe cast operation
cast :: (Typeable a, Typeable b) => a -> Maybe b
cast x = r
where
r = if typeOf x == typeOf (fromJust r)
then Just $ unsafeCoerce x
else Nothing
-- | A convenient variation for kind "* -> *"
castss :: (Typeable a, Typeable b) => t a -> Maybe (t b)
castss x = r
where
r = if typeOf (get x) == typeOf (get (fromJust r))
then Just $ unsafeCoerce x
else Nothing
get :: t c -> c
get = undefined
-- | Another variation
castarr :: (Typeable a, Typeable b, Typeable c, Typeable d)
=> (a -> t b) -> Maybe (c -> t d)
castarr x = r
where
r = if typeOf (get x) == typeOf (get (fromJust r))
then Just $ unsafeCoerce x
else Nothing
get :: (e -> t f) -> (e, f)
get = undefined
{-
The variations castss and castarr are arguably not really needed.
Let's discuss castss in some detail. To get rid of castss, we can
require "Typeable (t a)" and "Typeable (t b)" rather than just
"Typeable a" and "Typeable b". In that case, the ordinary cast would
work. Eventually, all kinds of library instances should become
Typeable. (There is another potential use of variations as those given
above. It allows quantification on type constructors.
-}
-------------------------------------------------------------
--
-- Instances of the Typeable class for Prelude types
--
-------------------------------------------------------------
listTc :: TyCon
listTc = mkTyCon "[]"
instance Typeable a => Typeable [a] where
typeOf ls = mkAppTy listTc [typeOf ((undefined :: [a] -> a) ls)]
-- In GHC we can say
-- typeOf (undefined :: a)
-- using scoped type variables, but we use the
-- more verbose form here, for compatibility with Hugs
unitTc :: TyCon
unitTc = mkTyCon "()"
instance Typeable () where
typeOf _ = mkAppTy unitTc []
tup2Tc :: TyCon
tup2Tc = mkTyCon ","
instance (Typeable a, Typeable b) => Typeable (a,b) where
typeOf tu = mkAppTy tup2Tc [typeOf ((undefined :: (a,b) -> a) tu),
typeOf ((undefined :: (a,b) -> b) tu)]
tup3Tc :: TyCon
tup3Tc = mkTyCon ",,"
instance ( Typeable a , Typeable b , Typeable c) => Typeable (a,b,c) where
typeOf tu = mkAppTy tup3Tc [typeOf ((undefined :: (a,b,c) -> a) tu),
typeOf ((undefined :: (a,b,c) -> b) tu),
typeOf ((undefined :: (a,b,c) -> c) tu)]
tup4Tc :: TyCon
tup4Tc = mkTyCon ",,,"
instance ( Typeable a
, Typeable b
, Typeable c
, Typeable d) => Typeable (a,b,c,d) where
typeOf tu = mkAppTy tup4Tc [typeOf ((undefined :: (a,b,c,d) -> a) tu),
typeOf ((undefined :: (a,b,c,d) -> b) tu),
typeOf ((undefined :: (a,b,c,d) -> c) tu),
typeOf ((undefined :: (a,b,c,d) -> d) tu)]
tup5Tc :: TyCon
tup5Tc = mkTyCon ",,,,"
instance ( Typeable a
, Typeable b
, Typeable c
, Typeable d
, Typeable e) => Typeable (a,b,c,d,e) where
typeOf tu = mkAppTy tup5Tc [typeOf ((undefined :: (a,b,c,d,e) -> a) tu),
typeOf ((undefined :: (a,b,c,d,e) -> b) tu),
typeOf ((undefined :: (a,b,c,d,e) -> c) tu),
typeOf ((undefined :: (a,b,c,d,e) -> d) tu),
typeOf ((undefined :: (a,b,c,d,e) -> e) tu)]
instance (Typeable a, Typeable b) => Typeable (a -> b) where
typeOf f = mkFunTy (typeOf ((undefined :: (a -> b) -> a) f))
(typeOf ((undefined :: (a -> b) -> b) f))
-------------------------------------------------------
--
-- Generate Typeable instances for standard datatypes
--
-------------------------------------------------------
INSTANCE_TYPEABLE0(Bool,boolTc,"Bool")
INSTANCE_TYPEABLE0(Char,charTc,"Char")
INSTANCE_TYPEABLE0(Float,floatTc,"Float")
INSTANCE_TYPEABLE0(Double,doubleTc,"Double")
INSTANCE_TYPEABLE0(Int,intTc,"Int")
INSTANCE_TYPEABLE0(Integer,integerTc,"Integer")
INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio")
INSTANCE_TYPEABLE2(Either,eitherTc,"Either")
INSTANCE_TYPEABLE1(IO,ioTc,"IO")
INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe")
INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering")
INSTANCE_TYPEABLE0(Handle,handleTc,"Handle")
INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr")
INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr")
INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8")
INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16")
INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32")
INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64")
INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" )
INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16")
INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32")
INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64")
INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon")
INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep")
INSTANCE_TYPEABLE1(IORef,ioRefTc,"IORef")
#endif /* GHC < 6.3 */
---------------------------------------------
--
-- Internals
--
---------------------------------------------
newtype Key = Key Int deriving( Eq )
data KeyPr = KeyPr !Key !Key deriving( Eq )
hashKP :: KeyPr -> Int32
hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime
data Cache = Cache { next_key :: !(IORef Key),
tc_tbl :: !(HT.HashTable String Key),
ap_tbl :: !(HT.HashTable KeyPr Key) }
{-# NOINLINE cache #-}
cache :: Cache
cache = unsafePerformIO $ do
empty_tc_tbl <- HT.new (==) HT.hashString
empty_ap_tbl <- HT.new (==) hashKP
key_loc <- newIORef (Key 1)
return (Cache { next_key = key_loc,
tc_tbl = empty_tc_tbl,
ap_tbl = empty_ap_tbl })
newKey :: IORef Key -> IO Key
newKey _ = do i <- genSym; return (Key i)
-- In GHC we use the RTS's genSym function to get a new unique,
-- because in GHCi we might have two copies of the Data.Typeable
-- library running (one in the compiler and one in the running
-- program), and we need to make sure they don't share any keys.
--
-- This is really a hack. A better solution would be to centralise the
-- whole mutable state used by this module, i.e. both hashtables. But
-- the current solution solves the immediate problem, which is that
-- dynamics generated in one world with one type were erroneously
-- being recognised by the other world as having a different type.
--
-- dons: SimonM says we need to unify the hashes by storing them in a
-- variable in the rts.
--
foreign import ccall unsafe "genSymZh"
genSym :: IO Int
mkTyConKey :: String -> Key
mkTyConKey str
= unsafePerformIO $ do
let Cache {next_key = kloc, tc_tbl = tbl} = cache
mb_k <- HT.lookup tbl str
case mb_k of
Just k -> return k
Nothing -> do { k <- newKey kloc ;
HT.insert tbl str k ;
return k }
appKey :: Key -> Key -> Key
appKey k1 k2
= unsafePerformIO $ do
let Cache {next_key = kloc, ap_tbl = tbl} = cache
mb_k <- HT.lookup tbl kpr
case mb_k of
Just k -> return k
Nothing -> do { k <- newKey kloc ;
HT.insert tbl kpr k ;
return k }
where
kpr = KeyPr k1 k2
appKeys :: Key -> [Key] -> Key
appKeys k ks = foldl appKey k ks

577
src/Language/Hi/Binary.hs
View File

@ -1,577 +0,0 @@
{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -fno-warn-unused-imports -fno-warn-name-shadowing #-}
{-# OPTIONS -fno-warn-unused-matches -fno-warn-unused-binds #-}
--
-- 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/utils/Binary.hs:
-- (c) The University of Glasgow 2002
--
-- Binary I/O library, with special tweaks for GHC
--
-- Based on the nhc98 Binary library, which is copyright
-- (c) Malcolm Wallace and Colin Runciman, University of York, 1998.
-- Under the terms of the license for that software, we must tell you
-- where you can obtain the original version of the Binary library, namely
-- http://www.cs.york.ac.uk/fp/nhc98/
--
-- We never have to write stuff, so I've scrubbed all the put* code.
--
module Language.Hi.Binary (
{-type-} Bin,
{-class-} Binary(..),
{-type-} BinHandle,
openBinIO, openBinIO_,
openBinMem,
-- closeBin,
seekBin,
tellBin,
castBin,
readBinMem,
isEOFBin,
-- for writing instances:
getByte,
-- lazy Bin I/O
lazyGet,
-- GHC only:
ByteArray(..),
getByteArray,
getBinFileWithDict, -- :: Binary a => FilePath -> IO a
) where
-- The *host* architecture version:
#include "MachDeps.h"
-- import Hi.Utils -- ?
import Language.Hi.FastMutInt
import Language.Hi.FastString
#if __GLASGOW_HASKELL__ < 604
import Data.FiniteMap
#else
import qualified Data.Map as M
#endif
import Data.Unique
import Data.Array.IO
import Data.Array
import Data.Bits
import Data.Int
import Data.Word
import Data.IORef
import Data.Char ( ord, chr )
import Data.Array.Base ( unsafeRead, unsafeWrite )
import Control.Monad ( when )
import System.IO
import System.IO.Unsafe ( unsafeInterleaveIO )
import System.IO.Error ( mkIOError, eofErrorType )
import GHC.Real ( Ratio(..) )
import GHC.Exts
import GHC.IOBase ( IO(..) )
import GHC.Word ( Word8(..) )
#if __GLASGOW_HASKELL__ < 601
import GHC.Handle ( openFileEx, IOModeEx(..) )
#endif
#if __GLASGOW_HASKELL__ < 601
openBinaryFile f mode = openFileEx f (BinaryMode mode)
#endif
type BinArray = IOUArray Int Word8
---------------------------------------------------------------
-- BinHandle
---------------------------------------------------------------
data BinHandle
= BinMem { -- binary data stored in an unboxed array
bh_usr :: UserData, -- sigh, need parameterized modules :-)
off_r :: !FastMutInt, -- the current offset
sz_r :: !FastMutInt, -- size of the array (cached)
arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))
}
-- XXX: should really store a "high water mark" for dumping out
-- the binary data to a file.
| BinIO { -- binary data stored in a file
bh_usr :: UserData,
off_r :: !FastMutInt, -- the current offset (cached)
hdl :: !Handle -- the file handle (must be seekable)
}
-- cache the file ptr in BinIO; using hTell is too expensive
-- to call repeatedly. If anyone else is modifying this Handle
-- at the same time, we'll be screwed.
getUserData :: BinHandle -> UserData
getUserData bh = bh_usr bh
setUserData :: BinHandle -> UserData -> BinHandle
setUserData bh us = bh { bh_usr = us }
---------------------------------------------------------------
-- Bin
---------------------------------------------------------------
newtype Bin a = BinPtr Int
deriving (Eq, Ord, Show, Bounded)
castBin :: Bin a -> Bin b
castBin (BinPtr i) = BinPtr i
---------------------------------------------------------------
-- class Binary
---------------------------------------------------------------
class Binary a where
get :: BinHandle -> IO a
getAt :: Binary a => BinHandle -> Bin a -> IO a
getAt bh p = do seekBin bh p; get bh
openBinIO_ :: Handle -> IO BinHandle
openBinIO_ h = openBinIO h
openBinIO :: Handle -> IO BinHandle
openBinIO h = do
r <- newFastMutInt
writeFastMutInt r 0
return (BinIO noUserData r h)
openBinMem :: Int -> IO BinHandle
openBinMem size
| size <= 0 = error "Hi.Binary.openBinMem: size must be >= 0"
| otherwise = do
arr <- newArray_ (0,size-1)
arr_r <- newIORef arr
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
sz_r <- newFastMutInt
writeFastMutInt sz_r size
return (BinMem noUserData ix_r sz_r arr_r)
tellBin :: BinHandle -> IO (Bin a)
tellBin (BinIO _ r _) = do ix <- readFastMutInt r; return (BinPtr ix)
tellBin (BinMem _ r _ _) = do ix <- readFastMutInt r; return (BinPtr ix)
seekBin :: BinHandle -> Bin a -> IO ()
seekBin (BinIO _ ix_r h) (BinPtr p) = do
writeFastMutInt ix_r p
hSeek h AbsoluteSeek (fromIntegral p)
seekBin h@(BinMem _ ix_r sz_r a) (BinPtr p) = do
sz <- readFastMutInt sz_r
if (p >= sz)
then do expandBin h p; writeFastMutInt ix_r p
else writeFastMutInt ix_r p
isEOFBin :: BinHandle -> IO Bool
isEOFBin (BinMem _ ix_r sz_r a) = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
return (ix >= sz)
isEOFBin (BinIO _ ix_r h) = hIsEOF h
readBinMem :: FilePath -> IO BinHandle
-- Return a BinHandle with a totally undefined State
readBinMem filename = do
h <- openBinaryFile filename ReadMode
filesize' <- hFileSize h
let filesize = fromIntegral filesize'
arr <- newArray_ (0,filesize-1)
count <- hGetArray h arr filesize
when (count /= filesize)
(error ("Hi.Binary.readBinMem: only read " ++ show count ++ " bytes"))
hClose h
arr_r <- newIORef arr
ix_r <- newFastMutInt
writeFastMutInt ix_r 0
sz_r <- newFastMutInt
writeFastMutInt sz_r filesize
return (BinMem noUserData ix_r sz_r arr_r)
-- expand the size of the array to include a specified offset
expandBin :: BinHandle -> Int -> IO ()
expandBin (BinMem _ ix_r sz_r arr_r) off = do
sz <- readFastMutInt sz_r
let sz' = head (dropWhile (<= off) (iterate (* 2) sz))
arr <- readIORef arr_r
arr' <- newArray_ (0,sz'-1)
sequence_ [ unsafeRead arr i >>= unsafeWrite arr' i
| i <- [ 0 .. sz-1 ] ]
writeFastMutInt sz_r sz'
writeIORef arr_r arr'
#ifdef DEBUG
hPutStrLn stderr ("Binary: expanding to size: " ++ show sz')
#endif
return ()
expandBin (BinIO _ _ _) _ = return ()
-- no need to expand a file, we'll assume they expand by themselves.
-- -----------------------------------------------------------------------------
-- Low-level reading/writing of bytes
getWord8 :: BinHandle -> IO Word8
getWord8 (BinMem _ ix_r sz_r arr_r) = do
ix <- readFastMutInt ix_r
sz <- readFastMutInt sz_r
when (ix >= sz) $
#if __GLASGOW_HASKELL__ <= 408
throw (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing)
#else
ioError (mkIOError eofErrorType "Hi.Binary.getWord8" Nothing Nothing)
#endif
arr <- readIORef arr_r
w <- unsafeRead arr ix
writeFastMutInt ix_r (ix+1)
return w
getWord8 (BinIO _ ix_r h) = do
ix <- readFastMutInt ix_r
c <- hGetChar h
writeFastMutInt ix_r (ix+1)
return $! (fromIntegral (ord c)) -- XXX not really correct
getByte :: BinHandle -> IO Word8
getByte = getWord8
-- -----------------------------------------------------------------------------
-- Primitve Word writes
instance Binary Word8 where
get = getWord8
instance Binary Word16 where
get h = do
w1 <- getWord8 h
w2 <- getWord8 h
return $! ((fromIntegral w1 `shiftL` 8) .|. fromIntegral w2)
instance Binary Word32 where
get h = do
w1 <- getWord8 h
w2 <- getWord8 h
w3 <- getWord8 h
w4 <- getWord8 h
return $! ((fromIntegral w1 `shiftL` 24) .|.
(fromIntegral w2 `shiftL` 16) .|.
(fromIntegral w3 `shiftL` 8) .|.
(fromIntegral w4))
instance Binary Word64 where
get h = do
w1 <- getWord8 h
w2 <- getWord8 h
w3 <- getWord8 h
w4 <- getWord8 h
w5 <- getWord8 h
w6 <- getWord8 h
w7 <- getWord8 h
w8 <- getWord8 h
return $! ((fromIntegral w1 `shiftL` 56) .|.
(fromIntegral w2 `shiftL` 48) .|.
(fromIntegral w3 `shiftL` 40) .|.
(fromIntegral w4 `shiftL` 32) .|.
(fromIntegral w5 `shiftL` 24) .|.
(fromIntegral w6 `shiftL` 16) .|.
(fromIntegral w7 `shiftL` 8) .|.
(fromIntegral w8))
-- -----------------------------------------------------------------------------
-- Primitve Int writes
instance Binary Int8 where
get h = do w <- get h; return $! (fromIntegral (w::Word8))
instance Binary Int16 where
get h = do w <- get h; return $! (fromIntegral (w::Word16))
instance Binary Int32 where
get h = do w <- get h; return $! (fromIntegral (w::Word32))
instance Binary Int64 where
get h = do w <- get h; return $! (fromIntegral (w::Word64))
-- -----------------------------------------------------------------------------
-- Instances for standard types
instance Binary () where
get _ = return ()
instance Binary Bool where
get bh = do x <- getWord8 bh; return $! (toEnum (fromIntegral x))
instance Binary Char where
get bh = do x <- get bh; return $! (chr (fromIntegral (x :: Word32)))
instance Binary Int where
#if SIZEOF_HSINT == 4
get bh = do
x <- get bh
return $! (fromIntegral (x :: Int32))
#elif SIZEOF_HSINT == 8
get bh = do
x <- get bh
return $! (fromIntegral (x :: Int64))
#else
#error "unsupported sizeof(HsInt)"
#endif
instance Binary a => Binary [a] where
#if __GLASGOW_HASKELL__ < 605
get bh = do h <- getWord8 bh
case h of
0 -> return []
_ -> do x <- get bh
xs <- get bh
return (x:xs)
#else
get bh = do
b <- getByte bh
len <- if b == 0xff
then get bh
else return (fromIntegral b :: Word32)
let loop 0 = return []
loop n = do a <- get bh; as <- loop (n-1); return (a:as)
loop len
#endif
instance (Binary a, Binary b) => Binary (a,b) where
get bh = do a <- get bh
b <- get bh
return (a,b)
instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where
get bh = do a <- get bh
b <- get bh
c <- get bh
return (a,b,c)
instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where
get bh = do a <- get bh
b <- get bh
c <- get bh
d <- get bh
return (a,b,c,d)
instance Binary a => Binary (Maybe a) where
get bh = do h <- getWord8 bh
case h of
0 -> return Nothing
_ -> do x <- get bh; return (Just x)
instance (Binary a, Binary b) => Binary (Either a b) where
get bh = do h <- getWord8 bh
case h of
0 -> do a <- get bh ; return (Left a)
_ -> do b <- get bh ; return (Right b)
#ifdef __GLASGOW_HASKELL__
instance Binary Integer where
get bh = do
b <- getByte bh
case b of
0 -> do (I# i#) <- get bh
return (S# i#)
_ -> do (I# s#) <- get bh
sz <- get bh
(BA a#) <- getByteArray bh sz
return (J# s# a#)
getByteArray :: BinHandle -> Int -> IO ByteArray
getByteArray bh (I# sz) = do
(MBA arr) <- newByteArray sz
let loop n
| n ==# sz = return ()
| otherwise = do
w <- getByte bh
writeByteArray arr n w
loop (n +# 1#)
loop 0#
freezeByteArray arr
data ByteArray = BA ByteArray#
data MBA = MBA (MutableByteArray# RealWorld)
newByteArray :: Int# -> IO MBA
newByteArray sz = IO $ \s ->
case newByteArray# sz s of { (# s, arr #) ->
(# s, MBA arr #) }
freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray
freezeByteArray arr = IO $ \s ->
case unsafeFreezeByteArray# arr s of { (# s, arr #) ->
(# s, BA arr #) }
#if __GLASGOW_HASKELL__ < 503
writeByteArray arr i w8 = IO $ \s ->
case word8ToWord w8 of { W# w# ->
case writeCharArray# arr i (chr# (word2Int# w#)) s of { s ->
(# s , () #) }}
#else
writeByteArray arr i (W8# w) = IO $ \s ->
case writeWord8Array# arr i w s of { s ->
(# s, () #) }
#endif
#if __GLASGOW_HASKELL__ < 503
indexByteArray a# n# = fromIntegral (I# (ord# (indexCharArray# a# n#)))
#else
indexByteArray a# n# = W8# (indexWord8Array# a# n#)
#endif
instance (Integral a, Binary a) => Binary (Ratio a) where
get bh = do a <- get bh; b <- get bh; return (a :% b)
#endif
instance Binary (Bin a) where
get bh = do i <- get bh; return (BinPtr i)
-- -----------------------------------------------------------------------------
-- Lazy reading/writing
lazyGet :: Binary a => BinHandle -> IO a
lazyGet bh = do
p <- get bh -- a BinPtr
p_a <- tellBin bh
a <- unsafeInterleaveIO (getAt bh p_a)
seekBin bh p -- skip over the object for now
return a
-- --------------------------------------------------------------
-- Main wrappers: getBinFileWithDict, putBinFileWithDict
--
-- This layer is built on top of the stuff above,
-- and should not know anything about BinHandles
-- --------------------------------------------------------------
initBinMemSize = (1024*1024) :: Int
binaryInterfaceMagic = 0x1face :: Word32
getBinFileWithDict :: Binary a => FilePath -> IO a
getBinFileWithDict file_path = do
bh <- Language.Hi.Binary.readBinMem file_path
-- Read the magic number to check that this really is a GHC .hi file
-- (This magic number does not change when we change
-- GHC interface file format)
magic <- get bh
when (magic /= binaryInterfaceMagic) $
error "magic number mismatch: old/corrupt interface file?"
-- Read the dictionary
-- The next word in the file is a pointer to where the dictionary is
-- (probably at the end of the file)
dict_p <- Language.Hi.Binary.get bh -- Get the dictionary ptr
data_p <- tellBin bh -- Remember where we are now
seekBin bh dict_p
dict <- getDictionary bh
seekBin bh data_p -- Back to where we were before
-- Initialise the user-data field of bh
let bh' = setUserData bh (initReadState dict)
-- At last, get the thing
get bh'
-- -----------------------------------------------------------------------------
-- UserData
-- -----------------------------------------------------------------------------
data UserData =
UserData { -- This field is used only when reading
ud_dict :: Dictionary,
-- The next two fields are only used when writing
ud_next :: IORef Int, -- The next index to use
#if __GLASGOW_HASKELL__ < 604
ud_map :: IORef (FiniteMap Unique (Int,FastString))
#else
ud_map :: IORef (M.Map Unique (Int,FastString))
#endif
}
noUserData = error "Hi.Binary.UserData: no user data"
initReadState :: Dictionary -> UserData
initReadState dict = UserData{ ud_dict = dict,
ud_next = undef "next",
ud_map = undef "map" }
newWriteState :: IO UserData
newWriteState = do
j_r <- newIORef 0
#if __GLASGOW_HASKELL__ < 604
out_r <- newIORef emptyFM
#else
out_r <- newIORef M.empty
#endif
return (UserData { ud_dict = error "dict",
ud_next = j_r,
ud_map = out_r })
undef s = error ("Hi.Binary.UserData: no " ++ s)
---------------------------------------------------------
-- The Dictionary
---------------------------------------------------------
type Dictionary = Array Int FastString -- The dictionary
-- Should be 0-indexed
getDictionary :: BinHandle -> IO Dictionary
getDictionary bh = do
sz <- get bh
elems <- sequence (take sz (repeat (getFS bh)))
return (listArray (0,sz-1) elems)
#if __GLASGOW_HASKELL__ < 604
constructDictionary :: Int -> FiniteMap Unique (Int,FastString) -> Dictionary
constructDictionary j fm = array (0,j-1) (eltsFM fm)
#else
constructDictionary :: Int -> M.Map Unique (Int,FastString) -> Dictionary
constructDictionary j fm = array (0,j-1) (M.elems fm)
#endif
---------------------------------------------------------
-- Reading and writing FastStrings
---------------------------------------------------------
getFS bh = do
(I# l) <- get bh
(BA ba) <- getByteArray bh (I# l)
return $! (mkFastSubStringBA# ba 0# l)
instance Binary FastString where
get bh = do j <- get bh -- Int
return $! (ud_dict (getUserData bh) ! j)

81
src/Language/Hi/FastMutInt.hs
View File

@ -1,81 +0,0 @@
{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -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 code from $fptools/ghc/compiler/utils/FastMutInt.lhs
--
-- (c) Copyright 2002, The University Court of the University of Glasgow.
--
-- Unboxed mutable Ints
--
module Language.Hi.FastMutInt (
FastMutInt,
newFastMutInt,
readFastMutInt,
writeFastMutInt,
incFastMutInt,
incFastMutIntBy
) where
#include "MachDeps.h"
#if __GLASGOW_HASKELL__ < 503
import GlaExts
import PrelIOBase
#else
import GHC.Base
import GHC.IOBase
#endif
#if __GLASGOW_HASKELL__ < 411
newByteArray# = newCharArray#
#endif
data FastMutInt = FastMutInt (MutableByteArray# RealWorld)
newFastMutInt :: IO FastMutInt
newFastMutInt = IO $ \s ->
case newByteArray# size s of { (# s, arr #) ->
(# s, FastMutInt arr #) }
where I# size = SIZEOF_HSINT
readFastMutInt :: FastMutInt -> IO Int
readFastMutInt (FastMutInt arr) = IO $ \s ->
case readIntArray# arr 0# s of { (# s, i #) ->
(# s, I# i #) }
writeFastMutInt :: FastMutInt -> Int -> IO ()
writeFastMutInt (FastMutInt arr) (I# i) = IO $ \s ->
case writeIntArray# arr 0# i s of { s ->
(# s, () #) }
incFastMutInt :: FastMutInt -> IO Int -- Returns original value
incFastMutInt (FastMutInt arr) = IO $ \s ->
case readIntArray# arr 0# s of { (# s, i #) ->
case writeIntArray# arr 0# (i +# 1#) s of { s ->
(# s, I# i #) } }
incFastMutIntBy :: FastMutInt -> Int -> IO Int -- Returns original value
incFastMutIntBy (FastMutInt arr) (I# n) = IO $ \s ->
case readIntArray# arr 0# s of { (# s, i #) ->
case writeIntArray# arr 0# (i +# n) s of { s ->
(# s, I# i #) } }

508
src/Language/Hi/FastString.hs
View File

@ -1,508 +0,0 @@
{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-}
{-# OPTIONS -#include "hschooks.h" #-}
--
-- 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/utils/FastString.lhs
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
--
-- Fast strings
--
-- Compact representations of character strings with
-- unique identifiers (hash-cons'ish).
--
module Language.Hi.FastString
(
FastString(..), -- not abstract, for now.
mkFastString, -- :: String -> FastString
mkFastStringNarrow, -- :: String -> FastString
mkFastSubString, -- :: Addr -> Int -> Int -> FastString
mkFastString#, -- :: Addr# -> FastString
mkFastSubStringBA#, -- :: ByteArray# -> Int# -> Int# -> FastString
mkFastStringInt, -- :: [Int] -> FastString
uniqueOfFS, -- :: FastString -> Int#
lengthFS, -- :: FastString -> Int
nullFastString, -- :: FastString -> Bool
unpackFS, -- :: FastString -> String
unpackIntFS, -- :: FastString -> [Int]
appendFS, -- :: FastString -> FastString -> FastString
headFS, -- :: FastString -> Char
headIntFS, -- :: FastString -> Int
tailFS, -- :: FastString -> FastString
concatFS, -- :: [FastString] -> FastString
consFS, -- :: Char -> FastString -> FastString
indexFS, -- :: FastString -> Int -> Char
nilFS, -- :: FastString
hPutFS, -- :: Handle -> FastString -> IO ()
LitString,
mkLitString# -- :: Addr# -> LitString
) where
import Language.Hi.PrimPacked
import System.IO
import Data.Char ( chr, ord )
import GHC.Exts
import GHC.IOBase
import GHC.Arr ( STArray(..), newSTArray )
import GHC.Handle
import Foreign.C
-- import System.IO.Unsafe ( unsafePerformIO )
-- import Control.Monad.ST ( stToIO )
-- import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
#define hASH_TBL_SIZE 993
{-
@FastString@s are packed representations of strings
with a unique id for fast comparisons. The unique id
is assigned when creating the @FastString@, using
a hash table to map from the character string representation
to the unique ID.
-}
data FastString
= FastString -- packed repr. on the heap.
Int# -- unique id
-- 0 => string literal, comparison
-- will
Int# -- length
ByteArray# -- stuff
| UnicodeStr -- if contains characters outside '\1'..'\xFF'
Int# -- unique id
[Int] -- character numbers
instance Eq FastString where
-- shortcut for real FastStrings
(FastString u1 _ _) == (FastString u2 _ _) = u1 ==# u2
a == b = case cmpFS a b of { LT -> False; EQ -> True; GT -> False }
(FastString u1 _ _) /= (FastString u2 _ _) = u1 /=# u2
a /= b = case cmpFS a b of { LT -> True; EQ -> False; GT -> True }
instance Ord FastString where
-- Compares lexicographically, not by unique
a <= b = case cmpFS a b of { LT -> True; EQ -> True; GT -> False }
a < b = case cmpFS a b of { LT -> True; EQ -> False; GT -> False }
a >= b = case cmpFS a b of { LT -> False; EQ -> True; GT -> True }
a > b = case cmpFS a b of { LT -> False; EQ -> False; GT -> True }
max x y | x >= y = x
| otherwise = y
min x y | x <= y = x
| otherwise = y
compare a b = cmpFS a b
lengthFS :: FastString -> Int
lengthFS (FastString _ l# _) = I# l#
lengthFS (UnicodeStr _ s) = length s
nullFastString :: FastString -> Bool
nullFastString (FastString _ l# _) = l# ==# 0#
nullFastString (UnicodeStr _ []) = True
nullFastString (UnicodeStr _ (_:_)) = False
unpackFS :: FastString -> String
unpackFS (FastString _ l# ba#) = unpackNBytesBA (BA ba#) (I# l#)
unpackFS (UnicodeStr _ s) = map chr s
unpackIntFS :: FastString -> [Int]
unpackIntFS (UnicodeStr _ s) = s
unpackIntFS fs = map ord (unpackFS fs)
appendFS :: FastString -> FastString -> FastString
appendFS fs1 fs2 = mkFastStringInt (unpackIntFS fs1 ++ unpackIntFS fs2)
concatFS :: [FastString] -> FastString
concatFS ls = mkFastStringInt (concat (map unpackIntFS ls)) -- ToDo: do better
headFS :: FastString -> Char
headFS (FastString _ l# ba#) =
if l# ># 0# then C# (indexCharArray# ba# 0#) else error ("headFS: empty FS")
headFS (UnicodeStr _ (c:_)) = chr c
headFS (UnicodeStr _ []) = error ("headFS: empty FS")
headIntFS :: FastString -> Int
headIntFS (UnicodeStr _ (c:_)) = c
headIntFS fs = ord (headFS fs)
indexFS :: FastString -> Int -> Char
indexFS f i@(I# i#) =
case f of
FastString _ l# ba#
| l# ># 0# && l# ># i# -> C# (indexCharArray# ba# i#)
| otherwise -> error (msg (I# l#))
UnicodeStr _ s -> chr (s!!i)
where
msg l = "indexFS: out of range: " ++ show (l,i)
tailFS :: FastString -> FastString
tailFS (FastString _ l# ba#) = mkFastSubStringBA# ba# 1# (l# -# 1#)
tailFS fs = mkFastStringInt (tail (unpackIntFS fs))
consFS :: Char -> FastString -> FastString
consFS c fs = mkFastStringInt (ord c : unpackIntFS fs)
uniqueOfFS :: FastString -> Int#
uniqueOfFS (FastString u# _ _) = u#
uniqueOfFS (UnicodeStr u# _) = u#
nilFS = mkFastString ""
{-
GHC-related stuff:
Internally, the compiler will maintain a fast string symbol
table, providing sharing and fast comparison. Creation of
new @FastString@s then covertly does a lookup, re-using the
@FastString@ if there was a hit.
Caution: mkFastStringUnicode assumes that if the string is in the
table, it sits under the UnicodeStr constructor. Other mkFastString
variants analogously assume the FastString constructor.
-}
data FastStringTable =
FastStringTable
Int#
(MutableArray# RealWorld [FastString])
type FastStringTableVar = IORef FastStringTable
string_table :: FastStringTableVar
string_table =
unsafePerformIO (
stToIO (newSTArray (0::Int,hASH_TBL_SIZE) [])
>>= \ (STArray _ _ arr#) ->
newIORef (FastStringTable 0# arr#))
lookupTbl :: FastStringTable -> Int# -> IO [FastString]
lookupTbl (FastStringTable _ arr#) i# =
IO ( \ s# ->
readArray# arr# i# s#)
updTbl :: FastStringTableVar -> FastStringTable -> Int# -> [FastString] -> IO ()
updTbl fs_table_var (FastStringTable uid# arr#) i# ls =
IO (\ s# -> case writeArray# arr# i# ls s# of { s2# ->
(# s2#, () #) }) >>
writeIORef fs_table_var (FastStringTable (uid# +# 1#) arr#)
mkFastString# :: Addr# -> FastString
mkFastString# a# =
case strLength (Ptr a#) of { (I# len#) -> mkFastStringLen# a# len# }
mkFastStringLen# :: Addr# -> Int# -> FastString
mkFastStringLen# a# len# =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashStr a# len#
in
-- _trace ("hashed: "++show (I# h)) $
lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket" $
case copyPrefixStr a# (I# len#) of
BA barr# ->
let f_str = FastString uid# len# barr# in
updTbl string_table ft h [f_str] >>
({- _trace ("new: " ++ show f_str) $ -} return f_str)
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
-- _trace ("non-empty bucket"++show ls) $
case bucket_match ls len# a# of
Nothing ->
case copyPrefixStr a# (I# len#) of
BA barr# ->
let f_str = FastString uid# len# barr# in
updTbl string_table ft h (f_str:ls) >>
( {- _trace ("new: " ++ show f_str) $ -} return f_str)
Just v -> {- _trace ("re-use: "++show v) $ -} return v)
where
bucket_match [] _ _ = Nothing
bucket_match (v@(FastString _ l# ba#):ls) len# a# =
if len# ==# l# && eqStrPrefix a# ba# l# then
Just v
else
bucket_match ls len# a#
bucket_match (UnicodeStr _ _ : ls) len# a# =
bucket_match ls len# a#
mkFastSubStringBA# :: ByteArray# -> Int# -> Int# -> FastString
mkFastSubStringBA# barr# start# len# =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashSubStrBA barr# start# len#
in
-- _trace ("hashed(b): "++show (I# h)) $
lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a ByteArray
-- _trace "empty bucket(b)" $
case copySubStrBA (BA barr#) (I# start#) (I# len#) of
BA ba# ->
let f_str = FastString uid# len# ba# in
updTbl string_table ft h [f_str] >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls start# len# barr# of
Nothing ->
case copySubStrBA (BA barr#) (I# start#) (I# len#) of
BA ba# ->
let f_str = FastString uid# len# ba# in
updTbl string_table ft h (f_str:ls) >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
Just v ->
-- _trace ("re-use(b): "++show v) $
return v
)
where
bucket_match [] _ _ _ = Nothing
bucket_match (v:ls) start# len# ba# =
case v of
FastString _ l# barr# ->
if len# ==# l# && eqStrPrefixBA barr# ba# start# len# then
Just v
else
bucket_match ls start# len# ba#
UnicodeStr _ _ -> bucket_match ls start# len# ba#
mkFastStringUnicode :: [Int] -> FastString
mkFastStringUnicode s =
unsafePerformIO (
readIORef string_table >>= \ ft@(FastStringTable uid# tbl#) ->
let
h = hashUnicode s
in
-- _trace ("hashed(b): "++show (I# h)) $
lookupTbl ft h >>= \ lookup_result ->
case lookup_result of
[] ->
-- no match, add it to table by copying out the
-- the string into a [Int]
let f_str = UnicodeStr uid# s in
updTbl string_table ft h [f_str] >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
ls ->
-- non-empty `bucket', scan the list looking
-- entry with same length and compare byte by byte.
-- _trace ("non-empty bucket(b)"++show ls) $
case bucket_match ls of
Nothing ->
let f_str = UnicodeStr uid# s in
updTbl string_table ft h (f_str:ls) >>
-- _trace ("new(b): " ++ show f_str) $
return f_str
Just v ->
-- _trace ("re-use(b): "++show v) $
return v
)
where
bucket_match [] = Nothing
bucket_match (v@(UnicodeStr _ s'):ls) =
if s' == s then Just v else bucket_match ls
bucket_match (FastString _ _ _ : ls) = bucket_match ls
mkFastStringNarrow :: String -> FastString
mkFastStringNarrow str =
case packString str of { (I# len#, BA frozen#) ->
mkFastSubStringBA# frozen# 0# len#
}
{- 0-indexed array, len# == index to one beyond end of string,
i.e., (0,1) => empty string. -}
mkFastString :: String -> FastString
mkFastString str = if all good str
then mkFastStringNarrow str
else mkFastStringUnicode (map ord str)
where
good c = c >= '\1' && c <= '\xFF'
mkFastStringInt :: [Int] -> FastString
mkFastStringInt str = if all good str
then mkFastStringNarrow (map chr str)
else mkFastStringUnicode str
where
good c = c >= 1 && c <= 0xFF
mkFastSubString :: Addr# -> Int -> Int -> FastString
mkFastSubString a# (I# start#) (I# len#) =
mkFastStringLen# (a# `plusAddr#` start#) len#
hashStr :: Addr# -> Int# -> Int#
-- use the Addr to produce a hash value between 0 & m (inclusive)
hashStr a# len# =
case len# of
0# -> 0#
1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
_ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
where
c0 = indexCharOffAddr# a# 0#
c1 = indexCharOffAddr# a# (len# `quotInt#` 2# -# 1#)
c2 = indexCharOffAddr# a# (len# -# 1#)
{-
c1 = indexCharOffAddr# a# 1#
c2 = indexCharOffAddr# a# 2#
-}
hashSubStrBA :: ByteArray# -> Int# -> Int# -> Int#
-- use the byte array to produce a hash value between 0 & m (inclusive)
hashSubStrBA ba# start# len# =
case len# of
0# -> 0#
1# -> ((ord# c0 *# 631#) +# len#) `remInt#` hASH_TBL_SIZE#
2# -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# len#) `remInt#` hASH_TBL_SIZE#
_ -> ((ord# c0 *# 631#) +# (ord# c1 *# 217#) +# (ord# c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
where
c0 = indexCharArray# ba# (start# +# 0#)
c1 = indexCharArray# ba# (start# +# (len# `quotInt#` 2# -# 1#))
c2 = indexCharArray# ba# (start# +# (len# -# 1#))
-- c1 = indexCharArray# ba# 1#
-- c2 = indexCharArray# ba# 2#
hashUnicode :: [Int] -> Int#
-- use the Addr to produce a hash value between 0 & m (inclusive)
hashUnicode [] = 0#
hashUnicode [I# c0] = ((c0 *# 631#) +# 1#) `remInt#` hASH_TBL_SIZE#
hashUnicode [I# c0, I# c1] = ((c0 *# 631#) +# (c1 *# 217#) +# 2#) `remInt#` hASH_TBL_SIZE#
hashUnicode s = ((c0 *# 631#) +# (c1 *# 217#) +# (c2 *# 43#) +# len#) `remInt#` hASH_TBL_SIZE#
where
I# len# = length s
I# c0 = s !! 0
I# c1 = s !! (I# (len# `quotInt#` 2# -# 1#))
I# c2 = s !! (I# (len# -# 1#))
cmpFS :: FastString -> FastString -> Ordering
cmpFS (UnicodeStr u1# s1) (UnicodeStr u2# s2) = if u1# ==# u2# then EQ
else compare s1 s2
cmpFS (UnicodeStr _ s1) s2 = compare s1 (unpackIntFS s2)
cmpFS s1 (UnicodeStr _ s2) = compare (unpackIntFS s1) s2
cmpFS (FastString u1# l1# b1#) (FastString u2# l2# b2#) =
if u1# ==# u2# then EQ else
let l# = if l1# <=# l2# then l1# else l2# in
unsafePerformIO (
memcmp b1# b2# l# >>= \ (I# res) ->
return (
if res <# 0# then LT
else if res ==# 0# then
if l1# ==# l2# then EQ
else if l1# <# l2# then LT else GT
else GT
))
foreign import ccall unsafe "memcmp"
memcmp :: ByteArray# -> ByteArray# -> Int# -> IO Int
-- -----------------------------------------------------------------------------
-- Outputting 'FastString's
#if __GLASGOW_HASKELL__ >= 504
-- this is our own version of hPutBuf for FastStrings, because in
-- 5.04+ we don't have mutable byte arrays and therefore hPutBufBA.
-- The closest is hPutArray in Data.Array.IO, but that does some extra
-- range checks that we want to avoid here.
foreign import ccall unsafe "__hscore_memcpy_dst_off"
memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
hPutFS handle (FastString _ l# ba#)
| l# ==# 0# = return ()
| otherwise
= do wantWritableHandle "hPutFS" handle $
\ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=stream } -> do
old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
<- readIORef ref
let count = I# l#
raw = unsafeCoerce# ba# :: MutableByteArray# RealWorld
-- enough room in handle buffer?
if (size - w > count)
-- There's enough room in the buffer:
-- just copy the data in and update bufWPtr.
then do memcpy_baoff_ba old_raw w raw (fromIntegral count)
writeIORef ref old_buf{ bufWPtr = w + count }
return ()
-- else, we have to flush
else do flushed_buf <- flushWriteBuffer fd stream old_buf
writeIORef ref flushed_buf
let this_buf =
Buffer{ bufBuf=raw, bufState=WriteBuffer,
bufRPtr=0, bufWPtr=count, bufSize=count }
flushWriteBuffer fd stream this_buf
return ()
#else
hPutFS :: Handle -> FastString -> IO ()
hPutFS handle (FastString _ l# ba#)
| l# ==# 0# = return ()
| otherwise = do mba <- stToIO $ unsafeThawByteArray (ByteArray (bot::Int) bot ba#)
hPutBufBAFull handle mba (I# l#)
where
bot = error "hPutFS.ba"
#endif
-- ONLY here for debugging the NCG (so -ddump-stix works for string
-- literals); no idea if this is really necessary. JRS, 010131
hPutFS handle (UnicodeStr _ is)
= hPutStr handle ("(UnicodeStr " ++ show is ++ ")")
-- -----------------------------------------------------------------------------
-- LitStrings, here for convenience only.
type LitString = Ptr ()
-- ToDo: make it a Ptr when we don't have to support 4.08 any more
mkLitString# :: Addr# -> LitString
mkLitString# a# = Ptr a#

720
src/Language/Hi/Parser.hs
View File

@ -1,720 +0,0 @@
{-# 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
-}

194
src/Language/Hi/PrimPacked.hs
View File

@ -1,194 +0,0 @@
{-# OPTIONS -cpp -fglasgow-exts #-}
{-# OPTIONS -fno-warn-name-shadowing -fno-warn-unused-matches #-}
{-# OPTIONS -#include "hschooks.h" #-}
--
-- 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/utils/PrimPacked.lhs
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1997-1998
--
--
-- Basic ops on packed representations
--
-- Some basic operations for working on packed representations of series
-- of bytes (character strings). Used by the interface lexer input
-- subsystem, mostly.
{-# OPTIONS -optc-DNON_POSIX_SOURCE #-}
module Language.Hi.PrimPacked (
Ptr(..), nullPtr, plusAddr#,
BA(..),
packString, -- :: String -> (Int, BA)
unpackNBytesBA, -- :: BA -> Int -> [Char]
strLength, -- :: Ptr CChar -> Int
copyPrefixStr, -- :: Addr# -> Int -> BA
copySubStrBA, -- :: BA -> Int -> Int -> BA
eqStrPrefix, -- :: Addr# -> ByteArray# -> Int# -> Bool
eqStrPrefixBA, -- :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
) where
import Foreign
import GHC.Exts
import GHC.ST
-- Wrapper types for bytearrays
data BA = BA ByteArray#
data MBA s = MBA (MutableByteArray# s)
packString :: String -> (Int, BA)
packString str = (l, arr)
where
l@(I# length#) = length str
arr = runST (do
ch_array <- new_ps_array length#
-- fill in packed string from "str"
fill_in ch_array 0# str
-- freeze the puppy:
freeze_ps_array ch_array length#
)
fill_in :: MBA s -> Int# -> [Char] -> ST s ()
fill_in arr_in# idx [] =
return ()
fill_in arr_in# idx (C# c : cs) =
write_ps_array arr_in# idx c >>
fill_in arr_in# (idx +# 1#) cs
-- Unpacking a string
unpackNBytesBA :: BA -> Int -> [Char]
unpackNBytesBA (BA bytes) (I# len)
= unpack 0#
where
unpack nh
| nh >=# len = []
| otherwise = C# ch : unpack (nh +# 1#)
where
ch = indexCharArray# bytes nh
-- Copying a char string prefix into a byte array.
copyPrefixStr :: Addr# -> Int -> BA
copyPrefixStr a# len@(I# length#) = copy' length#
where
copy' length# = runST (do
{- allocate an array that will hold the string
-}
ch_array <- new_ps_array length#
{- Revert back to Haskell-only solution for the moment.
_ccall_ memcpy ch_array (A# a) len >>= \ () ->
write_ps_array ch_array length# (chr# 0#) >>
-}
-- fill in packed string from "addr"
fill_in ch_array 0#
-- freeze the puppy:
freeze_ps_array ch_array length#
)
fill_in :: MBA s -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
= return ()
| otherwise
= case (indexCharOffAddr# a# idx) of { ch ->
write_ps_array arr_in# idx ch >>
fill_in arr_in# (idx +# 1#) }
-- Copying out a substring, assume a 0-indexed string:
-- (and positive lengths, thank you).
copySubStrBA :: BA -> Int -> Int -> BA
copySubStrBA (BA barr#) (I# start#) len@(I# length#) = ba
where
ba = runST (do
-- allocate an array that will hold the string
ch_array <- new_ps_array length#
-- fill in packed string from "addr"
fill_in ch_array 0#
-- freeze the puppy:
freeze_ps_array ch_array length#
)
fill_in :: MBA s -> Int# -> ST s ()
fill_in arr_in# idx
| idx ==# length#
= return ()
| otherwise
= case (indexCharArray# barr# (start# +# idx)) of { ch ->
write_ps_array arr_in# idx ch >>
fill_in arr_in# (idx +# 1#) }
-- (Very :-) ``Specialised'' versions of some CharArray things...
-- [Copied from PackBase; no real reason -- UGH]
new_ps_array :: Int# -> ST s (MBA s)
write_ps_array :: MBA s -> Int# -> Char# -> ST s ()
freeze_ps_array :: MBA s -> Int# -> ST s BA
#if __GLASGOW_HASKELL__ < 411
#define NEW_BYTE_ARRAY newCharArray#
#else
#define NEW_BYTE_ARRAY newByteArray#
#endif
new_ps_array size = ST $ \ s ->
case (NEW_BYTE_ARRAY size s) of { (# s2#, barr# #) ->
(# s2#, MBA barr# #) }
write_ps_array (MBA barr#) n ch = ST $ \ s# ->
case writeCharArray# barr# n ch s# of { s2# ->
(# s2#, () #) }
-- same as unsafeFreezeByteArray
freeze_ps_array (MBA arr#) len# = ST $ \ s# ->
case unsafeFreezeByteArray# arr# s# of { (# s2#, frozen# #) ->
(# s2#, BA frozen# #) }
-- Compare two equal-length strings for equality:
eqStrPrefix :: Addr# -> ByteArray# -> Int# -> Bool
eqStrPrefix a# barr# len# =
unsafePerformIO $ do
x <- memcmp_ba a# barr# (I# len#)
return (x == 0)
eqStrPrefixBA :: ByteArray# -> ByteArray# -> Int# -> Int# -> Bool
eqStrPrefixBA b1# b2# start# len# =
unsafePerformIO $ do
x <- memcmp_baoff_ba b2# (I# start#) b1# (I# len#)
return (x == 0)
------------------------------------------------------------------------
-- in hschooks
--
foreign import ccall unsafe "plugin_strlen"
strLength :: Ptr () -> Int
foreign import ccall unsafe "plugin_memcmp"
memcmp_ba :: Addr# -> ByteArray# -> Int -> IO Int
foreign import ccall unsafe "plugin_memcmp_off"
memcmp_baoff_ba :: ByteArray# -> Int -> ByteArray# -> Int -> IO Int

360
src/Language/Hi/Syntax.hs
View File

@ -1,360 +0,0 @@
--
-- 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 code from $fptools/ghc/compiler/main/HscTypes.lhs
-- (c) The University of Glasgow 2002
--
module Language.Hi.Syntax where
import Language.Hi.FastString
import Data.List ( intersperse )
-- ---------------------------------------------------------------------
-- An Iface, the representation of an .hi file.
--
-- The abstract syntax that we don't need is blanked with a default
-- type, however we must be careful in BinIface to still parse the
-- correct number of bytes for each data type. This involves leaving the
-- code alone, other than to add the types of the sub-constructors of
-- the types we have blanked out (because they can't be inferred
-- anymore).
--
data Iface = Iface {
mi_package :: String, -- what package is this?
mi_module :: String, -- what module is this?
mi_deps :: Dependencies,
mi_usages :: [Usage],
mi_exports :: [IfaceExport] {-,-}
-- mi_decls :: [(Version,IfaceDecl)] {-,-}
-- mi_mod_vers :: !Version,
-- mi_orphan :: !Bool,
-- mi_boot :: !Bool,
-- mi_exp_vers :: !Version,
-- mi_fixities :: [(OccName,Fixity)],
-- mi_deprecs :: [IfaceDeprec],
-- mi_insts :: [IfaceInst],
-- mi_rules :: [IfaceRule],
-- mi_rule_vers :: !Version,
}
emptyIface = Iface {
mi_package = undefined,
mi_module = undefined,
mi_deps = noDependencies,
mi_usages = undefined,
mi_exports = undefined
}
-- ---------------------------------------------------------------------
-- pretty-print an interface
--
showIface :: Iface -> String
showIface (Iface { mi_package = p, mi_module = m,
mi_deps = deps, mi_usages = us }) =
"interface \"" ++ p ++ "\" " ++ m ++
"\n" ++ pprDeps deps ++
"\n" ++ (concat $ intersperse "\n" (map pprUsage us))
-- "\n" ++ (concat $ intersperse "\n" (map pprExport es))
pprDeps :: Dependencies -> String
pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs })
= "module dependencies: " ++ (concat $ intersperse ", " mods) ++
"\npackage dependencies: " ++ (concat $ intersperse ", " pkgs)
pprUsage :: Usage -> String
pprUsage usage = hsep ["import", usg_name usage]
pprExport :: IfaceExport -> String
pprExport (fsmod, items)
= hsep [ "export", unpackFS fsmod, hsep (map pp_avail items) ]
where
pp_avail :: GenAvailInfo OccName -> String
pp_avail (Avail nm) = ppr_occ nm
pp_avail (AvailTC _ []) = empty
pp_avail (AvailTC n (n':ns))
| n==n' = (ppr_occ n) ++ pp_export ns
| otherwise = (ppr_occ n) ++ "|" ++ pp_export (n':ns)
pp_export [] = empty
pp_export names = "{" ++ (hsep (map ppr_occ names)) ++ "}"
ppr_occ (OccName _ s) = s
--
-- TODO bring in the Pretty library
--
hsep = \ss -> concat (intersperse " " ss)
empty = ""
-- ---------------------------------------------------------------------
--
-- Dependency info about modules and packages below this one
-- in the import hierarchy. See TcRnTypes.ImportAvails for details.
--
-- Invariant: the dependencies of a module M never includes M
-- Invariant: the lists are unordered, with no duplicates
--
-- The fields are:
-- Home-package module dependencies
-- External package dependencies
-- Orphan modules (whether home or external pkg)
data Dependencies = Deps {
dep_mods :: [ModuleName],
dep_pkgs :: [PackageName] {-,-}
} deriving (Show)
noDependencies :: Dependencies
noDependencies = Deps [] []
--
-- Type aliases need to have a real type so the parser can work out how
-- to parse them. You have to find what these are by reading GHC.
--
type ModuleName = String {- was FastString -} -- Module
type PackageName = String {- was FastString -} -- Packages
type Version = Int -- BasicTypes
type EncodedFS = FastString -- FastString
type IfaceExport = (EncodedFS, [GenAvailInfo OccName]) -- HscTypes
data GenAvailInfo name
= Avail name -- An ordinary identifier
| AvailTC name -- The name of the type or class
[name] -- The available pieces of type/class.
-- NB: If the type or class is itself
-- to be in scope, it must be in this list.
-- Thus, typically: AvailTC Eq [Eq, ==, /=]
deriving Show
data OccName = OccName NameSpace String {- was EncodedFS -}
deriving Show
instance Eq OccName where
(OccName sp1 s1) == (OccName sp2 s2) = s1 == s2 && sp1 == sp2
data NameSpace = VarName -- variables, and "source" data constructors
| DataName -- "real" data constructors
| TvName -- tyvars
| TcClsName -- type constructors and classes
deriving (Eq, Show)
data Usage
= Usage { usg_name :: ModuleName, -- Name of the module
usg_mod :: Version, -- Module version
usg_exports :: Maybe Version, -- Export-list version, if we depend on it
usg_entities :: [(OccName,Version)],-- Sorted by occurrence name
usg_rules :: Version -- Orphan-rules version (for non-orphan
-- modules this will always be initialVersion)
} deriving Show
------------------------------------------------------------------------
-- TODO parsing type and decl information out of the .hi file
-- complex data structure...
--
{-
data IfaceExtName
= ExtPkg ModuleName OccName -- From an external package; no version #
-- Also used for wired-in things regardless
-- of whether they are home-pkg or not
| HomePkg ModuleName OccName Version -- From another module in home package;
-- has version #
| LocalTop OccName -- Top-level from the same module as
-- the enclosing IfaceDecl
| LocalTopSub -- Same as LocalTop, but for a class method or constr
OccName -- Class-meth/constr name
OccName -- Parent class/datatype name
-- LocalTopSub is written into iface files as LocalTop; the parent
-- info is only used when computing version information in MkIface
data IfaceTyCon -- Abbreviations for common tycons with known names
= IfaceTc IfaceExtName -- The common case
| IfaceIntTc | IfaceBoolTc | IfaceCharTc
| IfaceListTc | IfacePArrTc
| IfaceTupTc Boxity Arity
type Arity = Int -- BasicTypes
data Boxity
= Boxed
| Unboxed
type IfaceContext = [IfacePredType]
data IfacePredType -- NewTypes are handled as ordinary TyConApps
= IfaceClassP IfaceExtName [IfaceType]
| IfaceIParam (IPName OccName) IfaceType
data IPName name
= Dupable name -- ?x: you can freely duplicate this implicit parameter
| Linear name -- %x: you must use the splitting function to duplicate it
deriving( Eq, Ord ) -- Ord is used in the IP name cache finite map
-- (used in HscTypes.OrigIParamCache)
data IfaceType
= IfaceTyVar OccName -- Type variable only, not tycon
| IfaceAppTy IfaceType IfaceType
| IfaceForAllTy IfaceTvBndr IfaceType
| IfacePredTy IfacePredType
| IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated
-- Includes newtypes, synonyms, tuples
| IfaceFunTy IfaceType IfaceType
data IfaceBndr -- Local (non-top-level) binders
= IfaceIdBndr IfaceIdBndr
| IfaceTvBndr IfaceTvBndr
type IfaceIdBndr = (OccName, IfaceType) -- OccName, because always local
type IfaceTvBndr = (OccName, IfaceKind)
type IfaceKind = Kind -- Re-use the Kind type, but no KindVars in it
data IfaceIdInfo
= NoInfo -- When writing interface file without -O
| HasInfo [IfaceInfoItem] -- Has info, and here it is
data IfaceInfoItem
= HsArity Arity
| HsStrictness StrictSig
| HsUnfold Activation IfaceExpr
| HsNoCafRefs
| HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo
-- for why we want arity here.
-- NB: we need IfaceExtName (not just OccName) because the worker
-- can simplify to a function in another module.
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
newtype StrictSig = StrictSig DmdType
data IfaceDecl
= IfaceId { ifName :: OccName,
ifType :: IfaceType,
ifIdInfo :: IfaceIdInfo }
| IfaceData { ifCtxt :: IfaceContext, -- Context
ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifCons :: IfaceConDecls, -- Includes new/data info
ifRec :: RecFlag, -- Recursive or not?
ifVrcs :: ArgVrcs,
ifGeneric :: Bool -- True <=> generic converter functions available
} -- We need this for imported data decls, since the
-- imported modules may have been compiled with
-- different flags to the current compilation unit
| IfaceSyn { ifName :: OccName, -- Type constructor
ifTyVars :: [IfaceTvBndr], -- Type variables
ifVrcs :: ArgVrcs,
ifSynRhs :: IfaceType -- synonym expansion
}
| IfaceClass { ifCtxt :: IfaceContext, -- Context...
ifName :: OccName, -- Name of the class
ifTyVars :: [IfaceTvBndr], -- Type variables
ifFDs :: [FunDep OccName], -- Functional dependencies
ifSigs :: [IfaceClassOp], -- Method signatures
ifRec :: RecFlag, -- Is newtype/datatype associated with the class recursive?
ifVrcs :: ArgVrcs -- ... and what are its argument variances ...
}
| IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET
ifExtName :: Maybe FastString }
-}
------------------------------------------------------------------------
--
-- all this stuff may be enabled if we ever want other information out
--
{-
type ArgVrcs = [(Bool,Bool)] -- TyCon
type CLabelString = FastString -- CStrings
type CcName = EncodedFS -- CostCentre
type DeprecTxt = FastString -- BasicTypes
type FunDep a = ([a],[a]) -- Class
type IfaceAlt = (IfaceConAlt,[OccName],IfaceExpr) -- IfaceSyn
type IfaceContext = [IfacePredType] -- IfaceType
type IfaceDeprec = Deprecs [(OccName,DeprecTxt)] -- HscTypes
type IfaceIdBndr = (OccName, IfaceType) -- IfaceType
type IfaceKind = Kind -- IfaceType
type IfaceTvBndr = (OccName, IfaceKind) -- IfaceType
type RuleName = FastString -- CoreSyn
--
-- Empty definitions for the various types we need, but whose results we
-- don't care about.
--
-- 'data' types that have a parsing method associated with them
-- This list corresponds to each instance in BinIface
--
-- Try to keep this list ordered by the order they appear in BinIface
--
data Deprecs a = Deprecs
data Activation = Activation
data StrictnessMark = StrictnessMark
data Boxity = Boxity
data TupCon = TupCon
data RecFlag = RecFlag
data DefMeth = DefMeth
data FixityDirection = FixityDirection
data Fixity = Fixity
data DmdType = DmdType
data Demand = Demand
data Demands = Demands
data DmdResult = DmdResult
data StrictSig = StrictSig
data IsCafCC = IsCafCC
data IsDupdCC = IsDupdCC
data CostCentre = CostCentre
data IfaceExtName = IfaceExtName
data IfaceBndr = IfaceBndr
data Kind = Kind
data IfaceTyCon = IfaceTyCon
data IfacePredType = IfacePredType
data IfaceExpr = IfaceExpr
data IfaceConAlt = IfaceConAlt
data IfaceBinding = IfaceBinding
data IfaceIdInfo = IfaceIdInfo
data IfaceNoteItem = IfaceNoteItem
data IfaceInfoItem = IfaceInfoItem
data IfaceNote = IfaceNote
data IfaceInst = IfaceInst
data IfaceConDecls = IfaceConDecls
data IfaceConDecl = IfaceConDecl
data IfaceClassOp = IfaceClassOp
data IfaceRule = IfaceRule
data Literal = Literal
data ForeignCall = ForeignCall
data Safety = Safety
data CExportSpec = CExportSpec
data CCallSpec = CCallSpec
data CCallTarget = CCallTarget
data CCallConv = CCallConv
data DNCallSpec = DNCallSpec
data DNKind = DNKind
data DNType = DNType
-}

38
src/Language/Hi/hschooks.c
View File

@ -1,38 +0,0 @@
/*
These routines customise the error messages
for various bits of the RTS. They are linked
in instead of the defaults.
*/
#include <string.h>
/* For GHC 4.08, we are relying on the fact that RtsFlags has
* compatibile layout with the current version, because we're
* #including the current version of RtsFlags.h below. 4.08 didn't
* ship with its own RtsFlags.h, unfortunately. For later GHC
* versions, we #include the correct RtsFlags.h.
*/
#include "Rts.h"
#include "RtsFlags.h"
#include "HsFFI.h"
HsInt
plugin_strlen( HsAddr a )
{
return (strlen((char *)a));
}
HsInt
plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len )
{
return (memcmp((char *)a1, a2, len));
}
HsInt
plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len )
{
return (memcmp((char *)a1 + i, a2, len));
}

13
src/Language/Hi/hschooks.h
View File

@ -1,13 +0,0 @@
/* -----------------------------------------------------------------------------
* $ Id: hschooks.h,v 1.1.1.1 2004/05/24 09:35:39 dons Exp $
*
* Hooks into the RTS from the compiler.
*
* -------------------------------------------------------------------------- */
#include "HsFFI.h"
// Out-of-line string functions, see PrimPacked.lhs
HsInt plugin_strlen( HsAddr a );
HsInt plugin_memcmp( HsAddr a1, HsAddr a2, HsInt len );
HsInt plugin_memcmp_off( HsAddr a1, HsInt i, HsAddr a2, HsInt len );

2
src/Setup.hs
View File

@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

25
src/System/Eval.hs
View File

@ -1,25 +0,0 @@
--
-- 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
--
module System.Eval (
module System.Eval.Haskell,
) where
import System.Eval.Haskell {-all-}

259
src/System/Eval/Haskell.hs
View File

@ -1,259 +0,0 @@
{-# OPTIONS -fglasgow-exts -fffi #-}
--
-- Copyright (C) 2004-5 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
--
--
-- compile and run haskell strings at runtime.
--
module System.Eval.Haskell (
eval,
eval_,
unsafeEval,
unsafeEval_,
typeOf,
mkHsValues,
hs_eval_b, -- return a Bool
hs_eval_c, -- return a CChar
hs_eval_i, -- return a CInt
hs_eval_s, -- return a CString
module System.Eval.Utils,
) where
import System.Eval.Utils
import System.Plugins.Make
import System.Plugins.Load
import AltData.Dynamic ( Dynamic )
import AltData.Typeable ( Typeable )
import Data.Either
import Data.Map as Map
import System.IO
import System.Directory
import Foreign.C
import Foreign
--
-- ok. the idea is: the have either installed the library, in which case
-- is is registered, and the path to altdata is known to ghc, so just
-- saying "-package altdata" will work. if not, we search in the build
-- dir just in case. this should work for inplace work.
--
-- TODO could have a few extra package.conf search paths in here,
-- including PREFIX.
--
-- ---------------------------------------------------------------------
-- return a compiled value, and type check it first
--
-- TODO make this faster.
--
eval :: Typeable a => String -> [Import] -> IO (Maybe a)
eval src mods = do
pwd <- getCurrentDirectory
(cmdline,loadpath) <- getPaths
tmpf <- mkUniqueWith dynwrap src mods
status <- make tmpf cmdline
m_rsrc <- case status of
MakeSuccess _ obj -> do
m_v <- dynload obj [pwd] loadpath symbol
case m_v of LoadFailure _ -> return Nothing
LoadSuccess _ rsrc -> return $ Just rsrc
MakeFailure err -> mapM_ putStrLn err >> return Nothing
makeCleaner tmpf
return m_rsrc
-- ---------------------------------------------------------------------
-- Version of eval with all the buttons available.
eval_ :: Typeable a =>
String -- ^ code to compile
-> [Import] -- ^ any imports
-> [String] -- ^ extra make flags
-> [FilePath] -- ^ (package.confs) for load
-> [FilePath] -- ^ include paths load is to search in
-> IO (Either [String] (Maybe a)) -- ^ either errors, or maybe a well typed value
eval_ src mods args ldflags incs = do
pwd <- getCurrentDirectory
(cmdline,loadpath) <- getPaths -- find path to altdata
tmpf <- mkUniqueWith dynwrap src mods
status <- make tmpf $ ["-Onot"] ++ cmdline ++ args
m_rsrc <- case status of
MakeSuccess _ obj -> do
m_v <- dynload obj (pwd:incs) (loadpath++ldflags) symbol
return $ case m_v of LoadFailure e -> Left e
LoadSuccess _ rsrc -> Right (Just rsrc)
MakeFailure err -> return $ Left err
makeCleaner tmpf
return m_rsrc
-- ---------------------------------------------------------------------
-- unsafe because it doesn't use Dynamic types
-- useful for not having to provide type constraints to values, or when
-- you want to easily deal with polymorphic values.
--
unsafeEval :: String -> [Import] -> IO (Maybe a)
unsafeEval src mods = do
pwd <- getCurrentDirectory
tmpf <- mkUniqueWith wrap src mods
status <- make tmpf []
m_rsrc <- case status of
MakeSuccess _ obj -> do
m_v <- load obj [pwd] [] symbol
case m_v of LoadFailure _ -> return Nothing
LoadSuccess _ rsrc -> return $ Just rsrc
MakeFailure err -> mapM_ putStrLn err >> return Nothing
makeCleaner tmpf
return m_rsrc
--
-- like unsafeEval, except you can supply extra args to make and load,
-- and the error messages are returned too.
--
-- Need to be able to specify a search path to look in.
--
unsafeEval_ :: String -- ^ code to compile
-> [Import] -- ^ any imports
-> [String] -- ^ make flags
-> [FilePath] -- ^ (package.confs) for load
-> [FilePath] -- ^ include paths load is to search in
-> IO (Either [String] a)
unsafeEval_ src mods args ldflags incs = do
pwd <- getCurrentDirectory
tmpf <- mkUniqueWith wrap src mods
status <- make tmpf args
e_rsrc <- case status of
MakeSuccess _ obj -> do
m_v <- load obj (pwd:incs) ldflags symbol
case m_v of LoadFailure e -> return $ Left e
LoadSuccess _ rsrc -> return $ Right rsrc
MakeFailure err -> return $ Left err
makeCleaner tmpf
return e_rsrc
------------------------------------------------------------------------
--
-- Convenience function for use with eval (and friends). Returns a
-- string of Haskell code with the Data.Map passed as values.
--
mkHsValues :: (Show a) => Map.Map String a -> String
mkHsValues values = concat $ elems $ Map.mapWithKey convertToHs values
where convertToHs :: (Show a) => String -> a -> String
convertToHs name value = name ++ " = " ++ show value ++ "\n"
------------------------------------------------------------------------
--
-- return a compiled value's type, by using Dynamic to get a
-- representation of the inferred type.
--
typeOf :: String -> [Import] -> IO String
typeOf src mods = do
pwd <- getCurrentDirectory
(cmdline,loadpath) <- getPaths
tmpf <- mkUniqueWith dynwrap src mods
status <- make tmpf cmdline
ty <- case status of
MakeSuccess _ obj -> do
m_v <- load obj [pwd] loadpath symbol
case m_v of
LoadFailure _ -> return "<failure>"
LoadSuccess _ (v::Dynamic) -> return $ (init . tail) $ show v
MakeFailure err -> mapM_ putStrLn err >> return []
makeCleaner tmpf
return ty
--
-- note that the wrapper uses our altdata library for dynamic typing.
-- hence it needs to see the path to the altdata package. grr. is it
-- installed or not? what path does it have?
--
dynwrap :: String -> String -> [Import] -> String
dynwrap expr nm mods =
"module "++nm++ "( resource ) where\n" ++
concatMap (\m-> "import "++m++"\n") mods ++
"import AltData.Dynamic\n" ++
"resource = let { v = \n" ++
"{-# LINE 1 \"<eval>\" #-}\n" ++ expr ++ ";} in toDyn v"
-- ---------------------------------------------------------------------
-- unsafe wrapper
--
wrap :: String -> String -> [Import] -> String
wrap expr nm mods =
"module "++nm++ "( resource ) where\n" ++
concatMap (\m-> "import "++m++"\n") mods ++
"resource = let { v = \n" ++
"{-# LINE 1 \"<Plugins.Eval>\" #-}\n" ++ expr ++ ";} in v"
------------------------------------------------------------------------
--
-- And for our friends in foreign parts
--
-- TODO needs to accept char** to import list
--
--
-- return NULL pointer if an error occured.
--
foreign export ccall hs_eval_b :: CString -> IO (Ptr CInt)
foreign export ccall hs_eval_c :: CString -> IO (Ptr CChar)
foreign export ccall hs_eval_i :: CString -> IO (Ptr CInt)
foreign export ccall hs_eval_s :: CString -> IO CString
------------------------------------------------------------------------
--
-- TODO implement a marshalling for Dynamics, so that we can pass that
-- over to the C side for checking.
--
hs_eval_b :: CString -> IO (Ptr CInt)
hs_eval_b s = do m_v <- eval_cstring s
case m_v of Nothing -> return nullPtr
Just v -> new (fromBool v)
hs_eval_c :: CString -> IO (Ptr CChar)
hs_eval_c s = do m_v <- eval_cstring s
case m_v of Nothing -> return nullPtr
Just v -> new (castCharToCChar v)
-- should be Integral
hs_eval_i :: CString -> IO (Ptr CInt)
hs_eval_i s = do m_v <- eval_cstring s :: IO (Maybe Int)
case m_v of Nothing -> return nullPtr
Just v -> new (fromIntegral v :: CInt)
hs_eval_s :: CString -> IO CString
hs_eval_s s = do m_v <- eval_cstring s
case m_v of Nothing -> return nullPtr
Just v -> newCString v
--
-- convenience
--
eval_cstring :: Typeable a => CString -> IO (Maybe a)
eval_cstring cs = do s <- peekCString cs
eval s [] -- TODO use eval()

97
src/System/Eval/Utils.hs
View File

@ -1,97 +0,0 @@
{-# OPTIONS -fglasgow-exts -fffi -cpp #-}
--
-- 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
--
--
-- compile and run haskell strings at runtime.
--
module System.Eval.Utils (
Import,
symbol,
escape,
getPaths,
mkUniqueWith,
cleanup,
module Data.Maybe,
module Control.Monad,
) where
import System.Plugins.Load ( Symbol )
import System.Plugins.Utils
import System.IO
import System.Directory
import Data.Char
--
-- we export these so that eval() users have a nice time
--
import Data.Maybe
import Control.Monad
--
-- imports Foo's
--
type Import = String
--
-- distinguished symbol name
--
symbol :: Symbol
symbol = "resource"
--
-- turn a Haskell string into a printable version of the same string
--
escape s = concatMap (\c -> showLitChar c $ "") s
--
-- For Dynamic eval's, work out the compile and load command lines
--
getPaths :: IO ([String],[String])
getPaths = do
let make_line = ["-Onot","-fglasgow-exts","-package","plugins"]
return (make_line,[])
-- ---------------------------------------------------------------------
-- create the tmp file, and write source into it, using wrapper to
-- create extra .hs src.
--
mkUniqueWith :: (String -> String -> [Import] -> String)
-> String
-> [Import] -> IO FilePath
mkUniqueWith wrapper src mods = do
(tmpf,hdl) <- hMkUnique
let nm = mkModid (basename tmpf) -- used as a module name
src' = wrapper src nm mods
hPutStr hdl src' >> hFlush hdl >> hClose hdl >> return tmpf
--
-- remove all the tmp files
--
cleanup :: String -> String -> IO ()
cleanup a b = mapM_ removeFile [a, b, replaceSuffix b ".hi"]

278
src/System/MkTemp.hs
View File

@ -1,278 +0,0 @@
{-# OPTIONS -cpp -fffi -fglasgow-exts #-}
--
-- glaexts for I# ops
--
-- Copyright (c) 2004-5 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
--
--
-- A Haskell reimplementation of the C mktemp/mkstemp/mkstemps library
-- based on the algorithms in:
-- > $ OpenBSD: mktemp.c,v 1.17 2003/06/02 20:18:37 millert Exp $
-- which are available under the BSD license.
--
module System.MkTemp (
mktemp, -- :: FilePath -> IO Maybe FilePath
mkstemp, -- :: FilePath -> IO Maybe (FilePath, Handle)
mkstemps, -- :: FilePath -> Int -> IO Maybe (FilePath,Handle)
mkdtemp, -- :: FilePath -> IO Maybe FilePath
) where
import Data.List
import Data.Char ( chr, ord, isDigit )
import Control.Monad ( liftM )
import Control.Exception ( handleJust )
import System.Directory ( doesDirectoryExist, doesFileExist, createDirectory )
import System.IO
#ifndef __MINGW32__
import System.IO.Error ( isAlreadyExistsError )
#else
import System.IO.Error ( isAlreadyExistsError, isAlreadyInUseError, isPermissionError )
#endif
import GHC.IOBase ( IOException(IOError),
Exception(IOException),
IOErrorType(AlreadyExists) )
#ifndef __MINGW32__
import qualified System.Posix.Internals ( c_getpid )
#endif
#ifdef HAVE_ARC4RANDOM
import GHC.Base hiding ( ord, chr )
import GHC.Int
#else
import System.Random ( getStdRandom, Random(randomR) )
#endif
------------------------------------------------------------------------
mkstemps :: FilePath -> Int -> IO (Maybe (FilePath,Handle))
mkstemp :: FilePath -> IO (Maybe (FilePath,Handle))
mktemp :: FilePath -> IO (Maybe FilePath)
mkdtemp :: FilePath -> IO (Maybe FilePath)
mkstemps path slen = gettemp path True False slen
mkstemp path = gettemp path True False 0
mktemp path = do v <- gettemp path False False 0
return $ case v of Just (path',_) -> Just path'; _ -> Nothing
mkdtemp path = do v <- gettemp path False True 0
return $ case v of Just (path',_) -> Just path'; _ -> Nothing
------------------------------------------------------------------------
gettemp :: FilePath -> Bool -> Bool -> Int -> IO (Maybe (FilePath, Handle))
gettemp [] _ _ _ = return Nothing
gettemp _ True True _ = return Nothing
gettemp path doopen domkdir slen = do
--
-- firstly, break up the path and extract the template
--
let (pref,tmpl,suff) = let (r,s) = splitAt (length path - slen) path
(p,t) = break (== 'X') r
in (p,t,s)
--
-- an error if there is only a suffix, it seems
--
if null pref && null tmpl then return Nothing else do {
--
-- replace end of template with process id, and rest with randomness
--
;pid <- liftM show $ getProcessID
;let (rest, xs) = merge tmpl pid
;as <- randomise rest
;let tmpl' = as ++ xs
path' = pref ++ tmpl' ++ suff
--
-- just check if we can get at the directory we might need
--
;dir_ok <- if doopen || domkdir
then let d = reverse $ dropWhile (/= '/') $ reverse path'
in doesDirectoryExist d
else return True
;if not dir_ok then return Nothing else do {
--
-- We need a function for looking for appropriate temp files
--
;let fn p
| doopen = handleJust isInUse (\_ -> return Nothing) $
do h <- open0600 p ; return $ Just h
| domkdir = handleJust alreadyExists (\_ -> return Nothing) $
do mkdir0700 p ; return $ Just undefined
| otherwise = do b <- doesFileExist p
return $ if b then Nothing else Just undefined
--
-- now, try to create the tmp file, permute if we can't
-- once we've tried all permutations, give up
--
;let tryIt p t i =
do v <- fn p
case v of Just h -> return $ Just (p,h) -- it worked
Nothing -> let (i',t') = tweak i t
in if null t'
then return Nothing -- no more
else tryIt (pref++t'++suff) t' i'
;tryIt path' tmpl' 0
}}
--
-- Replace X's with pid digits. Complete rewrite
--
merge :: String -> String -> (String,String)
merge t [] = (t ,[])
merge [] _ = ([] ,[])
merge (_:ts) (p:ps) = (ts',p:ps')
where (ts',ps') = merge ts ps
--
-- And replace remaining X's with random chars
-- randomR is pretty slow, oh well.
--
randomise :: String -> IO String
randomise [] = return []
randomise ('X':xs) = do p <- getRandom ()
let c = chr $! if p < 26
then p + (ord 'A')
else (p - 26) + (ord 'a')
xs' <- randomise xs
return (c : xs')
randomise s = return s
--
-- "tricky little algorithm for backward compatibility"
-- could do with a Haskellish rewrite
--
tweak :: Int -> String -> (Int,String)
tweak i s
| i > length s - 1 = (i,[]) -- no more
| s !! i == 'Z' = if i == length s - 1
then (i,[]) -- no more
else let s' = splice (i+1) 'a'
in tweak (i+1) s' -- loop
| otherwise = let c = s !! i in case () of {_
| isDigit c -> (i, splice i 'a' )
| c == 'z' -> (i, splice i 'A' )
| otherwise -> let c' = chr $ (ord c) + 1 in (i,splice i c')
}
where
splice j c = let (a,b) = splitAt j s in a ++ [c] ++ tail b
-- ---------------------------------------------------------------------
alreadyExists :: Exception -> Maybe Exception
alreadyExists e@(IOException ioe)
| isAlreadyExistsError ioe = Just e
| otherwise = Nothing
alreadyExists _ = Nothing
isInUse :: Exception -> Maybe ()
#ifndef __MINGW32__
isInUse (IOException ioe)
| isAlreadyExistsError ioe = Just ()
| otherwise = Nothing
isInUse _ = Nothing
#else
isInUse (IOException ioe)
| isAlreadyInUseError ioe = Just ()
| isPermissionError ioe = Just ()
| isAlreadyExistsError ioe = Just () -- we throw this
| otherwise = Nothing
isInUse _ = Nothing
#endif
-- ---------------------------------------------------------------------
-- Create a file mode 0600 if possible
--
-- N.B. race condition between testing existence and opening
-- But we can live with that to avoid a posix dependency, right?
--
open0600 :: FilePath -> IO Handle
open0600 f = do
b <- doesFileExist f
if b then ioError err -- race
else openFile f ReadWriteMode
where
err = IOError Nothing AlreadyExists "open0600" "already exists" Nothing
{-
-- open(path, O_CREAT|O_EXCL|O_RDWR, 0600)
--
open0600 f = do
openFd f ReadWrite (Just o600) excl >>= fdToHandle
where
o600 = ownerReadMode `unionFileModes` ownerWriteMode
excl = defaultFileFlags { exclusive = True }
-}
--
-- create a directory mode 0700 if possible
--
mkdir0700 :: FilePath -> IO ()
mkdir0700 dir = createDirectory dir
{-
System.Posix.Directory.createDirectory dir ownerModes
-}
-- | getProcessId, stolen from GHC (main/SysTools.lhs)
--
#ifdef __MINGW32__
-- relies on Int == Int32 on Windows
foreign import ccall unsafe "_getpid" getProcessID' :: IO Int
getProcessID :: IO Int
getProcessID = liftM abs getProcessID'
#else
getProcessID :: IO Int
#ifdef CYGWIN
getProcessID = System.Posix.Internals.c_getpid >>= return . abs . fromIntegral
#else
getProcessID = System.Posix.Internals.c_getpid >>= return . fromIntegral
#endif
#endif
-- ---------------------------------------------------------------------
-- | Use a variety of random functions, if you like.
--
getRandom :: () -> IO Int
#ifndef HAVE_ARC4RANDOM
getRandom _ = getStdRandom (randomR (0,51))
#else
--
-- OpenBSD: "The arc4random() function provides a high quality 32-bit
-- pseudo-random number very quickly. arc4random() seeds itself on a
-- regular basis from the kernel strong random number subsystem
-- described in random(4)." Also, it is a bit faster than getStdRandom
--
getRandom _ = do
(I32# i) <- c_arc4random
return (I# (word2Int# ((int2Word# i `and#` int2Word# 0xffff#)
`remWord#` int2Word# 52#)))
foreign import ccall unsafe "stdlib.h arc4random" c_arc4random :: IO Int32
#endif

37
src/System/Plugins.hs
View File

@ -1,37 +0,0 @@
--
-- 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
--
module System.Plugins (
-- $Description
module System.Plugins.Make,
module System.Plugins.Load,
) where
import System.Plugins.Make {-all-}
import System.Plugins.Load {-all-}
--
-- $Description
--
-- [@NAME@] hs-plugins library : compile and load Haskell code at runtime
--

79
src/System/Plugins/Consts.hs
View File

@ -1,79 +0,0 @@
{-# OPTIONS -cpp #-}
--
-- 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
--
module System.Plugins.Consts where
#include "../../../config.h"
#if __GLASGOW_HASKELL__ >= 604
import System.Directory ( getTemporaryDirectory )
import System.IO.Unsafe ( unsafePerformIO )
#endif
-- | path to *build* dir, used by eval() for testing the examples
top = TOP
-- | what is ghc called?
ghc = WITH_GHC
-- | path to standard ghc libraries
ghcLibraryPath = GHC_LIB_PATH
-- | name of the system package.conf file
sysPkgConf = "package.conf"
-- | This code is from runtime_loader:
-- The extension used by system modules.
sysPkgSuffix = ".o"
objSuf = sysPkgSuffix
hiSuf = ".hi"
hsSuf = ".hs"
#if defined(CYGWIN) || defined(__MINGW32__)
dllSuf = ".dll"
#else
dllSuf = ".so"
#endif
-- | The prefix used by system modules. This, in conjunction with
-- 'systemModuleExtension', will result in a module filename that looks
-- like \"HSconcurrent.o\"
sysPkgPrefix = "HS"
-- | '_' on a.out, and Darwin
#if LEADING_UNDERSCORE == 1
prefixUnderscore = "_"
#else
prefixUnderscore = ""
#endif
-- | Define tmpDir to where tmp files should be created on your platform
#if __GLASGOW_HASKELL__ >= 604
tmpDir = unsafePerformIO getTemporaryDirectory
{-# NOINLINE tmpDir #-}
#else
#if !defined(__MINGW32__)
tmpDir = "/tmp"
#else
tmpDir = error "tmpDir not defined for this platform. Try setting the TMPDIR env var"
#endif
#endif

460
src/System/Plugins/Env.hs
View File

@ -1,460 +0,0 @@
{-# OPTIONS -cpp #-}
--
-- 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
--
module System.Plugins.Env (
withModEnv,
withDepEnv,
withPkgEnvs,
withMerged,
modifyModEnv,
modifyDepEnv,
modifyPkgEnv,
modifyMerged,
addModule,
rmModule,
addModules,
isLoaded,
loaded,
addModuleDeps,
getModuleDeps,
rmModuleDeps,
isMerged,
lookupMerged,
addMerge,
addPkgConf,
union,
grabDefaultPkgConf,
readPackageConf,
lookupPkg
) where
#include "../../../config.h"
import System.Plugins.LoadTypes (Module)
import System.Plugins.PackageAPI {- everything -}
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
import System.Plugins.ParsePkgConfCabal( parsePkgConf )
#else
import System.Plugins.ParsePkgConfLite ( parsePkgConf )
#endif
import System.Plugins.Consts ( ghcLibraryPath, sysPkgConf, sysPkgSuffix )
import Data.IORef ( writeIORef, readIORef, newIORef, IORef() )
import Data.Maybe ( isJust, isNothing, fromMaybe )
import Data.List ( isPrefixOf, nub )
import System.IO.Unsafe ( unsafePerformIO )
import System.Directory ( doesFileExist )
#if defined(CYGWIN) || defined(__MINGW32__)
import Prelude hiding ( catch, ioError )
import System.Environment ( getEnv )
import System.IO.Error ( catch, ioError, isDoesNotExistError )
#endif
import Control.Concurrent.MVar ( MVar(), newMVar, withMVar )
#if __GLASGOW_HASKELL__ < 604
import Data.FiniteMap
#else
import qualified Data.Map as M
--
-- and map Data.Map terms to FiniteMap terms
--
type FiniteMap k e = M.Map k e
emptyFM :: FiniteMap key elt
emptyFM = M.empty
addToFM :: (Ord key) => FiniteMap key elt -> key -> elt -> FiniteMap key elt
addToFM = \m k e -> M.insert k e m
delFromFM :: (Ord key) => FiniteMap key elt -> key -> FiniteMap key elt
delFromFM = flip M.delete
lookupFM :: (Ord key) => FiniteMap key elt -> key -> Maybe elt
lookupFM = flip M.lookup
#endif
--
-- We need to record what modules and packages we have loaded, so if we
-- read a .hi file that wants to load something already loaded, we can
-- safely ignore that request. We're in the IO monad anyway, so we can
-- add some extra state of our own.
--
-- The state is a FiniteMap String (Module,Int) (a hash of package/object names
-- to Modules and how many times they've been loaded).
--
-- It also contains the package.conf information, so that if there is a
-- package dependency we can find it correctly, even if it has a
-- non-standard path or name, and if it isn't an official package (but
-- rather one provided via -package-conf). This is stored as a
-- FiniteMap PackageName PackageConfig. The problem then is whether a
-- user's package.conf, that uses the same package name as an existing
-- GHC package, should be allowed, or should shadow a library package?
-- I don't know, but I'm inclined to have the GHC package shadow the
-- user's package.
--
-- This idea is based on *Hampus Ram's dynamic loader* dependency
-- tracking system. He uses state to record dependency trees to allow
-- clean unloading and other fun. This is quite cool. We're just using
-- state to make sure we don't load the same package twice. Implementing
-- the full dependency tree idea would be nice, though not fully
-- necessary as we have the dependency information store in .hi files,
-- unlike in hram's loader.
--
type ModEnv = FiniteMap String (Module,Int)
type DepEnv = FiniteMap Module [Module]
-- represents a package.conf file
type PkgEnv = FiniteMap PackageName PackageConfig
-- record dependencies between (src,stub) -> merged modid
type MergeEnv = FiniteMap (FilePath,FilePath) FilePath
-- multiple package.conf's kept in separate namespaces
type PkgEnvs = [PkgEnv]
type Env = (MVar (),
IORef ModEnv,
IORef DepEnv,
IORef PkgEnvs,
IORef MergeEnv)
--
-- our environment, contains a set of loaded objects, and a map of known
-- packages and their informations. Initially all we know is the default
-- package.conf information.
--
env = unsafePerformIO $ do
mvar <- newMVar ()
ref1 <- newIORef emptyFM -- loaded objects
ref2 <- newIORef emptyFM
p <- grabDefaultPkgConf
ref3 <- newIORef p -- package.conf info
ref4 <- newIORef emptyFM -- merged files
return (mvar, ref1, ref2, ref3, ref4)
{-# NOINLINE env #-}
-- -----------------------------------------------------------
--
-- apply 'f' to the loaded objects Env
-- apply 'f' to the package.conf FM
-- *locks up the MVar* so you can't recursively call a function inside a
-- with*Env function. Nice and threadsafe
--
withModEnv :: Env -> (ModEnv -> IO a) -> IO a
withDepEnv :: Env -> (DepEnv -> IO a) -> IO a
withPkgEnvs :: Env -> (PkgEnvs -> IO a) -> IO a
withMerged :: Env -> (MergeEnv -> IO a) -> IO a
withModEnv (mvar,ref,_,_,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
withDepEnv (mvar,_,ref,_,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
withPkgEnvs (mvar,_,_,ref,_) f = withMVar mvar (\_ -> readIORef ref >>= f)
withMerged (mvar,_,_,_,ref) f = withMVar mvar (\_ -> readIORef ref >>= f)
-- -----------------------------------------------------------
--
-- write an object name
-- write a new PackageConfig
--
modifyModEnv :: Env -> (ModEnv -> IO ModEnv) -> IO ()
modifyDepEnv :: Env -> (DepEnv -> IO DepEnv) -> IO ()
modifyPkgEnv :: Env -> (PkgEnvs -> IO PkgEnvs) -> IO ()
modifyMerged :: Env -> (MergeEnv -> IO MergeEnv)-> IO ()
modifyModEnv (mvar,ref,_,_,_) f = lockAndWrite mvar ref f
modifyDepEnv (mvar,_,ref,_,_) f = lockAndWrite mvar ref f
modifyPkgEnv (mvar,_,_,ref,_) f = lockAndWrite mvar ref f
modifyMerged (mvar,_,_,_,ref) f = lockAndWrite mvar ref f
-- private
lockAndWrite mvar ref f = withMVar mvar (\_->readIORef ref>>=f>>=writeIORef ref)
-- -----------------------------------------------------------
--
-- insert a loaded module name into the environment
--
addModule :: String -> Module -> IO ()
addModule s m = modifyModEnv env $ \fm -> let c = maybe 0 snd (lookupFM fm s)
in return $ addToFM fm s (m,c+1)
--getModule :: String -> IO (Maybe Module)
--getModule s = withModEnv env $ \fm -> return (lookupFM fm s)
--
-- remove a module name from the environment. Returns True if the module was actually removed.
--
rmModule :: String -> IO Bool
rmModule s = do modifyModEnv env $ \fm -> let c = maybe 1 snd (lookupFM fm s)
fm' = delFromFM fm s
in if c-1 <= 0
then return fm'
else return fm
withModEnv env $ \fm -> return (isNothing (lookupFM fm s))
--
-- insert a list of module names all in one go
--
addModules :: [(String,Module)] -> IO ()
addModules ns = mapM_ (uncurry addModule) ns
--
-- is a module/package already loaded?
--
isLoaded :: String -> IO Bool
isLoaded s = withModEnv env $ \fm -> return $ isJust (lookupFM fm s)
--
-- confusing! only for filter.
--
loaded :: String -> IO Bool
loaded m = do t <- isLoaded m ; return (not t)
-- -----------------------------------------------------------
--
-- module dependency stuff
--
--
-- set the dependencies of a Module.
--
addModuleDeps :: Module -> [Module] -> IO ()
addModuleDeps m deps = modifyDepEnv env $ \fm -> return $ addToFM fm m deps
--
-- Get module dependencies. Nothing if none have been recored.
--
getModuleDeps :: Module -> IO [Module]
getModuleDeps m = withDepEnv env $ \fm -> return $ fromMaybe [] (lookupFM fm m)
--
-- Unrecord a module from the environment.
--
rmModuleDeps :: Module -> IO ()
rmModuleDeps m = modifyDepEnv env $ \fm -> return $ delFromFM fm m
-- -----------------------------------------------------------
-- Package management stuff
--
-- insert a single package.conf (containing multiple configs)
-- means: create a new FM. insert packages into FM. add FM to end of
-- list of FM stored in the environment.
--
addPkgConf :: FilePath -> IO ()
addPkgConf f = do
ps <- readPackageConf f
modifyPkgEnv env $ \ls -> return $ union ls ps
--
-- add a new FM for the package.conf to the list of existing ones
--
union :: PkgEnvs -> [PackageConfig] -> PkgEnvs
union ls ps' =
let fm = emptyFM -- new FM for this package.conf
in ls ++ [foldr (\p fm' -> addToFM fm' (packageName p) p) fm ps']
--
-- generate a PkgEnv from the system package.conf
-- * the path to the default package.conf was determined by ./configure *
-- This imposes a constraint that you must build your plugins with the
-- same ghc you use to build hs-plugins. This is reasonable, we feel.
--
grabDefaultPkgConf :: IO PkgEnvs
grabDefaultPkgConf = do
pkgs <- readPackageConf $ ghcLibraryPath </> sysPkgConf
return $ union [] pkgs
--
-- parse a source file, expanding any $libdir we see.
--
readPackageConf :: FilePath -> IO [PackageConfig]
readPackageConf f = do
s <- readFile f
let p = parsePkgConf s
return $! map expand_libdir p
where
expand_libdir :: PackageConfig -> PackageConfig
expand_libdir pk =
let pk' = updImportDirs (\idirs -> map expand idirs) pk
pk'' = updLibraryDirs (\ldirs -> map expand ldirs) pk'
in pk''
expand :: FilePath -> FilePath
expand s | "$libdir" `isPrefixOf` s = ghcLibraryPath ++ drop 7 s
expand s = s
--
-- Package path, given a package name, look it up in the environment and
-- return the path to all the libraries needed to load this package.
--
-- What do we need to load? With the library_dirs as prefix paths:
-- * anything in the hs_libraries fields, $libdir expanded
-- * anything in the extra_libraries fields (i.e. cbits), expanded,
-- which includes system .so files.
-- * also load any dependencies now, because of that weird mtl
-- library that lang depends upon, but which doesn't show up in the
-- interfaces for some reason.
--
-- We return all the package paths that possibly exist, and the leave it
-- up to loadObject not to load the same ones twice...
--
lookupPkg :: PackageName -> IO ([FilePath],[FilePath])
lookupPkg p = do
t <- lookupPkg' p
case t of ([],(f,g)) -> return (f,g)
(ps,(f,g)) -> do gss <- mapM lookupPkg ps
let (f',g') = unzip gss
return $ (nub $ (concat f') ++ f,nub $ (concat g') ++ g)
data LibrarySpec
= DLL String -- -lLib
| DLLPath FilePath -- -Lpath
classifyLdInput :: FilePath -> IO (Maybe LibrarySpec)
classifyLdInput ('-':'l':lib) = return (Just (DLL lib))
classifyLdInput ('-':'L':path) = return (Just (DLLPath path))
classifyLdInput _ = return Nothing
-- TODO need to define a MAC/DARWIN symbol
#if defined(MACOSX)
mkSOName root = "lib" ++ root ++ ".dylib"
#elif defined(CYGWIN) || defined(__MINGW32__)
-- Win32 DLLs have no .dll extension here, because addDLL tries
-- both foo.dll and foo.drv
mkSOName root = root
#else
mkSOName root = "lib" ++ root ++ ".so"
#endif
--
-- return any stuff to load for this package, plus the list of packages
-- this package depends on. which includes stuff we have to then load
-- too.
--
lookupPkg' :: PackageName -> IO ([PackageName],([FilePath],[FilePath]))
lookupPkg' p = withPkgEnvs env $ \fms -> go fms p
where
go [] _ = return ([],([],[]))
go (fm:fms) q = case lookupFM fm q of
Nothing -> go fms q -- look in other pkgs
Just package -> do
let hslibs = hsLibraries package
extras' = extraLibraries package
cbits = filter (\e -> reverse (take (length "_cbits") (reverse e)) == "_cbits") extras'
extras = filter (not . flip elem (cbits++["m","gmp"])) extras'
ldopts = ldOptions package
deppkgs = packageDeps package
ldInput <- mapM classifyLdInput ldopts
let ldOptsLibs = [ path | Just (DLL path) <- ldInput ]
ldOptsPaths = [ path | Just (DLLPath path) <- ldInput ]
dlls = map mkSOName (extras ++ ldOptsLibs)
#if defined(CYGWIN) || defined(__MINGW32__)
libdirs = fix_topdir (libraryDirs package) ++ ldOptsPaths
#else
libdirs = libraryDirs package ++ ldOptsPaths
#endif
libs <- mapM (findHSlib libdirs) (hslibs ++ cbits)
#if defined(CYGWIN) || defined(__MINGW32__)
windowsos <- catch (getEnv "OS")
(\e -> if isDoesNotExistError e then return "Windows_98" else ioError e)
windowsdir <-
if windowsos == "Windows_9X" -- I don't know Windows 9X has OS system variable
then return "C:/windows"
else return "C:/winnt"
sysroot <- catch (getEnv "SYSTEMROOT")
(\e -> if isDoesNotExistError e then return windowsdir else ioError e) -- guess at a reasonable default
let syslibdir = sysroot ++ (if windowsos == "Windows_9X" then "/SYSTEM" else "/SYSTEM32")
libs' <- mapM (findDLL $ syslibdir : libdirs) dlls
#else
libs' <- mapM (findDLL libdirs) dlls
#endif
return (deppkgs, (filterRight libs,map (either id id) libs') )
#if defined(CYGWIN) || defined(__MINGW32__)
-- replace $topdir
fix_topdir [] = []
fix_topdir (x:xs) = replace_topdir x : fix_topdir xs
replace_topdir [] = []
replace_topdir ('$':xs)
| take 6 xs == "topdir" = ghcLibraryPath ++ (drop 6 xs)
| otherwise = '$' : replace_topdir xs
replace_topdir (x:xs) = x : replace_topdir xs
#endif
-- a list elimination form for the Maybe type
filterRight :: [Either left right] -> [right]
filterRight [] = []
filterRight (Right x:xs) = x:filterRight xs
filterRight (Left _:xs) = filterRight xs
--
-- Check that a path to a library actually reaches a library
-- Problem: sysPkgSuffix is ".o", but extra libraries could be
-- ".so" -- what to do?
--
findHSlib :: [FilePath] -> String -> IO (Either String FilePath)
findHSlib [] lib = return (Left lib)
findHSlib (dir:dirs) lib = do
let l = dir </> lib ++ sysPkgSuffix
b <- doesFileExist l
if b then return $ Right l -- found it!
else findHSlib dirs lib
findDLL :: [FilePath] -> String -> IO (Either String FilePath)
findDLL [] lib = return (Left lib)
findDLL (dir:dirs) lib = do
let l = dir </> lib
b <- doesFileExist l
if b then return $ Right l
else findDLL dirs lib
------------------------------------------------------------------------
-- do we have a Module name for this merge?
--
isMerged :: FilePath -> FilePath -> IO Bool
isMerged a b = withMerged env $ \fm -> return $ isJust (lookupFM fm (a,b))
lookupMerged :: FilePath -> FilePath -> IO (Maybe FilePath)
lookupMerged a b = withMerged env $ \fm -> return $ lookupFM fm (a,b)
--
-- insert a new merge pair into env
--
addMerge :: FilePath -> FilePath -> FilePath -> IO ()
addMerge a b z = modifyMerged env $ \fm -> return $ addToFM fm (a,b) z
------------------------------------------------------------------------
-- break a module cycle
-- private:
--
(</>) :: FilePath -> FilePath -> FilePath
[] </> b = b
a </> b = a ++ "/" ++ b

662
src/System/Plugins/Load.hs
View File

@ -1,662 +0,0 @@
{-# OPTIONS -#include "Linker.h" #-}
{-# OPTIONS -fglasgow-exts -cpp #-}
--
-- 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
--
module System.Plugins.Load (
-- high level interface
load , load_
, dynload
, pdynload , pdynload_
, unload
, unloadAll
, reload
, Module(..)
, LoadStatus(..)
-- low level interface
, initLinker -- start it up
, loadModule -- load a vanilla .o
, loadFunction -- retrieve a function from an object
, loadPackage -- load a ghc library and its cbits
, unloadPackage -- unload a ghc library and its cbits
, loadPackageWith -- load a pkg using the package.conf provided
, loadShared -- load a .so object file
, resolveObjs -- and resolve symbols
, loadRawObject -- load a bare .o. no dep chasing, no .hi file reading
, Symbol
, getImports
) where
#include "../../../config.h"
import System.Plugins.Make ( build )
import System.Plugins.Env
import System.Plugins.Utils
import System.Plugins.Consts ( sysPkgSuffix, hiSuf, prefixUnderscore )
import System.Plugins.LoadTypes
import Language.Hi.Parser
import AltData.Dynamic ( fromDynamic, Dynamic )
import AltData.Typeable ( Typeable )
import Data.List ( isSuffixOf, nub, nubBy )
import Control.Monad ( when, filterM, liftM )
import System.Directory ( doesFileExist, removeFile )
import Foreign.C.String ( CString, withCString, peekCString )
import GHC.Ptr ( Ptr(..), nullPtr )
import GHC.Exts ( addrToHValue# )
import GHC.Prim ( unsafeCoerce# )
#if DEBUG
import System.IO ( hFlush, stdout )
#endif
import System.IO ( hClose )
-- TODO need a loadPackage p package.conf :: IO () primitive
-- ---------------------------------------------------------------------
-- return status of all *load functions:
--
data LoadStatus a
= LoadSuccess Module a
| LoadFailure Errors
-- ---------------------------------------------------------------------
-- | load an object file into the address space, returning the closure
-- associated with the symbol requested, after removing its dynamism.
--
-- Recursively loads the specified modules, and all the modules they
-- depend on.
--
load :: FilePath -- ^ object file
-> [FilePath] -- ^ any include paths
-> [PackageConf] -- ^ list of package.conf paths
-> Symbol -- ^ symbol to find
-> IO (LoadStatus a)
load obj incpaths pkgconfs sym = do
initLinker
-- load extra package information
mapM_ addPkgConf pkgconfs
(hif,moduleDeps) <- loadDepends obj incpaths
-- why is this the package name?
#if DEBUG
putStr (' ':(decode $ mi_module hif)) >> hFlush stdout
#endif
m' <- loadObject obj (Object (mi_module hif))
let m = m' { iface = hif }
resolveObjs (mapM_ unloadAll (m:moduleDeps))
#if DEBUG
putStrLn " ... done" >> hFlush stdout
#endif
addModuleDeps m' moduleDeps
v <- loadFunction m sym
return $ case v of
Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"]
Just a -> LoadSuccess m a
--
-- | Like load, but doesn't want a package.conf arg (they are rarely used)
--
load_ :: FilePath -> [FilePath] -> Symbol -> IO (LoadStatus a)
load_ o i s = load o i [] s
--
-- A work-around for Dynamics. The keys used to compare two TypeReps are
-- somehow not equal for the same type in hs-plugin's loaded objects.
-- Solution: implement our own dynamics...
--
-- The problem with dynload is that it requires the plugin to export
-- a value that is a Dynamic (in our case a (TypeRep,a) pair). If this
-- is not the case, we core dump. Use pdynload if you don't trust the
-- user to supply you with a Dynamic
--
dynload :: Typeable a
=> FilePath
-> [FilePath]
-> [PackageConf]
-> Symbol
-> IO (LoadStatus a)
dynload obj incpaths pkgconfs sym = do
s <- load obj incpaths pkgconfs sym
case s of e@(LoadFailure _) -> return e
LoadSuccess m dyn_v -> return $
case fromDynamic (unsafeCoerce# dyn_v :: Dynamic) of
Just v' -> LoadSuccess m v'
Nothing -> LoadFailure ["Mismatched types in interface"]
------------------------------------------------------------------------
--
-- The super-replacement for dynload
--
-- Use GHC at runtime so we get staged type inference, providing full
-- power dynamics, *on module interfaces only*. This is quite suitable
-- for plugins, of coures :)
--
-- TODO where does the .hc file go in the call to build() ?
--
pdynload :: FilePath -- ^ object to load
-> [FilePath] -- ^ include paths
-> [PackageConf] -- ^ package confs
-> Type -- ^ API type
-> Symbol -- ^ symbol
-> IO (LoadStatus a)
pdynload object incpaths pkgconfs ty sym = do
#if DEBUG
putStr "Checking types ... " >> hFlush stdout
#endif
errors <- unify object incpaths [] ty sym
#if DEBUG
putStrLn "done"
#endif
if null errors
then load object incpaths pkgconfs sym
else return $ LoadFailure errors
--
-- | Like pdynload, but you can specify extra arguments to the
-- typechecker.
--
pdynload_ :: FilePath -- ^ object to load
-> [FilePath] -- ^ include paths for loading
-> [PackageConf] -- ^ any extra package.conf files
-> [Arg] -- ^ extra arguments to ghc, when typechecking
-> Type -- ^ expected type
-> Symbol -- ^ symbol to load
-> IO (LoadStatus a)
pdynload_ object incpaths pkgconfs args ty sym = do
#if DEBUG
putStr "Checking types ... " >> hFlush stdout
#endif
errors <- unify object incpaths args ty sym
#if DEBUG
putStrLn "done"
#endif
if null errors
then load object incpaths pkgconfs sym
else return $ LoadFailure errors
------------------------------------------------------------------------
-- run the typechecker over the constraint file
--
-- Problem: if the user depends on a non-auto package to build the
-- module, then that package will not be in scope when we try to build
-- the module, when performing `unify'. Normally make() will handle this
-- (as it takes extra ghc args). pdynload ignores these, atm -- but it
-- shouldn't. Consider a pdynload() that accepts extra -package flags?
--
-- Also, pdynload() should accept extra in-scope modules.
-- Maybe other stuff we want to hack in here.
--
unify obj incs args ty sym = do
(tmpf,hdl) <- mkTemp
(tmpf1,hdl1) <- mkTemp -- and send .hi file here.
hClose hdl1
let nm = mkModid (basename tmpf)
src = mkTest nm (hierize' . mkModid . hierize $ obj)
(fst $ break (=='.') ty) ty sym
is = map (\s -> "-i"++s) incs -- api
i = "-i" ++ dirname obj -- plugin
hWrite hdl src
e <- build tmpf tmpf1 (i:is++args++["-fno-code","-ohi "++tmpf1])
-- removeFile tmpf
removeFile tmpf1
return e
where
-- fix up hierarchical names
hierize [] = []
hierize ('/':cs) = '\\' : hierize cs
hierize (c:cs) = c : hierize cs
hierize'[] = []
hierize' ('\\':cs) = '.' : hierize' cs
hierize' (c:cs) = c : hierize' cs
mkTest modnm plugin api ty sym =
"module "++ modnm ++" where" ++
"\nimport qualified " ++ plugin ++
"\nimport qualified " ++ api ++
"{-# LINE 1 \"<typecheck>\" #-}" ++
"\n_ = "++ plugin ++"."++ sym ++" :: "++ty
------------------------------------------------------------------------
{-
--
-- old version that tried to rip stuff from .hi files
--
pdynload obj incpaths pkgconfs sym ty = do
(m, v) <- load obj incpaths pkgconfs sym
ty' <- mungeIface sym obj
if ty == ty'
then return $ Just (m, v)
else return Nothing -- mismatched types
where
-- grab the iface output from GHC. find the line relevant to our
-- symbol. grab the string rep of the type.
mungeIface sym o = do
let hi = replaceSuffix o hiSuf
(out,_) <- exec ghc ["--show-iface", hi]
case find (\s -> (sym ++ " :: ") `isPrefixOf` s) out of
Nothing -> return undefined
Just v -> do let v' = drop 3 $ dropWhile (/= ':') v
return v'
-}
{-
--
-- a version of load the also unwraps and types a Dynamic object
--
dynload2 :: Typeable a =>
FilePath ->
FilePath ->
Maybe [PackageConf] ->
Symbol ->
IO (Module, a)
dynload2 obj incpath pkgconfs sym = do
(m, v) <- load obj incpath pkgconfs sym
case fromDynamic v of
Nothing -> panic $ "load: couldn't type "++(show v)
Just a -> return (m,a)
-}
------------------------------------------------------------------------
--
-- | unload a module (not its dependencies)
-- we have the dependencies, so cascaded unloading is possible
--
-- once you unload it, you can't 'load' it again, you have to 'reload'
-- it. Cause we don't unload all the dependencies
--
unload :: Module -> IO ()
unload m = rmModuleDeps m >> unloadObj m
------------------------------------------------------------------------
--
-- | unload a module and its dependencies
-- we have the dependencies, so cascaded unloading is possible
--
unloadAll :: Module -> IO ()
unloadAll m = do moduleDeps <- getModuleDeps m
rmModuleDeps m
mapM_ unloadAll moduleDeps
unload m
--
-- | this will be nice for panTHeon, needs thinking about the interface
-- reload a single object file. don't care about depends, assume they
-- are loaded. (should use state to store all this)
--
-- assumes you've already done a 'load'
--
-- should factor the code
--
reload :: Module -> Symbol -> IO (LoadStatus a)
reload m@(Module{path = p, iface = hi}) sym = do
unloadObj m -- unload module (and delete)
#if DEBUG
putStr ("Reloading "++(mname m)++" ... ") >> hFlush stdout
#endif
m_ <- loadObject p (Object $ mi_module hi) -- load object at path p
let m' = m_ { iface = hi }
resolveObjs (unloadAll m)
#if DEBUG
putStrLn "done" >> hFlush stdout
#endif
v <- loadFunction m' sym
return $ case v of
Nothing -> LoadFailure ["load: couldn't find symbol <<"++sym++">>"]
Just a -> LoadSuccess m' a
-- ---------------------------------------------------------------------
-- This is a stripped-down version of Andr<64> Pang's runtime_loader,
-- which in turn is based on GHC's ghci/ObjLinker.lhs binding
--
-- Load and unload\/Haskell modules at runtime. This is not really
-- \'dynamic loading\', as such -- that implies that you\'re working
-- with proper shared libraries, whereas this is far more simple and
-- only loads object files. But it achieves the same goal: you can
-- load a Haskell module at runtime, load a function from it, and run
-- the function. I have no idea if this works for types, but that
-- doesn\'t mean that you can\'t try it :).
--
-- read $fptools/ghc/compiler/ghci/ObjLinker.lhs for how to use this stuff
--
------------------------------------------------------------------------
-- | Call the initLinker function first, before calling any of the other
-- functions in this module - otherwise you\'ll get unresolved symbols.
-- initLinker :: IO ()
-- our initLinker transparently calls the one in GHC
--
-- | Load a function from a module (which must be loaded and resolved first).
--
loadFunction :: Module -- ^ The module the value is in
-> String -- ^ Symbol name of value
-> IO (Maybe a) -- ^ The value you want
loadFunction (Module { iface = i }) valsym
= do let m = mi_module i
symbol = symbolise m
#if DEBUG
putStrLn $ "Looking for <<"++symbol++">>"
#endif
ptr@(~(Ptr addr)) <- withCString symbol c_lookupSymbol
if (ptr == nullPtr)
then return Nothing
else case addrToHValue# addr of
(# hval #) -> return ( Just hval )
where
symbolise m = prefixUnderscore++m++"_"++(encode valsym)++"_closure"
--
-- | Load a GHC-compiled Haskell vanilla object file.
-- The first arg is the path to the object file
--
-- We make it idempotent to stop the nasty problem of loading the same
-- .o twice. Also the rts is a very special package that is already
-- loaded, even if we ask it to be loaded. N.B. we should insert it in
-- the list of known packages.
--
-- NB the environment stores the *full path* to an object. So if you
-- want to know if a module is already loaded, you need to supply the
-- *path* to that object, not the name.
--
-- NB -- let's try just the module name.
--
-- loadObject loads normal .o objs, and packages too. .o objs come with
-- a nice canonical Z-encoded modid. packages just have a simple name.
-- Do we want to ensure they won't clash? Probably.
--
--
-- the second argument to loadObject is a string to use as the unique
-- identifier for this object. For normal .o objects, it should be the
-- Z-encoded modid from the .hi file. For archives/packages, we can
-- probably get away with the package name
--
loadObject :: FilePath -> Key -> IO Module
loadObject p ky@(Object k) = loadObject' p ky k
loadObject p ky@(Package k) = loadObject' p ky k
loadObject' :: FilePath -> Key -> String -> IO Module
loadObject' p ky k
| ("HSrts"++sysPkgSuffix) `isSuffixOf` p = return (emptyMod p)
| otherwise
= do alreadyLoaded <- isLoaded k
when (not alreadyLoaded) $ do
r <- withCString p c_loadObj
when (not r) (panic $ "Could not load module `"++p++"'")
addModule k (emptyMod p) -- needs to Z-encode module name
return (emptyMod p)
where emptyMod q = Module q (mkModid q) Vanilla emptyIface ky
--
-- load a single object. no dependencies. You should know what you're
-- doing.
--
loadModule :: FilePath -> IO Module
loadModule obj = do
let hifile = replaceSuffix obj hiSuf
exists <- doesFileExist hifile
if (not exists)
then error $ "No .hi file found for "++show obj
else do hiface <- readIface hifile
loadObject obj (Object (mi_module hiface))
--
-- | Load a generic .o file, good for loading C objects.
-- You should know what you're doing..
-- Returns a fairly meaningless iface value.
--
loadRawObject :: FilePath -> IO Module
loadRawObject obj = loadObject obj (Object k)
where
k = encode (mkModid obj) -- Z-encoded module name
--
-- | Resolve (link) the modules loaded by the 'loadObject' function.
--
resolveObjs :: IO a -> IO ()
resolveObjs unloadLoaded
= do r <- c_resolveObjs
when (not r) $ unloadLoaded >> panic "resolvedObjs failed."
-- | Unload a module
unloadObj :: Module -> IO ()
unloadObj (Module { path = p, kind = k, key = ky }) = case k of
Vanilla -> withCString p $ \c_p -> do
removed <- rmModule name
when (removed) $ do r <- c_unloadObj c_p
when (not r) (panic "unloadObj: failed")
Shared -> return () -- can't unload .so?
where name = case ky of Object s -> s ; Package pk -> pk
--
-- | from ghci/ObjLinker.c
--
-- Load a .so type object file.
--
loadShared :: FilePath -> IO Module
loadShared str = do
#if DEBUG
putStrLn $ " shared: " ++ str
#endif
maybe_errmsg <- withCString str $ \dll -> c_addDLL dll
if maybe_errmsg == nullPtr
then return (Module str (mkModid str) Shared emptyIface (Package (mkModid str)))
else do e <- peekCString maybe_errmsg
panic $ "loadShared: couldn't load `"++str++"\' because "++e
--
-- Load a -package that we might need, implicitly loading the cbits too
-- The argument is the name of package (e.g. \"concurrent\")
--
-- How to find a package is determined by the package.conf info we store
-- in the environment. It is just a matter of looking it up.
--
-- Not printing names of dependent pkgs
--
loadPackage :: String -> IO ()
loadPackage p = do
#if DEBUG
putStr (' ':p) >> hFlush stdout
#endif
(libs,dlls) <- lookupPkg p
mapM_ (\l -> loadObject l (Package (mkModid l))) libs
#if DEBUG
putStr (' ':show dlls)
#endif
mapM_ loadShared dlls
--
-- Unload a -package, that has already been loaded. Unload the cbits
-- too. The argument is the name of the package.
--
-- May need to check if it exists.
--
-- Note that we currently need to unload everything. grumble grumble.
--
-- We need to add the version number to the package name with 6.4 and
-- over. "yi-0.1" for example. This is a bug really.
--
unloadPackage :: String -> IO ()
unloadPackage pkg = do
let pkg' = takeWhile (/= '-') pkg -- in case of *-0.1
libs <- liftM (\(a,_) -> (filter (isSublistOf pkg') ) a) (lookupPkg pkg)
flip mapM_ libs $ \p -> withCString p $ \c_p -> do
r <- c_unloadObj c_p
when (not r) (panic "unloadObj: failed")
rmModule (mkModid p) -- unrecord this module
--
-- load a package using the given package.conf to help
-- TODO should report if it doesn't actually load the package, instead
-- of mapM_ doing nothing like above.
--
loadPackageWith :: String -> [PackageConf] -> IO ()
loadPackageWith p pkgconfs = do
#if DEBUG
putStr "Loading package" >> hFlush stdout
#endif
mapM_ addPkgConf pkgconfs
loadPackage p
#if DEBUG
putStrLn " done"
#endif
-- ---------------------------------------------------------------------
-- module dependency loading
--
-- given an Foo.o vanilla object file, supposed to be a plugin compiled
-- by our library, find the associated .hi file. If this is found, load
-- the dependencies, packages first, then the modules. If it doesn't
-- exist, assume the user knows what they are doing and continue. The
-- linker will crash on them anyway. Second argument is any include
-- paths to search in
--
-- ToDo problem with absolute and relative paths, and different forms of
-- relative paths. A user may cause a dependency to be loaded, which
-- will search the incpaths, and perhaps find "./Foo.o". The user may
-- then explicitly load "Foo.o". These are the same, and the loader
-- should ignore the second load request. However, isLoaded will say
-- that "Foo.o" is not loaded, as the full string is used as a key to
-- the modenv fm. We need a canonical form for the keys -- is basename
-- good enough?
--
loadDepends :: FilePath -> [FilePath] -> IO (Iface,[Module])
loadDepends obj incpaths = do
let hifile = replaceSuffix obj hiSuf
exists <- doesFileExist hifile
if (not exists)
then do
#if DEBUG
putStrLn "No .hi file found." >> hFlush stdout
#endif
return (emptyIface,[]) -- could be considered fatal
else do hiface <- readIface hifile
let ds = mi_deps hiface
-- remove ones that we've already loaded
ds' <- filterM loaded (dep_mods ds)
-- now, try to generate a path to the actual .o file
-- fix up hierachical names
let mods_ = map (\s -> (s, map (\c ->
if c == '.' then '/' else c) $ decode s)) ds'
-- construct a list of possible dependent modules to load
let mods = concatMap (\p ->
map (\(hi,m) -> (hi,p </> m++".o")) mods_) incpaths
-- remove modules that don't exist
mods' <- filterM (\(_,y) -> doesFileExist y) $
nubBy (\v u -> snd v == snd u) mods
-- now remove duplicate valid paths to the same object
let mods'' = nubBy (\v u -> fst v == fst u) mods'
-- and find some packages to load, as well.
let ps = dep_pkgs ds
ps' <- filterM loaded (nub ps)
#if DEBUG
when (not (null ps')) $
putStr "Loading package" >> hFlush stdout
#endif
mapM_ loadPackage ps'
#if DEBUG
when (not (null ps')) $
putStr " ... linking ... " >> hFlush stdout
#endif
resolveObjs (mapM_ unloadPackage ps')
#if DEBUG
when (not (null ps')) $ putStrLn "done"
putStr "Loading object"
mapM_ (\(m,_) -> putStr (" "++(decode m)) >> hFlush stdout) mods''
#endif
moduleDeps <- mapM (\(hi,m) -> loadObject m (Object hi)) mods''
return (hiface,moduleDeps)
-- ---------------------------------------------------------------------
-- Nice interface to .hi parser
--
getImports :: String -> IO [String]
getImports m = do
hi <- readIface (m ++ hiSuf)
return $ dep_mods (mi_deps hi)
-- ---------------------------------------------------------------------
-- C interface
--
foreign import ccall unsafe "lookupSymbol"
c_lookupSymbol :: CString -> IO (Ptr a)
foreign import ccall unsafe "loadObj"
c_loadObj :: CString -> IO Bool
foreign import ccall unsafe "unloadObj"
c_unloadObj :: CString -> IO Bool
foreign import ccall unsafe "resolveObjs"
c_resolveObjs :: IO Bool
foreign import ccall unsafe "addDLL"
c_addDLL :: CString -> IO CString
foreign import ccall unsafe "initLinker"
initLinker :: IO ()

52
src/System/Plugins/LoadTypes.hs
View File

@ -1,52 +0,0 @@
--
-- Copyright (c) 2005 Lemmih <lemmih@gmail.com>
-- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
--
-- This program 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
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--
module System.Plugins.LoadTypes
( Key (..)
, Symbol
, Type
, Errors
, PackageConf
, Module (..)
, ObjType (..)
) where
import Language.Hi.Parser
data Key = Object String | Package String
type Symbol = String
type Type = String
type Errors = [String]
type PackageConf = FilePath
data Module = Module { path :: !FilePath
, mname :: !String
, kind :: !ObjType
, iface :: Iface -- cache the iface
, key :: Key
}
instance Ord Module where
compare m1 m2 = mname m1 `compare` mname m2
instance Eq Module where
m1 == m2 = mname m1 == mname m2
data ObjType = Vanilla | Shared deriving Eq

356
src/System/Plugins/Make.hs
View File

@ -1,356 +0,0 @@
{-# OPTIONS -cpp #-}
--
-- 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
--
module System.Plugins.Make (
make,
makeAll,
makeWith,
MakeStatus(..),
MakeCode(..),
hasChanged,
hasChanged',
recompileAll,
recompileAll',
merge,
mergeTo,
mergeToDir,
MergeStatus(..),
MergeCode,
makeClean,
makeCleaner,
build, {- internal -}
) where
import System.Plugins.Utils
import System.Plugins.Parser
import System.Plugins.LoadTypes ( Module (Module, path) )
import System.Plugins.Consts ( ghc, hiSuf, objSuf, hsSuf )
import System.Plugins.Process ( exec )
import System.Plugins.Env ( lookupMerged, addMerge
, getModuleDeps)
#if DEBUG
import System.IO (hFlush, stdout, openFile, IOMode(..),hClose, hPutStr)
#else
import System.IO (openFile, IOMode(..),hClose,hPutStr)
#endif
import System.Directory ( doesFileExist, removeFile
, getModificationTime )
import Control.Exception ( handleJust )
import GHC.IOBase ( Exception(IOException) )
#if __GLASGOW_HASKELL__ >= 604
import System.IO.Error ( isDoesNotExistError )
#endif
------------------------------------------------------------------------
--
-- A better compiler status.
--
data MakeStatus
= MakeSuccess MakeCode FilePath
| MakeFailure Errors
deriving (Eq,Show)
data MakeCode = ReComp | NotReq
deriving (Eq,Show)
------------------------------------------------------------------------
--
-- An equivalent status for the preprocessor (merge)
--
data MergeStatus
= MergeSuccess MergeCode Args FilePath
| MergeFailure Errors
deriving (Eq,Show)
type MergeCode = MakeCode
type Args = [Arg]
type Errors = [String]
--
-- |Returns @True@ if the module or any of its dependencies have older object files than source files.
-- Defaults to @True@ if some files couldn't be located.
--
hasChanged :: Module -> IO Bool
hasChanged = hasChanged' ["hs","lhs"]
hasChanged' :: [String] -> Module -> IO Bool
hasChanged' suffices m@(Module {path = p})
= do modFile <- doesFileExist p
mbFile <- findFile suffices p
case mbFile of
Just f | modFile
-> do srcT <- getModificationTime f
objT <- getModificationTime p
if srcT > objT
then return True
else do deps <- getModuleDeps m
depsStatus <- mapM (hasChanged' suffices) deps
return (or depsStatus)
_ -> return True
--
-- |Same as 'makeAll' but with better recompilation checks since module dependencies are known.
--
recompileAll :: Module -> [Arg] -> IO MakeStatus
recompileAll = recompileAll' ["hs","lhs"]
recompileAll' :: [String] -> Module -> [Arg] -> IO MakeStatus
recompileAll' suffices m args
= do changed <- hasChanged m
if changed
then do mbSource <- findFile suffices (path m)
case mbSource of
Nothing
-> error $ "Couldn't find source for object file: " ++ path m
Just source
-> makeAll source args
else return (MakeSuccess NotReq (path m))
-- touch.
-- ---------------------------------------------------------------------
-- | Standard make. Compile a single module, unconditionally.
-- Behaves like ghc -c
--
make :: FilePath -> [Arg] -> IO MakeStatus
make src args = rawMake src ("-c":args) True
-- | Recursive make. Compile a module, and its dependencies if we can
-- find them. Takes the top-level file as the first argument.
-- Behaves like ghc --make
--
makeAll :: FilePath -> [Arg] -> IO MakeStatus
makeAll src args =
rawMake src ( "--make":"-no-hs-main":"-no-link":"-v0":args ) False
-- | merge two files; then make them. will leave a .o and .hi file in tmpDir.
--
makeWith :: FilePath -- ^ a src file
-> FilePath -- ^ a syntax stub file
-> [Arg] -- ^ any required args
-> IO MakeStatus -- ^ path to an object file
makeWith src stub args = do
status <- merge src stub
case status of
MergeFailure errs -> return $ MakeFailure ("merge failed:\n":errs)
MergeSuccess _ args' tmpf -> do
status' <- rawMake tmpf ("-c": args' ++ args) True
return status'
-- ---------------------------------------------------------------------
-- rawMake : really do the compilation
-- Conditional on file modification times, compile a .hs file
-- When using 'make', the name of the src file must be the name of the
-- .o file you are expecting back
--
-- Problem: we use GHC producing stdout to indicate compilation failure.
-- We should instead check the error conditions. I.e. --make will
-- produce output, but of course compiles correctly. TODO
-- So, e.g. --make requires -v0 to stop spurious output confusing
-- rawMake
--
-- Problem :: makeAll incorrectly refuses to recompile if the top level
-- src isn't new.
--
rawMake :: FilePath -- ^ src
-> [Arg] -- ^ any compiler args
-> Bool -- ^ do our own recompilation checking
-> IO MakeStatus
rawMake src args docheck = do
src_exists <- doesFileExist src
if not src_exists
then return $ MakeFailure ["Source file does not exist: "++src]
else do {
; let (obj,_) = outFilePath src args
; src_changed <- if docheck then src `newer` obj else return True
; if not src_changed
then return $ MakeSuccess NotReq obj
else do
#if DEBUG
putStr "Compiling object ... " >> hFlush stdout
#endif
err <- build src obj args
#if DEBUG
putStrLn "done"
#endif
return $ if null err
then MakeSuccess ReComp obj
else MakeFailure err
}
--
-- compile a .hs file to a .o file
--
-- If the plugin needs to import an api (which should be almost
-- everyone) then the ghc flags to find the api need to be provided as
-- arguments
--
build :: FilePath -- path to .hs source
-> FilePath -- path to object file
-> [String] -- any extra cmd line flags
-> IO [String]
build src obj extra_opts = do
let odir = dirname obj -- *always* put the .hi file next to the .o file
let ghc_opts = [ "-Onot" ]
output = [ "-o", obj, "-odir", odir,
"-hidir", odir, "-i" ++ odir ]
let flags = ghc_opts ++ output ++ extra_opts ++ [src]
#if DEBUG
-- env.
putStr $ show $ ghc : flags
#endif
(_out,err) <- exec ghc flags -- this is a fork()
obj_exists <- doesFileExist obj -- sanity
return $ if not obj_exists && null err -- no errors, but no object?
then ["Compiled, but didn't create object file `"++obj++"'!"]
else err
-- ---------------------------------------------------------------------
-- | Merge to source files into a temporary file. If we've tried to
-- merge these two stub files before, then reuse the module name (helps
-- recompilation checking)
--
merge :: FilePath -> FilePath -> IO MergeStatus
merge src stb = do
m_mod <- lookupMerged src stb
(out,domerge) <- case m_mod of
Nothing -> do out <- mkUnique
addMerge src stb (dropSuffix out)
return (out, True) -- definitely out of date
Just nm -> return $ (nm <> hsSuf, False)
rawMerge src stb out domerge
-- | Merge to source files and store them in the specified output file,
-- instead of a temp file as merge does.
--
mergeTo :: FilePath -> FilePath -> FilePath -> IO MergeStatus
mergeTo src stb out = rawMerge src stb out False
mergeToDir :: FilePath -> FilePath -> FilePath -> IO MergeStatus
mergeToDir src stb dir = do
out <- mkUniqueIn dir
rawMerge src stb out True
-- ---------------------------------------------------------------------
-- Conditional on file modification times, merge a src file with a
-- syntax stub file into a result file.
--
-- Merge should only occur if the srcs has changed since last time.
-- Parser errors result in MergeFailure, and are reported to the client
--
-- Also returns a list of cmdline flags found in pragmas in the src of
-- the files. This last feature exists as OPTION pragmas aren't handled
-- (for obvious reasons, relating to the implementation of OPTIONS
-- parsing in GHC) by the library parser, and, also, we want a way for
-- the user to introduce *dynamic* cmd line flags in the .conf file.
-- This is achieved via the GLOBALOPTIONS pragma : an extension to ghc
-- pragma syntax
--
rawMerge :: FilePath -> FilePath -> FilePath -> Bool -> IO MergeStatus
rawMerge src stb out always_merge = do
src_exists <- doesFileExist src
stb_exists <- doesFileExist stb
case () of {_
| not src_exists -> return $
MergeFailure ["Source file does not exist : "++src]
| not stb_exists -> return $
MergeFailure ["Source file does not exist : "++stb]
| otherwise -> do {
;do_merge <- do src_changed <- src `newer` out
stb_changed <- stb `newer` out
return $ src_changed || stb_changed
;if not do_merge && not always_merge
then return $ MergeSuccess NotReq [] out
else do
src_str <- readFile src
stb_str <- readFile stb
let (a,a') = parsePragmas src_str
(b,b') = parsePragmas stb_str
opts = a ++ a' ++ b ++ b'
let e_src_syn = parse src src_str
e_stb_syn = parse stb stb_str
-- check if there were parser errors
case (e_src_syn,e_stb_syn) of
(Left e, _) -> return $ MergeFailure [e]
(_ , Left e) -> return $ MergeFailure [e]
(Right src_syn, Right stb_syn) -> do {
;let mrg_syn = mergeModules src_syn stb_syn
mrg_syn'= replaceModName mrg_syn (mkModid $ basename out)
mrg_str = pretty mrg_syn'
;hdl <- openFile out WriteMode -- overwrite!
;hPutStr hdl mrg_str ; hClose hdl
;return $ MergeSuccess ReComp opts out -- must have recreated file
}}}
-- ---------------------------------------------------------------------
-- | makeClean : assuming we some element of [f.hs,f.hi,f.o], remove the
-- .hi and .o components. Silently ignore any missing components. *Does
-- not remove .hs files*. To do that use makeCleaner. This would be
-- useful for merged files, for example.
--
makeClean :: FilePath -> IO ()
makeClean f = let f_hi = dropSuffix f <> hiSuf
f_o = dropSuffix f <> objSuf
in mapM_ rm_f [f_hi, f_o]
makeCleaner :: FilePath -> IO ()
makeCleaner f = makeClean f >> rm_f (dropSuffix f <> hsSuf)
-- internal:
-- try to remove a file, ignoring if it didn't exist in the first place
-- Doesn't seem to be able to remove all files in all circumstances, why?
--
rm_f f = handleJust doesntExist (\_->return ()) (removeFile f)
where
doesntExist (IOException ioe)
| isDoesNotExistError ioe = Just ()
| otherwise = Nothing
doesntExist _ = Nothing

67
src/System/Plugins/Package.hs
View File

@ -1,67 +0,0 @@
--
-- Copyright (C) 2004 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried
--
-- 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
--
-- Read information from a package.conf
--
module System.Plugins.Package {-everything-} where
type PackageName = String
--
-- Take directly from ghc/utils/ghc-pkg/Package.hs
--
data PackageConfig = Package {
name :: PackageName,
auto :: Bool,
import_dirs :: [FilePath],
source_dirs :: [FilePath],
library_dirs :: [FilePath],
hs_libraries :: [String],
extra_libraries :: [String],
include_dirs :: [FilePath],
c_includes :: [String],
package_deps :: [String],
extra_ghc_opts :: [String],
extra_cc_opts :: [String],
extra_ld_opts :: [String],
framework_dirs :: [FilePath], -- ignored everywhere but on Darwin/MacOS X
extra_frameworks:: [String] -- ignored everywhere but on Darwin/MacOS X
} deriving Show
defaultPackageConfig = Package {
name = error "defaultPackage",
auto = False,
import_dirs = [],
source_dirs = [],
library_dirs = [],
hs_libraries = [],
extra_libraries = [],
include_dirs = [],
c_includes = [],
package_deps = [],
extra_ghc_opts = [],
extra_cc_opts = [],
extra_ld_opts = [],
framework_dirs = [],
extra_frameworks= []
}

96
src/System/Plugins/PackageAPI.hs
View File

@ -1,96 +0,0 @@
{-# OPTIONS -cpp #-}
--
-- Copyright (C) 2005 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried
--
-- 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
--
-- We export an abstract interface to package conf`s because we have
-- to handle either traditional or Cabal style package conf`s.
--
module System.Plugins.PackageAPI (
PackageName
, PackageConfig
, packageName
, packageName_
, importDirs
, hsLibraries
, libraryDirs
, extraLibraries
, ldOptions
, packageDeps
, updImportDirs
, updLibraryDirs
) where
#include "../../../config.h"
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
import Distribution.InstalledPackageInfo
import Distribution.Package
#else
import System.Plugins.Package
#endif
packageName :: PackageConfig -> PackageName
packageDeps :: PackageConfig -> [PackageName]
updImportDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig
updLibraryDirs :: ([FilePath] -> [FilePath]) -> PackageConfig -> PackageConfig
-- We use different package.conf parsers when running on 6.2.x or 6.4
#if CABAL == 1 || __GLASGOW_HASKELL__ >= 604
type PackageName = String
type PackageConfig = InstalledPackageInfo
packageName = showPackageId . package
packageName_ = pkgName . package
packageDeps = (map showPackageId) . depends
updImportDirs f pk@(InstalledPackageInfo { importDirs = idirs }) =
pk { importDirs = f idirs }
updLibraryDirs f pk@(InstalledPackageInfo { libraryDirs = ldirs }) =
pk { libraryDirs = f ldirs }
#else
packageName = name
packageName_ = name
packageDeps = package_deps
updImportDirs f pk@(Package {import_dirs = idirs})
= pk {import_dirs = f idirs}
updLibraryDirs f pk@(Package {library_dirs = ldirs})
= pk {library_dirs = f ldirs}
importDirs :: PackageConfig -> [FilePath]
importDirs = import_dirs
hsLibraries :: PackageConfig -> [String]
hsLibraries = hs_libraries
libraryDirs :: PackageConfig -> [FilePath]
libraryDirs = library_dirs
extraLibraries :: PackageConfig -> [String]
extraLibraries = extra_libraries
ldOptions :: PackageConfig -> [String]
ldOptions = extra_ld_opts
#endif

218
src/System/Plugins/ParsePkgConfCabal.y
View File

@ -1,218 +0,0 @@
--
-- Copyright (C) 2005 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried
--
-- 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
--
--
-- Taken (apart from the most minor of alterations) from
-- ghc/utils/ghc-pkg/ParsePkgConfLite.hs from GHC 6.2.2 source tree
-- and then modified to mimic the behaviour of the parser within
-- ghc/compiler/main/ParsePkgConf.y in GHC 6.4, without importing
-- heavy-weight infrastructure from the GHC source tree such as module
-- FastString, Lexer, etc.
--
-- (c) Copyright 2002, The University Court of the University of Glasgow.
--
{
{-# OPTIONS -w #-}
module System.Plugins.ParsePkgConfCabal (
parsePkgConf, parseOnePkgConf
) where
import Distribution.InstalledPackageInfo
import Distribution.Package
import Distribution.Version
import Data.Char ( isSpace, isAlpha, isAlphaNum, isUpper, isDigit )
import Data.List ( break )
}
%token
'{' { ITocurly }
'}' { ITccurly }
'[' { ITobrack }
']' { ITcbrack }
',' { ITcomma }
'=' { ITequal }
VARID { ITvarid $$ }
CONID { ITconid $$ }
STRING { ITstring $$ }
INT { ITinteger $$ }
%name parse pkgconf
%name parseOne pkg
%tokentype { Token }
%%
pkgconf :: { [ PackageConfig ] }
: '[' ']' { [] }
| '[' pkgs ']' { reverse $2 }
pkgs :: { [ PackageConfig ] }
: pkg { [ $1 ] }
| pkgs ',' pkg { $3 : $1 }
pkg :: { PackageConfig }
: CONID '{' fields '}' { $3 defaultPackageConfig }
fields :: { PackageConfig -> PackageConfig }
: field { \p -> $1 p }
| fields ',' field { \p -> $1 ($3 p) }
field :: { PackageConfig -> PackageConfig }
: VARID '=' pkgid
{\p -> case $1 of
"package" -> p {package = $3}
_ -> error "unknown key in config file" }
| VARID '=' STRING { id }
-- we aren't interested in the string fields, they're all
-- boring (copyright, maintainer etc.)
| VARID '=' CONID
{ case $1 of {
"exposed" ->
case $3 of {
"True" -> (\p -> p {exposed=True});
"False" -> (\p -> p {exposed=False});
_ -> error "exposed must be either True or False" };
"license" -> id; -- not interested
_ -> error "unknown constructor" }
}
| VARID '=' CONID STRING { id }
-- another case of license
| VARID '=' strlist
{\p -> case $1 of
"exposedModules" -> p{exposedModules = $3}
"hiddenModules" -> p{hiddenModules = $3}
"importDirs" -> p{importDirs = $3}
"libraryDirs" -> p{libraryDirs = $3}
"hsLibraries" -> p{hsLibraries = $3}
"extraLibraries" -> p{extraLibraries = $3}
"includeDirs" -> p{includeDirs = $3}
"includes" -> p{includes = $3}
"hugsOptions" -> p{hugsOptions = $3}
"ccOptions" -> p{ccOptions = $3}
"ldOptions" -> p{ldOptions = $3}
"frameworkDirs" -> p{frameworkDirs = $3}
"frameworks" -> p{frameworks = $3}
"haddockInterfaces" -> p{haddockInterfaces = $3}
"haddockHTMLs" -> p{haddockHTMLs = $3}
"depends" -> p{depends = []}
-- empty list only, non-empty handled below
other -> p
}
| VARID '=' pkgidlist
{ case $1 of
"depends" -> (\p -> p{depends = $3})
_other -> error "unknown key in config file"
}
pkgid :: { PackageIdentifier }
: CONID '{' VARID '=' STRING ',' VARID '=' version '}'
{ PackageIdentifier{ pkgName = $5,
pkgVersion = $9 } }
version :: { Version }
: CONID '{' VARID '=' intlist ',' VARID '=' strlist '}'
{ Version{ versionBranch=$5, versionTags=$9 } }
pkgidlist :: { [PackageIdentifier] }
: '[' pkgids ']' { $2 }
-- empty list case is covered by strlist, to avoid conflicts
pkgids :: { [PackageIdentifier] }
: pkgid { [ $1 ] }
| pkgid ',' pkgids { $1 : $3 }
intlist :: { [Int] }
: '[' ']' { [] }
| '[' ints ']' { $2 }
ints :: { [Int] }
: INT { [ fromIntegral $1 ] }
| INT ',' ints { fromIntegral $1 : $3 }
strlist :: { [String] }
: '[' ']' { [] }
| '[' strs ']' { reverse $2 }
strs :: { [String] }
: STRING { [ $1 ] }
| strs ',' STRING { $3 : $1 }
{
type PackageConfig = InstalledPackageInfo
defaultPackageConfig = emptyInstalledPackageInfo
data Token
= ITocurly
| ITccurly
| ITobrack
| ITcbrack
| ITcomma
| ITequal
| ITvarid String
| ITconid String
| ITstring String
| ITinteger Int
lexer :: String -> [Token]
lexer [] = []
lexer ('{':cs) = ITocurly : lexer cs
lexer ('}':cs) = ITccurly : lexer cs
lexer ('[':cs) = ITobrack : lexer cs
lexer (']':cs) = ITcbrack : lexer cs
lexer (',':cs) = ITcomma : lexer cs
lexer ('=':cs) = ITequal : lexer cs
lexer ('"':cs) = lexString cs ""
lexer (c:cs)
| isSpace c = lexer cs
| isAlpha c = lexID (c:cs)
| isDigit c = lexInt (c:cs)
lexer _ = error ( "Unexpected token")
lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest
where
(id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs
lexInt cs = let (intStr, rest) = span isDigit cs
in ITinteger (read intStr) : lexer rest
lexString ('"':cs) s = ITstring (reverse s) : lexer cs
lexString ('\\':c:cs) s = lexString cs (c:s)
lexString (c:cs) s = lexString cs (c:s)
happyError _ = error "Couldn't parse package configuration."
parsePkgConf :: String -> [PackageConfig]
parsePkgConf = parse . lexer
parseOnePkgConf :: String -> PackageConfig
parseOnePkgConf = parseOne . lexer
}

616
src/System/Plugins/ParsePkgConfLite.hs
View File

@ -1,616 +0,0 @@
{-# OPTIONS -fglasgow-exts -cpp #-}
{-# OPTIONS -w #-}
module System.Plugins.ParsePkgConfLite (
parsePkgConf, parseOnePkgConf
) where
import System.Plugins.Package ( PackageConfig(..), defaultPackageConfig )
import Char ( isSpace, isAlpha, isAlphaNum, isUpper )
import List ( break )
import Array
#if __GLASGOW_HASKELL__ >= 503
import GHC.Exts
#else
import GlaExts
#endif
-- parser produced by Happy Version 1.15
newtype HappyAbsSyn = HappyAbsSyn (() -> ())
happyIn5 :: ([ PackageConfig ]) -> (HappyAbsSyn )
happyIn5 x = unsafeCoerce# x
{-# INLINE happyIn5 #-}
happyOut5 :: (HappyAbsSyn ) -> ([ PackageConfig ])
happyOut5 x = unsafeCoerce# x
{-# INLINE happyOut5 #-}
happyIn6 :: ([ PackageConfig ]) -> (HappyAbsSyn )
happyIn6 x = unsafeCoerce# x
{-# INLINE happyIn6 #-}
happyOut6 :: (HappyAbsSyn ) -> ([ PackageConfig ])
happyOut6 x = unsafeCoerce# x
{-# INLINE happyOut6 #-}
happyIn7 :: (PackageConfig) -> (HappyAbsSyn )
happyIn7 x = unsafeCoerce# x
{-# INLINE happyIn7 #-}
happyOut7 :: (HappyAbsSyn ) -> (PackageConfig)
happyOut7 x = unsafeCoerce# x
{-# INLINE happyOut7 #-}
happyIn8 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn )
happyIn8 x = unsafeCoerce# x
{-# INLINE happyIn8 #-}
happyOut8 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig)
happyOut8 x = unsafeCoerce# x
{-# INLINE happyOut8 #-}
happyIn9 :: (PackageConfig -> PackageConfig) -> (HappyAbsSyn )
happyIn9 x = unsafeCoerce# x
{-# INLINE happyIn9 #-}
happyOut9 :: (HappyAbsSyn ) -> (PackageConfig -> PackageConfig)
happyOut9 x = unsafeCoerce# x
{-# INLINE happyOut9 #-}
happyIn10 :: ([String]) -> (HappyAbsSyn )
happyIn10 x = unsafeCoerce# x
{-# INLINE happyIn10 #-}
happyOut10 :: (HappyAbsSyn ) -> ([String])
happyOut10 x = unsafeCoerce# x
{-# INLINE happyOut10 #-}
happyIn11 :: ([String]) -> (HappyAbsSyn )
happyIn11 x = unsafeCoerce# x
{-# INLINE happyIn11 #-}
happyOut11 :: (HappyAbsSyn ) -> ([String])
happyOut11 x = unsafeCoerce# x
{-# INLINE happyOut11 #-}
happyIn12 :: (Bool) -> (HappyAbsSyn )
happyIn12 x = unsafeCoerce# x
{-# INLINE happyIn12 #-}
happyOut12 :: (HappyAbsSyn ) -> (Bool)
happyOut12 x = unsafeCoerce# x
{-# INLINE happyOut12 #-}
happyInTok :: Token -> (HappyAbsSyn )
happyInTok x = unsafeCoerce# x
{-# INLINE happyInTok #-}
happyOutTok :: (HappyAbsSyn ) -> Token
happyOutTok x = unsafeCoerce# x
{-# INLINE happyOutTok #-}
happyActOffsets :: HappyAddr
happyActOffsets = HappyA# "\x1f\x00\x1e\x00\x1d\x00\x1b\x00\x1a\x00\x1c\x00\x19\x00\x01\x00\x0e\x00\x00\x00\x00\x00\x17\x00\x08\x00\x00\x00\x16\x00\x00\x00\x13\x00\x00\x00\xfe\xff\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x11\x00\x00\x00\x00\x00"#
happyGotoOffsets :: HappyAddr
happyGotoOffsets = HappyA# "\x18\x00\x15\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x14\x00\x00\x00\xfd\xff\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"#
happyDefActions :: HappyAddr
happyDefActions = HappyA# "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\xfd\xff\x00\x00\x00\x00\xf8\xff\x00\x00\xfc\xff\x00\x00\xfa\xff\x00\x00\xf9\xff\x00\x00\xf7\xff\xf4\xff\xf5\xff\x00\x00\xef\xff\xf6\xff\x00\x00\xf3\xff\xf1\xff\xf2\xff\x00\x00\xf0\xff"#
happyCheck :: HappyAddr
happyCheck = HappyA# "\xff\xff\x03\x00\x05\x00\x04\x00\x07\x00\x04\x00\x08\x00\x09\x00\x09\x00\x08\x00\x02\x00\x01\x00\x02\x00\x05\x00\x03\x00\x04\x00\x04\x00\x05\x00\x04\x00\x05\x00\x04\x00\x06\x00\x02\x00\x02\x00\x00\x00\x07\x00\x09\x00\x08\x00\x06\x00\x01\x00\x07\x00\x04\x00\x03\x00\xff\xff\x03\x00\x0a\x00\x0a\x00\xff\xff\x08\x00\xff\xff\xff\xff\xff\xff"#
happyTable :: HappyAddr
happyTable = HappyA# "\x00\x00\x19\x00\x16\x00\x1d\x00\x17\x00\x0b\x00\x1a\x00\x1b\x00\x1e\x00\x06\x00\x14\x00\x08\x00\x09\x00\x15\x00\x0c\x00\x0d\x00\x1f\x00\x20\x00\x10\x00\x11\x00\x15\x00\x1b\x00\x11\x00\x04\x00\x06\x00\x0f\x00\x21\x00\x06\x00\x13\x00\x0c\x00\x0f\x00\x0b\x00\x04\x00\x00\x00\x08\x00\xff\xff\xff\xff\x00\x00\x06\x00\x00\x00\x00\x00\x00\x00"#
happyReduceArr = array (2, 16) [
(2 , happyReduce_2),
(3 , happyReduce_3),
(4 , happyReduce_4),
(5 , happyReduce_5),
(6 , happyReduce_6),
(7 , happyReduce_7),
(8 , happyReduce_8),
(9 , happyReduce_9),
(10 , happyReduce_10),
(11 , happyReduce_11),
(12 , happyReduce_12),
(13 , happyReduce_13),
(14 , happyReduce_14),
(15 , happyReduce_15),
(16 , happyReduce_16)
]
happy_n_terms = 11 :: Int
happy_n_nonterms = 8 :: Int
happyReduce_2 = happySpecReduce_2 0# happyReduction_2
happyReduction_2 happy_x_2
happy_x_1
= happyIn5
([]
)
happyReduce_3 = happySpecReduce_3 0# happyReduction_3
happyReduction_3 happy_x_3
happy_x_2
happy_x_1
= case happyOut6 happy_x_2 of { happy_var_2 ->
happyIn5
(reverse happy_var_2
)}
happyReduce_4 = happySpecReduce_1 1# happyReduction_4
happyReduction_4 happy_x_1
= case happyOut7 happy_x_1 of { happy_var_1 ->
happyIn6
([ happy_var_1 ]
)}
happyReduce_5 = happySpecReduce_3 1# happyReduction_5
happyReduction_5 happy_x_3
happy_x_2
happy_x_1
= case happyOut6 happy_x_1 of { happy_var_1 ->
case happyOut7 happy_x_3 of { happy_var_3 ->
happyIn6
(happy_var_3 : happy_var_1
)}}
happyReduce_6 = happyReduce 4# 2# happyReduction_6
happyReduction_6 (happy_x_4 `HappyStk`
happy_x_3 `HappyStk`
happy_x_2 `HappyStk`
happy_x_1 `HappyStk`
happyRest)
= case happyOut8 happy_x_3 of { happy_var_3 ->
happyIn7
(happy_var_3 defaultPackageConfig
) `HappyStk` happyRest}
happyReduce_7 = happySpecReduce_1 3# happyReduction_7
happyReduction_7 happy_x_1
= case happyOut9 happy_x_1 of { happy_var_1 ->
happyIn8
(\p -> happy_var_1 p
)}
happyReduce_8 = happySpecReduce_3 3# happyReduction_8
happyReduction_8 happy_x_3
happy_x_2
happy_x_1
= case happyOut8 happy_x_1 of { happy_var_1 ->
case happyOut9 happy_x_3 of { happy_var_3 ->
happyIn8
(\p -> happy_var_1 (happy_var_3 p)
)}}
happyReduce_9 = happySpecReduce_3 4# happyReduction_9
happyReduction_9 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (ITvarid happy_var_1) ->
case happyOutTok happy_x_3 of { (ITstring happy_var_3) ->
happyIn9
(\p -> case happy_var_1 of
"name" -> p{name = happy_var_3}
_ -> error "unknown key in config file"
)}}
happyReduce_10 = happySpecReduce_3 4# happyReduction_10
happyReduction_10 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (ITvarid happy_var_1) ->
case happyOut12 happy_x_3 of { happy_var_3 ->
happyIn9
(\p -> case happy_var_1 of {
"auto" -> p{auto = happy_var_3};
_ -> p }
)}}
happyReduce_11 = happySpecReduce_3 4# happyReduction_11
happyReduction_11 happy_x_3
happy_x_2
happy_x_1
= case happyOutTok happy_x_1 of { (ITvarid happy_var_1) ->
case happyOut10 happy_x_3 of { happy_var_3 ->
happyIn9
(\p -> case happy_var_1 of
"import_dirs" -> p{import_dirs = happy_var_3}
"library_dirs" -> p{library_dirs = happy_var_3}
"hs_libraries" -> p{hs_libraries = happy_var_3}
"extra_libraries" -> p{extra_libraries = happy_var_3}
"include_dirs" -> p{include_dirs = happy_var_3}
"c_includes" -> p{c_includes = happy_var_3}
"package_deps" -> p{package_deps = happy_var_3}
"extra_ghc_opts" -> p{extra_ghc_opts = happy_var_3}
"extra_cc_opts" -> p{extra_cc_opts = happy_var_3}
"extra_ld_opts" -> p{extra_ld_opts = happy_var_3}
"framework_dirs" -> p{framework_dirs = happy_var_3}
"extra_frameworks"-> p{extra_frameworks= happy_var_3}
_other -> p
)}}
happyReduce_12 = happySpecReduce_2 5# happyReduction_12
happyReduction_12 happy_x_2
happy_x_1
= happyIn10
([]
)
happyReduce_13 = happySpecReduce_3 5# happyReduction_13
happyReduction_13 happy_x_3
happy_x_2
happy_x_1
= case happyOut11 happy_x_2 of { happy_var_2 ->
happyIn10
(reverse happy_var_2
)}
happyReduce_14 = happySpecReduce_1 6# happyReduction_14
happyReduction_14 happy_x_1
= case happyOutTok happy_x_1 of { (ITstring happy_var_1) ->
happyIn11
([ happy_var_1 ]
)}
happyReduce_15 = happySpecReduce_3 6# happyReduction_15
happyReduction_15 happy_x_3
happy_x_2
happy_x_1
= case happyOut11 happy_x_1 of { happy_var_1 ->
case happyOutTok happy_x_3 of { (ITstring happy_var_3) ->
happyIn11
(happy_var_3 : happy_var_1
)}}
happyReduce_16 = happySpecReduce_1 7# happyReduction_16
happyReduction_16 happy_x_1
= case happyOutTok happy_x_1 of { (ITconid happy_var_1) ->
happyIn12
( case happy_var_1 of {
"True" -> True;
"False" -> False;
_ -> error ("unknown constructor in config file: " ++ happy_var_1) }
)}
happyNewToken action sts stk [] =
happyDoAction 10# (error "reading EOF!") action sts stk []
happyNewToken action sts stk (tk:tks) =
let cont i = happyDoAction i tk action sts stk tks in
case tk of {
ITocurly -> cont 1#;
ITccurly -> cont 2#;
ITobrack -> cont 3#;
ITcbrack -> cont 4#;
ITcomma -> cont 5#;
ITequal -> cont 6#;
ITvarid happy_dollar_dollar -> cont 7#;
ITconid happy_dollar_dollar -> cont 8#;
ITstring happy_dollar_dollar -> cont 9#;
_ -> happyError' (tk:tks)
}
happyError_ tk tks = happyError' (tk:tks)
newtype HappyIdentity a = HappyIdentity a
happyIdentity = HappyIdentity
happyRunIdentity (HappyIdentity a) = a
instance Monad HappyIdentity where
return = HappyIdentity
(HappyIdentity p) >>= q = q p
happyThen :: () => HappyIdentity a -> (a -> HappyIdentity b) -> HappyIdentity b
happyThen = (>>=)
happyReturn :: () => a -> HappyIdentity a
happyReturn = (return)
happyThen1 m k tks = (>>=) m (\a -> k a tks)
happyReturn1 :: () => a -> b -> HappyIdentity a
happyReturn1 = \a tks -> (return) a
happyError' :: () => [Token] -> HappyIdentity a
happyError' = HappyIdentity . happyError
parse tks = happyRunIdentity happySomeParser where
happySomeParser = happyThen (happyParse 0# tks) (\x -> happyReturn (happyOut5 x))
parseOne tks = happyRunIdentity happySomeParser where
happySomeParser = happyThen (happyParse 1# tks) (\x -> happyReturn (happyOut7 x))
happySeq = happyDontSeq
data Token
= ITocurly
| ITccurly
| ITobrack
| ITcbrack
| ITcomma
| ITequal
| ITvarid String
| ITconid String
| ITstring String
lexer :: String -> [Token]
lexer [] = []
lexer ('{':cs) = ITocurly : lexer cs
lexer ('}':cs) = ITccurly : lexer cs
lexer ('[':cs) = ITobrack : lexer cs
lexer (']':cs) = ITcbrack : lexer cs
lexer (',':cs) = ITcomma : lexer cs
lexer ('=':cs) = ITequal : lexer cs
lexer ('"':cs) = lexString cs ""
lexer (c:cs)
| isSpace c = lexer cs
| isAlpha c = lexID (c:cs) where
lexer _ = error "Unexpected token"
lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest
where
(id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs
lexString ('"':cs) s = ITstring (reverse s) : lexer cs
lexString ('\\':c:cs) s = lexString cs (c:s)
lexString (c:cs) s = lexString cs (c:s)
happyError _ = error "Couldn't parse package configuration."
parsePkgConf :: String -> [PackageConfig]
parsePkgConf = parse . lexer
parseOnePkgConf :: String -> PackageConfig
parseOnePkgConf = parseOne . lexer
{-# LINE 1 "GenericTemplate.hs" #-}
{-# LINE 1 "<built-in>" #-}
{-# LINE 1 "<command line>" #-}
{-# LINE 1 "GenericTemplate.hs" #-}
-- $Id$
{-# LINE 28 "GenericTemplate.hs" #-}
data Happy_IntList = HappyCons Int# Happy_IntList
{-# LINE 49 "GenericTemplate.hs" #-}
{-# LINE 59 "GenericTemplate.hs" #-}
infixr 9 `HappyStk`
data HappyStk a = HappyStk a (HappyStk a)
-----------------------------------------------------------------------------
-- starting the parse
happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
-----------------------------------------------------------------------------
-- Accepting the parse
-- If the current token is 0#, it means we've just accepted a partial
-- parse (a %partial parser). We must ignore the saved token on the top of
-- the stack in this case.
happyAccept 0# tk st sts (_ `HappyStk` ans `HappyStk` _) =
happyReturn1 ans
happyAccept j tk st sts (HappyStk ans _) =
(happyTcHack j (happyTcHack st)) (happyReturn1 ans)
-----------------------------------------------------------------------------
-- Arrays only: do the next action
happyDoAction i tk st
= {- nothing -}
case action of
0# -> {- nothing -}
happyFail i tk st
-1# -> {- nothing -}
happyAccept i tk st
n | (n <# (0# :: Int#)) -> {- nothing -}
(happyReduceArr ! rule) i tk st
where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))
n -> {- nothing -}
happyShift new_state i tk st
where new_state = (n -# (1# :: Int#))
where off = indexShortOffAddr happyActOffsets st
off_i = (off +# i)
check = if (off_i >=# (0# :: Int#))
then (indexShortOffAddr happyCheck off_i ==# i)
else False
action | check = indexShortOffAddr happyTable off_i
| otherwise = indexShortOffAddr happyDefActions st
indexShortOffAddr (HappyA# arr) off =
#if __GLASGOW_HASKELL__ > 500
narrow16Int# i
#elif __GLASGOW_HASKELL__ == 500
intToInt16# i
#else
(i `iShiftL#` 16#) `iShiftRA#` 16#
#endif
where
#if __GLASGOW_HASKELL__ >= 503
i = word2Int# ((high `uncheckedShiftL#` 8#) `or#` low)
#else
i = word2Int# ((high `shiftL#` 8#) `or#` low)
#endif
high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
low = int2Word# (ord# (indexCharOffAddr# arr off'))
off' = off *# 2#
data HappyAddr = HappyA# Addr#
-----------------------------------------------------------------------------
-- HappyState data type (not arrays)
{-# LINE 170 "GenericTemplate.hs" #-}
-----------------------------------------------------------------------------
-- Shifting a token
happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
let i = (case unsafeCoerce# x of { (I# (i)) -> i }) in
-- trace "shifting the error token" $
happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
happyShift new_state i tk st sts stk =
happyNewToken new_state (HappyCons (st) (sts)) ((happyInTok (tk))`HappyStk`stk)
-- happyReduce is specialised for the common cases.
happySpecReduce_0 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_0 nt fn j tk st@((action)) sts stk
= happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
happySpecReduce_1 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
= let r = fn v1 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_2 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
= let r = fn v1 v2 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happySpecReduce_3 i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
= let r = fn v1 v2 v3 in
happySeq r (happyGoto nt j tk st sts (r `HappyStk` stk'))
happyReduce k i fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happyReduce k nt fn j tk st sts stk
= case happyDrop (k -# (1# :: Int#)) sts of
sts1@((HappyCons (st1@(action)) (_))) ->
let r = fn stk in -- it doesn't hurt to always seq here...
happyDoSeq r (happyGoto nt j tk st1 sts1 r)
happyMonadReduce k nt fn 0# tk st sts stk
= happyFail 0# tk st sts stk
happyMonadReduce k nt fn j tk st sts stk =
happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
drop_stk = happyDropStk k stk
happyDrop 0# l = l
happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
happyDropStk 0# l = l
happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
-----------------------------------------------------------------------------
-- Moving to a new state after a reduction
happyGoto nt j tk st =
{- nothing -}
happyDoAction j tk new_state
where off = indexShortOffAddr happyGotoOffsets st
off_i = (off +# nt)
new_state = indexShortOffAddr happyTable off_i
-----------------------------------------------------------------------------
-- Error recovery (0# is the error token)
-- parse error if we are in recovery and we fail again
happyFail 0# tk old_st _ stk =
-- trace "failing" $
happyError_ tk
{- We don't need state discarding for our restricted implementation of
"error". In fact, it can cause some bogus parses, so I've disabled it
for now --SDM
-- discard a state
happyFail 0# tk old_st (HappyCons ((action)) (sts))
(saved_tok `HappyStk` _ `HappyStk` stk) =
-- trace ("discarding state, depth " ++ show (length stk)) $
happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
-}
-- Enter error recovery: generate an error token,
-- save the old token and carry on.
happyFail i tk (action) sts stk =
-- trace "entering error recovery" $
happyDoAction 0# tk action sts ( (unsafeCoerce# (I# (i))) `HappyStk` stk)
-- Internal happy errors:
notHappyAtAll = error "Internal Happy error\n"
-----------------------------------------------------------------------------
-- Hack to get the typechecker to accept our action functions
happyTcHack :: Int# -> a -> a
happyTcHack x y = y
{-# INLINE happyTcHack #-}
-----------------------------------------------------------------------------
-- Seq-ing. If the --strict flag is given, then Happy emits
-- happySeq = happyDoSeq
-- otherwise it emits
-- happySeq = happyDontSeq
happyDoSeq, happyDontSeq :: a -> b -> b
happyDoSeq a b = a `seq` b
happyDontSeq a b = b
-----------------------------------------------------------------------------
-- Don't inline any functions from the template. GHC has a nasty habit
-- of deciding to inline happyGoto everywhere, which increases the size of
-- the generated parser quite a bit.
{-# NOINLINE happyDoAction #-}
{-# NOINLINE happyTable #-}
{-# NOINLINE happyCheck #-}
{-# NOINLINE happyActOffsets #-}
{-# NOINLINE happyGotoOffsets #-}
{-# NOINLINE happyDefActions #-}
{-# NOINLINE happyShift #-}
{-# NOINLINE happySpecReduce_0 #-}
{-# NOINLINE happySpecReduce_1 #-}
{-# NOINLINE happySpecReduce_2 #-}
{-# NOINLINE happySpecReduce_3 #-}
{-# NOINLINE happyReduce #-}
{-# NOINLINE happyMonadReduce #-}
{-# NOINLINE happyGoto #-}
{-# NOINLINE happyFail #-}
-- end of Happy Template.

159
src/System/Plugins/ParsePkgConfLite.y
View File

@ -1,159 +0,0 @@
--
-- Copyright (C) 2004 Sean Seefried - http://www.cse.unsw.edu.au/~sseefried
--
-- 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
--
--
-- Taken (apart from the most minor of alterations) from
-- ghc/utils/ghc-pkg/ParsePkgConfLite.hs:
--
-- (c) Copyright 2002, The University Court of the University of Glasgow.
--
{
{-# OPTIONS -w #-}
module System.Plugins.ParsePkgConfLite (
parsePkgConf, parseOnePkgConf
) where
import System.Plugins.Package ( PackageConfig(..), defaultPackageConfig )
import Char ( isSpace, isAlpha, isAlphaNum, isUpper )
import List ( break )
}
%token
'{' { ITocurly }
'}' { ITccurly }
'[' { ITobrack }
']' { ITcbrack }
',' { ITcomma }
'=' { ITequal }
VARID { ITvarid $$ }
CONID { ITconid $$ }
STRING { ITstring $$ }
%name parse pkgconf
%name parseOne pkg
%tokentype { Token }
%%
pkgconf :: { [ PackageConfig ] }
: '[' ']' { [] }
| '[' pkgs ']' { reverse $2 }
pkgs :: { [ PackageConfig ] }
: pkg { [ $1 ] }
| pkgs ',' pkg { $3 : $1 }
pkg :: { PackageConfig }
: CONID '{' fields '}' { $3 defaultPackageConfig }
fields :: { PackageConfig -> PackageConfig }
: field { \p -> $1 p }
| fields ',' field { \p -> $1 ($3 p) }
field :: { PackageConfig -> PackageConfig }
: VARID '=' STRING
{\p -> case $1 of
"name" -> p{name = $3}
_ -> error "unknown key in config file" }
| VARID '=' bool
{\p -> case $1 of {
"auto" -> p{auto = $3};
_ -> p } }
| VARID '=' strlist
{\p -> case $1 of
"import_dirs" -> p{import_dirs = $3}
"library_dirs" -> p{library_dirs = $3}
"hs_libraries" -> p{hs_libraries = $3}
"extra_libraries" -> p{extra_libraries = $3}
"include_dirs" -> p{include_dirs = $3}
"c_includes" -> p{c_includes = $3}
"package_deps" -> p{package_deps = $3}
"extra_ghc_opts" -> p{extra_ghc_opts = $3}
"extra_cc_opts" -> p{extra_cc_opts = $3}
"extra_ld_opts" -> p{extra_ld_opts = $3}
"framework_dirs" -> p{framework_dirs = $3}
"extra_frameworks"-> p{extra_frameworks= $3}
_other -> p
}
strlist :: { [String] }
: '[' ']' { [] }
| '[' strs ']' { reverse $2 }
strs :: { [String] }
: STRING { [ $1 ] }
| strs ',' STRING { $3 : $1 }
bool :: { Bool }
: CONID {% case $1 of {
"True" -> True;
"False" -> False;
_ -> error ("unknown constructor in config file: " ++ $1) } }
{
data Token
= ITocurly
| ITccurly
| ITobrack
| ITcbrack
| ITcomma
| ITequal
| ITvarid String
| ITconid String
| ITstring String
lexer :: String -> [Token]
lexer [] = []
lexer ('{':cs) = ITocurly : lexer cs
lexer ('}':cs) = ITccurly : lexer cs
lexer ('[':cs) = ITobrack : lexer cs
lexer (']':cs) = ITcbrack : lexer cs
lexer (',':cs) = ITcomma : lexer cs
lexer ('=':cs) = ITequal : lexer cs
lexer ('"':cs) = lexString cs ""
lexer (c:cs)
| isSpace c = lexer cs
| isAlpha c = lexID (c:cs) where
lexer _ = error "Unexpected token"
lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest
where
(id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs
lexString ('"':cs) s = ITstring (reverse s) : lexer cs
lexString ('\\':c:cs) s = lexString cs (c:s)
lexString (c:cs) s = lexString cs (c:s)
happyError _ = error "Couldn't parse package configuration."
parsePkgConf :: String -> [PackageConfig]
parsePkgConf = parse . lexer
parseOnePkgConf :: String -> PackageConfig
parseOnePkgConf = parseOne . lexer
}

239
src/System/Plugins/Parser.hs
View File

@ -1,239 +0,0 @@
{-# OPTIONS -cpp -fglasgow-exts #-}
--
-- Copyright (C) 2004 Don Stewart - http://www.cse.unsw.edu.au/~dons
--
-- This program is free software; you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation; either version 2 of
-- the License, or (at your option) any later version.
--
-- This program 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
-- General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; if not, write to the Free Software
-- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
-- 02111-1307, USA.
--
module System.Plugins.Parser (
parse, mergeModules, pretty, parsePragmas,
HsModule(..) ,
replaceModName
) where
#include "../../../config.h"
import Data.List
import Data.Char
import Data.Either
#if defined(WITH_HSX)
import Language.Haskell.Hsx
#else
import Language.Haskell.Parser
import Language.Haskell.Syntax
import Language.Haskell.Pretty
#endif
--
-- | parse a file (as a string) as Haskell src
--
parse :: FilePath -- ^ module name
-> String -- ^ haskell src
-> Either String HsModule -- ^ abstract syntax
parse f fsrc =
#if defined(WITH_HSX)
case parseFileContentsWithMode (ParseMode f) fsrc of
#else
case parseModuleWithMode (ParseMode f) fsrc of
#endif
ParseOk src -> Right src
ParseFailed loc _ -> Left $ srcmsg loc
where
srcmsg loc = "parse error in " ++ f ++ "\n" ++
"line: " ++ (show $ srcLine loc) ++
", col: " ++ (show $ srcColumn loc)++ "\n"
--
-- | pretty print haskell src
--
-- doesn't handle operators with '#' at the end. i.e. unsafeCoerce#
--
pretty :: HsModule -> String
pretty code = prettyPrintWithMode (defaultMode { linePragmas = True }) code
-- |
-- mergeModules : generate a full Haskell src file, give a .hs config
-- file, and a stub to take default syntax and decls from. Mostly we
-- just ensure they don't do anything bad, and that the names are
-- correct for the module.
--
-- Transformations:
--
-- * Take src location pragmas from the conf file (1st file)
-- * Use the template's (2nd argument) module name
-- * Only use export list from template (2nd arg)
-- * Merge top-level decls
-- * need to force the type of the plugin to match the stub,
-- overwriting any type they supply.
--
mergeModules :: HsModule -> -- ^ Configure module
HsModule -> -- ^ Template module
HsModule -- ^ A merge of the two
mergeModules (HsModule l _ _ is ds )
(HsModule _ m' es' is' ds')
= (HsModule l m' es'
(mImps m' is is')
(mDecl ds ds') )
--
-- replace Module name with String.
--
replaceModName :: HsModule -> String -> HsModule
replaceModName (HsModule l _ es is ds) nm = (HsModule l (Module nm) es is ds)
--
-- | merge import declarations:
--
-- * ensure that the config file doesn't import the stub name
-- * merge import lists uniquely, and when they match, merge their decls
--
-- TODO : we don't merge imports of the same module from both files.
-- We should, and then merge the decls in their import list
-- ** rename args, too confusing.
--
-- quick fix: strip all type signatures from the source.
--
mImps :: Module -> -- ^ plugin module name
[HsImportDecl] -> -- ^ conf file imports
[HsImportDecl] -> -- ^ stub file imports
[HsImportDecl]
mImps plug_mod cimps timps =
case filter (!~ self) cimps of cimps' -> unionBy (=~) cimps' timps
where
self = ( HsImportDecl undefined plug_mod undefined undefined undefined )
--
-- | merge top-level declarations
--
-- Remove decls found in template, using those from the config file.
-- Need to sort decls by types, then decls first, in both.
--
-- * could we write a pass to handle "editor, foo :: String" ?
--
-- we must keep the type from the template.
--
mDecl ds es = let ds' = filter (\t->not $ typeDecl t) ds -- rm type sigs from plugin
in sortBy decls $! unionBy (=~) ds' es
where
decls a b = compare (encoding a) (encoding b)
typeDecl :: HsDecl -> Bool
typeDecl (HsTypeSig _ _ _) = True
typeDecl _ = False
encoding :: HsDecl -> Int
encoding d = case d of
HsFunBind _ -> 1
HsPatBind _ _ _ _ -> 1
_ -> 0
--
-- syntactic equality over the useful Haskell abstract syntax
-- this may be extended if we try to merge the files more thoroughly
--
class SynEq a where
(=~) :: a -> a -> Bool
(!~) :: a -> a -> Bool
n !~ m = not (n =~ m)
instance SynEq HsDecl where
(HsPatBind _ (HsPVar n) _ _) =~ (HsPatBind _ (HsPVar m) _ _) = n == m
(HsTypeSig _ (n:_) _) =~ (HsTypeSig _ (m:_) _) = n == m
_ =~ _ = False
instance SynEq HsImportDecl where
(HsImportDecl _ m _ _ _) =~ (HsImportDecl _ n _ _ _) = n == m
--
-- | Parsing option pragmas.
--
-- This is not a type checker. If the user supplies bogus options,
-- they'll get slightly mystical error messages. Also, we *want* to
-- handle -package options, and other *static* flags. This is more than
-- GHC.
--
-- GHC user's guide :
-- "OPTIONS pragmas are only looked for at the top of your source
-- files, upto the first (non-literate,non-empty) line not
-- containing OPTIONS. Multiple OPTIONS pragmas are recognised."
--
-- based on getOptionsFromSource(), in main/DriverUtil.hs
--
parsePragmas :: String -- ^ input src
-> ([String],[String]) -- ^ normal options, global options
parsePragmas s = look $ lines s
where
look [] = ([],[])
look (l':ls) =
let l = remove_spaces l'
in case () of
() | null l -> look ls
| prefixMatch "#" l -> look ls
| prefixMatch "{-# LINE" l -> look ls
| Just (Option o) <- matchPragma l
-> let (as,bs) = look ls in (words o ++ as,bs)
| Just (Global g) <- matchPragma l
-> let (as,bs) = look ls in (as,words g ++ bs)
| otherwise -> ([],[])
--
-- based on main/DriverUtil.hs
--
-- extended to handle dynamic options too
--
data Pragma = Option !String | Global !String
matchPragma :: String -> Maybe Pragma
matchPragma s
| Just s1 <- maybePrefixMatch "{-#" s, -- -}
Just s2 <- maybePrefixMatch "OPTIONS" (remove_spaces s1),
Just s3 <- maybePrefixMatch "}-#" (reverse s2)
= Just (Option (reverse s3))
| Just s1 <- maybePrefixMatch "{-#" s, -- -}
Just s2 <- maybePrefixMatch "GLOBALOPTIONS" (remove_spaces s1),
Just s3 <- maybePrefixMatch "}-#" (reverse s2)
= Just (Global (reverse s3))
| otherwise
= Nothing
remove_spaces :: String -> String
remove_spaces = reverse . dropWhile isSpace . reverse . dropWhile isSpace
--
-- verbatim from utils/Utils.lhs
--
prefixMatch :: Eq a => [a] -> [a] -> Bool
prefixMatch [] _str = True
prefixMatch _pat [] = False
prefixMatch (p:ps) (s:ss) | p == s = prefixMatch ps ss
| otherwise = False
maybePrefixMatch :: String -> String -> Maybe String
maybePrefixMatch [] rest = Just rest
maybePrefixMatch (_:_) [] = Nothing
maybePrefixMatch (p:pat) (r:rest)
| p == r = maybePrefixMatch pat rest
| otherwise = Nothing

90
src/System/Plugins/Process.hs
View File

@ -1,90 +0,0 @@
{-# OPTIONS -cpp #-}
--
-- | A Posix.popen compatibility mapping.
--
-- If we use this, we should build -threaded
--
module System.Plugins.Process (exec, popen) where
import System.Exit
#if __GLASGOW_HASKELL__ >= 604
import System.IO
import System.Process
import Control.Concurrent (forkIO)
#else
import qualified Posix as P
#endif
import qualified Control.Exception
--
-- slight wrapper over popen for calls that don't care about stdin to the program
--
exec :: String -> [String] -> IO ([String],[String])
exec f as = do
(a,b,_) <- popen f as (Just [])
return (lines a, lines b)
#if __GLASGOW_HASKELL__ >= 604
type ProcessID = ProcessHandle
--
-- Ignoring exit status for now.
--
-- XXX there are still issues. Large amounts of output can cause what
-- seems to be a dead lock on the pipe write from runplugs, for example.
-- Posix.popen doesn't have this problem, so maybe we can reproduce its
-- pipe handling somehow.
--
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,ProcessID)
popen file args minput =
Control.Exception.handle (\e -> return ([],show e,error (show e))) $ do
(inp,out,err,pid) <- runInteractiveProcess file args Nothing Nothing
case minput of
Just input -> hPutStr inp input >> hClose inp -- importante!
Nothing -> return ()
-- Now, grab the input
output <- hGetContents out
errput <- hGetContents err
-- SimonM sez:
-- ... avoids blocking the main thread, but ensures that all the
-- data gets pulled as it becomes available. you have to force the
-- output strings before waiting for the process to terminate.
--
forkIO (Control.Exception.evaluate (length output) >> return ())
forkIO (Control.Exception.evaluate (length errput) >> return ())
-- And now we wait. We must wait after we read, unsurprisingly.
exitCode <- waitForProcess pid -- blocks without -threaded, you're warned.
case exitCode of
ExitFailure code
| null errput -> let errMsg = file ++ ": failed with error code " ++ show code
in return ([],errMsg,error errMsg)
_ -> return (output,errput,pid)
#else
--
-- catch so that we can deal with forkProcess failing gracefully. and
-- getProcessStatus is needed so as not to get a bunch of zombies,
-- leading to forkProcess failing.
--
-- Large amounts of input will cause problems with blocking as we wait
-- on the process to finish. Make sure no lambdabot processes will
-- generate 1000s of lines of output.
--
popen :: FilePath -> [String] -> Maybe String -> IO (String,String,P.ProcessID)
popen f s m =
Control.Exception.handle (\e -> return ([], show e, error $ show e )) $ do
x@(_,_,pid) <- P.popen f s m
b <- P.getProcessStatus True False pid -- wait
return $ case b of
Nothing -> ([], "process has disappeared", pid)
_ -> x
#endif

504
src/System/Plugins/Utils.hs
View File

@ -1,504 +0,0 @@
{-# OPTIONS -cpp #-}
--
-- 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
--
module System.Plugins.Utils (
Arg,
hWrite,
mkUnique,
hMkUnique,
mkUniqueIn,
hMkUniqueIn,
findFile,
mkTemp, mkTempIn, {- internal -}
replaceSuffix,
outFilePath,
dropSuffix,
mkModid,
changeFileExt,
joinFileExt,
splitFileExt,
isSublistOf, -- :: Eq a => [a] -> [a] -> Bool
dirname,
basename,
(</>), (<.>), (<+>), (<>),
newer,
encode,
decode,
EncodedString,
panic
) where
#include "../../../config.h"
import System.Plugins.Env ( isLoaded )
import System.Plugins.Consts ( objSuf, hiSuf, tmpDir )
import qualified System.MkTemp ( mkstemps )
import Data.Char
import Data.List
import System.IO
import System.Environment ( getEnv )
import System.Directory
-- ---------------------------------------------------------------------
-- some misc types we use
type Arg = String
-- ---------------------------------------------------------------------
-- | useful
--
panic s = ioError ( userError s )
-- ---------------------------------------------------------------------
-- | writeFile for Handles
--
hWrite :: Handle -> String -> IO ()
hWrite hdl src = hPutStr hdl src >> hClose hdl >> return ()
-- ---------------------------------------------------------------------
-- | mkstemps.
--
-- We use the Haskell version now... it is faster than calling into
-- mkstemps(3).
--
mkstemps :: String -> Int -> IO (String,Handle)
mkstemps path slen = do
m_v <- System.MkTemp.mkstemps path slen
case m_v of Nothing -> error "mkstemps : couldn't create temp file"
Just v' -> return v'
{-
mkstemps path slen = do
withCString path $ \ ptr -> do
let c_slen = fromIntegral $ slen+1
fd <- throwErrnoIfMinus1 "mkstemps" $ c_mkstemps ptr c_slen
name <- peekCString ptr
hdl <- fdToHandle fd
return (name, hdl)
foreign import ccall unsafe "mkstemps" c_mkstemps :: CString -> CInt -> IO Fd
-}
-- ---------------------------------------------------------------------
-- | create a new temp file, returning name and handle.
-- bit like the mktemp shell utility
--
mkTemp :: IO (String,Handle)
mkTemp = do tmpd <- catch (getEnv "TMPDIR") (\_ -> return tmpDir)
mkTempIn tmpd
mkTempIn :: String -> IO (String, Handle)
mkTempIn tmpd = do
(tmpf,hdl) <- mkstemps (tmpd++"/MXXXXXXXXX.hs") 3
let modname = mkModid $ dropSuffix tmpf
if and $ map (\c -> isAlphaNum c && c /= '_') modname
then return (tmpf,hdl)
else panic $ "Illegal characters in temp file: `"++tmpf++"'"
-- ---------------------------------------------------------------------
-- | Get a new temp file, unique from those in /tmp, and from those
-- modules already loaded. Very nice for merge/eval uses.
--
-- Will run for a long time if we can't create a temp file, luckily
-- mkstemps gives us a pretty big search space
--
mkUnique :: IO FilePath
mkUnique = do (t,h) <- hMkUnique
hClose h >> return t
hMkUnique :: IO (FilePath,Handle)
hMkUnique = do (t,h) <- mkTemp
alreadyLoaded <- isLoaded t -- not unique!
if alreadyLoaded
then hClose h >> removeFile t >> hMkUnique
else return (t,h)
mkUniqueIn :: FilePath -> IO FilePath
mkUniqueIn dir = do (t,h) <- hMkUniqueIn dir
hClose h >> return t
hMkUniqueIn :: FilePath -> IO (FilePath,Handle)
hMkUniqueIn dir = do (t,h) <- mkTempIn dir
alreadyLoaded <- isLoaded t -- not unique!
if alreadyLoaded
then hClose h >> removeFile t >> hMkUniqueIn dir
else return (t,h)
findFile :: [String] -> FilePath -> IO (Maybe FilePath)
findFile [] _ = return Nothing
findFile (ext:exts) file
= do let l = changeFileExt file ext
b <- doesFileExist l
if b then return $ Just l
else findFile exts file
-- ---------------------------------------------------------------------
-- some filename manipulation stuff
--
-- | </>, <.> : join two path components
--
infixr 6 </>
infixr 6 <.>
(</>), (<.>), (<+>), (<>) :: FilePath -> FilePath -> FilePath
[] </> b = b
a </> b = a ++ "/" ++ b
[] <.> b = b
a <.> b = a ++ "." ++ b
[] <+> b = b
a <+> b = a ++ " " ++ b
[] <> b = b
a <> b = a ++ b
--
-- | dirname : return the directory portion of a file path
-- if null, return "."
--
dirname :: FilePath -> FilePath
dirname p =
let x = findIndices (== '\\') p
y = findIndices (== '/') p
in
if not $ null x
then if not $ null y
then if (maximum x) > (maximum y) then dirname' '\\' p else dirname' '/' p
else dirname' '\\' p
else dirname' '/' p
where
dirname' chara pa =
case reverse $ dropWhile (/= chara) $ reverse pa of
[] -> "."
pa' -> pa'
--
-- | basename : return the filename portion of a path
--
basename :: FilePath -> FilePath
basename p =
let x = findIndices (== '\\') p
y = findIndices (== '/') p
in
if not $ null x
then if not $ null y
then if (maximum x) > (maximum y) then basename' '\\' p else basename' '/' p
else basename' '\\' p
else basename' '/' p
where
basename' chara pa = reverse $ takeWhile (/= chara) $ reverse pa
--
-- drop suffix
--
dropSuffix :: FilePath -> FilePath
dropSuffix f = reverse . tail . dropWhile (/= '.') $ reverse f
--
-- | work out the mod name from a filepath
mkModid :: String -> String
mkModid = (takeWhile (/= '.')) . reverse . (takeWhile (\x -> ('/'/= x) && ('\\' /= x))) . reverse
-----------------------------------------------------------
-- Code from Cabal ----------------------------------------
-- | Changes the extension of a file path.
changeFileExt :: FilePath -- ^ The path information to modify.
-> String -- ^ The new extension (without a leading period).
-- Specify an empty string to remove an existing
-- extension from path.
-> FilePath -- ^ A string containing the modified path information.
changeFileExt fpath ext = joinFileExt name ext
where
(name,_) = splitFileExt fpath
-- | The 'joinFileExt' function is the opposite of 'splitFileExt'.
-- It joins a file name and an extension to form a complete file path.
--
-- The general rule is:
--
-- > filename `joinFileExt` ext == path
-- > where
-- > (filename,ext) = splitFileExt path
joinFileExt :: String -> String -> FilePath
joinFileExt fpath "" = fpath
joinFileExt fpath ext = fpath ++ '.':ext
-- | Split the path into file name and extension. If the file doesn\'t have extension,
-- the function will return empty string. The extension doesn\'t include a leading period.
--
-- Examples:
--
-- > splitFileExt "foo.ext" == ("foo", "ext")
-- > splitFileExt "foo" == ("foo", "")
-- > splitFileExt "." == (".", "")
-- > splitFileExt ".." == ("..", "")
-- > splitFileExt "foo.bar."== ("foo.bar.", "")
splitFileExt :: FilePath -> (String, String)
splitFileExt p =
case break (== '.') fname of
(suf@(_:_),_:pre) -> (reverse (pre++fpath), reverse suf)
_ -> (p, [])
where
(fname,fpath) = break isPathSeparator (reverse p)
-- | Checks whether the character is a valid path separator for the host
-- platform. The valid character is a 'pathSeparator' but since the Windows
-- operating system also accepts a slash (\"\/\") since DOS 2, the function
-- checks for it on this platform, too.
isPathSeparator :: Char -> Bool
isPathSeparator ch =
#if defined(CYGWIN) || defined(__MINGW32__)
ch == '/' || ch == '\\'
#else
ch == '/'
#endif
-- Code from Cabal end ------------------------------------
-----------------------------------------------------------
-- | return the object file, given the .conf file
-- i.e. /home/dons/foo.rc -> /home/dons/foo.o
--
-- we depend on the suffix we are given having a lead '.'
--
replaceSuffix :: FilePath -> String -> FilePath
replaceSuffix [] _ = [] -- ?
replaceSuffix f suf =
case reverse $ dropWhile (/= '.') $ reverse f of
[] -> f ++ suf -- no '.' in file name
f' -> f' ++ tail suf
--
-- Normally we create the .hi and .o files next to the .hs files.
-- For some uses this is annoying (i.e. true EDSL users don't actually
-- want to know that their code is compiled at all), and for hmake-like
-- applications.
--
-- This code checks if "-o foo" or "-odir foodir" are supplied as args
-- to make(), and if so returns a modified file path, otherwise it
-- uses the source file to determing the path to where the object and
-- .hi file will be put.
--
outFilePath :: FilePath -> [Arg] -> (FilePath,FilePath)
outFilePath src args =
let objs = find_o args -- user sets explicit object path
paths = find_p args -- user sets a directory to put stuff in
in case () of { _
| not (null objs)
-> let obj = last objs in (obj, mk_hi obj)
| not (null paths)
-> let obj = last paths </> mk_o (basename src) in (obj, mk_hi obj)
| otherwise
-> (mk_o src, mk_hi src)
}
where
outpath = "-o"
outdir = "-odir"
mk_hi s = replaceSuffix s hiSuf
mk_o s = replaceSuffix s objSuf
find_o [] = []
find_o (f:f':fs) | f == outpath = [f']
| otherwise = find_o $! f':fs
find_o _ = []
find_p [] = []
find_p (f:f':fs) | f == outdir = [f']
| otherwise = find_p $! f':fs
find_p _ = []
------------------------------------------------------------------------
--
-- | is file1 newer than file2?
--
-- needs some fixing to work with 6.0.x series. (is this true?)
--
-- fileExist still seems to throw exceptions on some platforms: ia64 in
-- particular.
--
-- invarient : we already assume the first file, 'a', exists
--
newer :: FilePath -> FilePath -> IO Bool
newer a b = do
a_t <- getModificationTime a
b_exists <- doesFileExist b
if not b_exists
then return True -- needs compiling
else do b_t <- getModificationTime b
return ( a_t > b_t ) -- maybe need recompiling
------------------------------------------------------------------------
--
-- | return the Z-Encoding of the string.
--
-- Stolen from GHC. Use -package ghc as soon as possible
--
type EncodedString = String
encode :: String -> EncodedString
encode [] = []
encode (c:cs) = encode_ch c ++ encode cs
unencodedChar :: Char -> Bool -- True for chars that don't need encoding
unencodedChar 'Z' = False
unencodedChar 'z' = False
unencodedChar c = c >= 'a' && c <= 'z'
|| c >= 'A' && c <= 'Z'
|| c >= '0' && c <= '9'
--
-- Decode is used for user printing.
--
decode :: EncodedString -> String
decode [] = []
decode ('Z' : d : rest) | isDigit d = decode_tuple d rest
| otherwise = decode_upper d : decode rest
decode ('z' : d : rest) | isDigit d = decode_num_esc d rest
| otherwise = decode_lower d : decode rest
decode (c : rest) = c : decode rest
decode_upper, decode_lower :: Char -> Char
decode_upper 'L' = '('
decode_upper 'R' = ')'
decode_upper 'M' = '['
decode_upper 'N' = ']'
decode_upper 'C' = ':'
decode_upper 'Z' = 'Z'
decode_upper ch = error $ "decode_upper can't handle this char `"++[ch]++"'"
decode_lower 'z' = 'z'
decode_lower 'a' = '&'
decode_lower 'b' = '|'
decode_lower 'c' = '^'
decode_lower 'd' = '$'
decode_lower 'e' = '='
decode_lower 'g' = '>'
decode_lower 'h' = '#'
decode_lower 'i' = '.'
decode_lower 'l' = '<'
decode_lower 'm' = '-'
decode_lower 'n' = '!'
decode_lower 'p' = '+'
decode_lower 'q' = '\''
decode_lower 'r' = '\\'
decode_lower 's' = '/'
decode_lower 't' = '*'
decode_lower 'u' = '_'
decode_lower 'v' = '%'
decode_lower ch = error $ "decode_lower can't handle this char `"++[ch]++"'"
-- Characters not having a specific code are coded as z224U
decode_num_esc :: Char -> [Char] -> String
decode_num_esc d cs
= go (digitToInt d) cs
where
go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
go n ('U' : rest) = chr n : decode rest
go _ other = error $
"decode_num_esc can't handle this: \""++other++"\""
encode_ch :: Char -> EncodedString
encode_ch c | unencodedChar c = [c] -- Common case first
-- Constructors
encode_ch '(' = "ZL" -- Needed for things like (,), and (->)
encode_ch ')' = "ZR" -- For symmetry with (
encode_ch '[' = "ZM"
encode_ch ']' = "ZN"
encode_ch ':' = "ZC"
encode_ch 'Z' = "ZZ"
-- Variables
encode_ch 'z' = "zz"
encode_ch '&' = "za"
encode_ch '|' = "zb"
encode_ch '^' = "zc"
encode_ch '$' = "zd"
encode_ch '=' = "ze"
encode_ch '>' = "zg"
encode_ch '#' = "zh"
encode_ch '.' = "zi"
encode_ch '<' = "zl"
encode_ch '-' = "zm"
encode_ch '!' = "zn"
encode_ch '+' = "zp"
encode_ch '\'' = "zq"
encode_ch '\\' = "zr"
encode_ch '/' = "zs"
encode_ch '*' = "zt"
encode_ch '_' = "zu"
encode_ch '%' = "zv"
encode_ch c = 'z' : shows (ord c) "U"
decode_tuple :: Char -> EncodedString -> String
decode_tuple d cs
= go (digitToInt d) cs
where
go n (c : rest) | isDigit c = go (10*n + digitToInt c) rest
go 0 ['T'] = "()"
go n ['T'] = '(' : replicate (n-1) ',' ++ ")"
go 1 ['H'] = "(# #)"
go n ['H'] = '(' : '#' : replicate (n-1) ',' ++ "#)"
go _ other = error $ "decode_tuple \'"++other++"'"
-- ---------------------------------------------------------------------
--
-- 'isSublistOf' takes two arguments and returns 'True' iff the first
-- list is a sublist of the second list. This means that the first list
-- is wholly contained within the second list. Both lists must be
-- finite.
isSublistOf :: Eq a => [a] -> [a] -> Bool
isSublistOf [] _ = True
isSublistOf _ [] = False
isSublistOf x y@(_:ys)
| isPrefixOf x y = True
| otherwise = isSublistOf x ys

37
src/plugins.cabal.in
View File

@ -1,37 +0,0 @@
name: plugins
version: 0.9.10
license: LGPL
License-file: LICENSE
author: Don Stewart
maintainer: dons@cse.unsw.edu.au
exposed-modules:
AltData.Dynamic,
AltData.Typeable,
Language.Hi.Binary,
Language.Hi.FastMutInt,
Language.Hi.FastString,
Language.Hi.Parser,
Language.Hi.PrimPacked,
Language.Hi.Syntax,
System.Eval,
System.Eval.Haskell,
System.Eval.Utils,
System.MkTemp,
System.Plugins,
System.Plugins.Consts,
System.Plugins.Env,
System.Plugins.Load,
System.Plugins.LoadTypes,
System.Plugins.Make,
System.Plugins.Package,
System.Plugins.PackageAPI,
System.Plugins.ParsePkgConfCabal,
System.Plugins.Parser,
System.Plugins.Process,
System.Plugins.Utils
c-sources:
Language/Hi/hschooks.c
includes: Linker.h
Build-Depends: base, haskell98, Cabal, @HASKELL_SRC@
ghc-options: -Wall -O -fvia-C -funbox-strict-fields -fno-warn-missing-signatures