Partially improve the cabalisation
This commit is contained in:
Don Stewart
25
System/Eval.hs
Normal file
25
System/Eval.hs
Normal file
@ -0,0 +1,25 @@
|
||||
--
|
||||
-- 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
System/Eval/Haskell.hs
Normal file
259
System/Eval/Haskell.hs
Normal file
@ -0,0 +1,259 @@
|
||||
{-# 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
System/Eval/Utils.hs
Normal file
97
System/Eval/Utils.hs
Normal file
@ -0,0 +1,97 @@
|
||||
{-# 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
System/MkTemp.hs
Normal file
278
System/MkTemp.hs
Normal file
@ -0,0 +1,278 @@
|
||||
{-# 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
System/Plugins.hs
Normal file
37
System/Plugins.hs
Normal file
@ -0,0 +1,37 @@
|
||||
--
|
||||
-- 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
|
||||
--
|
||||
|
||||
78
System/Plugins/Consts.hs
Normal file
78
System/Plugins/Consts.hs
Normal file
@ -0,0 +1,78 @@
|
||||
--
|
||||
-- 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
System/Plugins/Env.hs
Normal file
460
System/Plugins/Env.hs
Normal file
@ -0,0 +1,460 @@
|
||||
{-# 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
System/Plugins/Load.hs
Normal file
662
System/Plugins/Load.hs
Normal file
@ -0,0 +1,662 @@
|
||||
{-# 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
System/Plugins/LoadTypes.hs
Normal file
52
System/Plugins/LoadTypes.hs
Normal file
@ -0,0 +1,52 @@
|
||||
--
|
||||
-- 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
System/Plugins/Make.hs
Normal file
356
System/Plugins/Make.hs
Normal file
@ -0,0 +1,356 @@
|
||||
{-# 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
System/Plugins/Package.hs
Normal file
67
System/Plugins/Package.hs
Normal file
@ -0,0 +1,67 @@
|
||||
--
|
||||
-- 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
System/Plugins/PackageAPI.hs
Normal file
96
System/Plugins/PackageAPI.hs
Normal file
@ -0,0 +1,96 @@
|
||||
{-# 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
System/Plugins/ParsePkgConfCabal.y
Normal file
218
System/Plugins/ParsePkgConfCabal.y
Normal file
@ -0,0 +1,218 @@
|
||||
--
|
||||
-- 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
System/Plugins/ParsePkgConfLite.hs
Normal file
616
System/Plugins/ParsePkgConfLite.hs
Normal file
@ -0,0 +1,616 @@
|
||||
{-# 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
System/Plugins/ParsePkgConfLite.y
Normal file
159
System/Plugins/ParsePkgConfLite.y
Normal file
@ -0,0 +1,159 @@
|
||||
--
|
||||
-- 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
System/Plugins/Parser.hs
Normal file
239
System/Plugins/Parser.hs
Normal file
@ -0,0 +1,239 @@
|
||||
{-# 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
System/Plugins/Process.hs
Normal file
90
System/Plugins/Process.hs
Normal file
@ -0,0 +1,90 @@
|
||||
{-# 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
System/Plugins/Utils.hs
Normal file
504
System/Plugins/Utils.hs
Normal file
@ -0,0 +1,504 @@
|
||||
{-# 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
|
||||
|
||||
Reference in New Issue
Block a user