Patch using multiple preprocessors ...
Marc Weber
marco-oweber at gmx.de
Thu Dec 28 06:51:51 EST 2006
This patch seems to work. But I haven't done serious testing yet. It
passes my own test.
The test is in multipleextensiontest
and contains the files
multiple_extension/
setup.hs ( contains the test preprocessors)
src_executable/Multipleextensiontest.1.2.3.a.b
module Main where
main = do
print "start"
-- P1
-- P2
-- P3
-- Pa
-- Pb
-- Pc
print "end"
multipleextensiontest.cabal
The preprocessors 0,1,2,a,b,c (c not used) will each replace -- Px by
print "x" and add another print line to get the reversed order of run
preprocessors.
The diff is made relative to darcs/haskell.org/cabal/cabal-1.1.7
Isaac told me that cabal-install is newer ..
You can also get the whole repository with changes here (http://mawercer.de/marcweber/haskell/cabal-1.1.7-my/ )
Greetings Marc
diff -rN old-cabal-1.1.7-my/Cabal.cabal new-cabal-1.1.7-my/Cabal.cabal
7c7
< Build-Depends: base
---
> Build-Depends: base, mtl
diff -rN old-cabal-1.1.7-my/Distribution/PreProcess.hs new-cabal-1.1.7-my/Distribution/PreProcess.hs
64c64
< moduleToFilePath, die, dieWithLocation)
---
> moduleToFilePath, die, dieWithLocation, on)
70c70,71
< import System.Directory (removeFile, getModificationTime)
---
> import System.Directory (removeFile, getModificationTime, doesFileExist)
> import Data.Bits ((.|.))
73c74,76
< (splitFileExt, joinFileName, joinFileExt)
---
> (splitFileName, splitFilePath, splitFileExt, joinFileName, joinFileExt)
> import Control.Monad
> import Debug.Trace
76c79
< -- external program, but need not be. The arguments are the name of
---
> -- /xternal program, but need not be. The arguments are the name of
144,163c147,177
< preprocessModule searchLoc modu verbose builtinSuffixes handlers = do
< bsrcFiles <- moduleToFilePath searchLoc modu builtinSuffixes
< psrcFiles <- moduleToFilePath searchLoc modu (map fst handlers)
< case psrcFiles of
< [] -> case bsrcFiles of
< [] -> die ("can't find source for " ++ modu ++ " in " ++ show searchLoc)
< _ -> return ExitSuccess
< (psrcFile:_) -> do
< let (srcStem, ext) = splitFileExt psrcFile
< pp = fromMaybe (error "Internal error in preProcess module: Just expected")
< (lookup ext handlers)
< recomp <- case bsrcFiles of
< [] -> return True
< (bsrcFile:_) -> do
< btime <- getModificationTime bsrcFile
< ptime <- getModificationTime psrcFile
< return (btime < ptime)
< if recomp
< then pp psrcFile (srcStem `joinFileExt` "hs") verbose
< else return ExitSuccess
---
> preprocessModule searchLoc modu verbose builtinSuffixes handlers =
> let hslhs = zip builtinSuffixes $ repeat (\_ _ _ -> return ExitSuccess) -- .hs,.lhs or .gc using hmake with nhc : do nothing
> all_handler = hslhs ++ handlers -- use builtin handler first ( you can't override .hs, lhs anyway as target and source filename would be the same, wouldn't it?)
> preprocess f = let (dir, file) = splitFileName f
> (fwe, ext) = splitFileExt file
> in case ext of
> "" -> case splitFileExt fwe of
> (_, "") -> return ExitSuccess -- No extension left. do nothing
> _ -> die $ "no extension found! don't know how to handle this file " ++ f
> ext -> case lookup ext all_handler of
> Nothing -> die $ "no handler found for extinsion pant " ++ ext
> Just pp -> let dest = dir `joinFileName` fwe
> in do de <- doesFileExist dest
> recomp <- if de then liftM2 (>)
> (getModificationTime f)
> (getModificationTime dest)
> else return True -- dest file doesn't exist
> if recomp then pp f dest verbose >>=
> \exitCode -> case exitCode of
> ExitSuccess -> return ()
> _ -> fail $ "preprocessor beeing responsible for extension part " ++ ext ++ "failed"
> else return ()
> -- now do next preprocessing step
> preprocess dest
>
> in moduleToFilePath searchLoc modu (map fst all_handler) >>= \srcFiles -> case srcFiles of
> [] -> die $ "!!can't find source for " ++ modu ++ " in " ++ show searchLoc
> [f] -> -- run preprocessor if necessary
> preprocess f
> files -> die $ "muliple fitting source files found for module "
> ++ modu ++ " files " ++ foldr1 (\a b->a ++ ", " ++ b) files
diff -rN old-cabal-1.1.7-my/Distribution/Simple/Utils.hs new-cabal-1.1.7-my/Distribution/Simple/Utils.hs
44a45
> on,
58a60
> moduleToFilePath2,
89,90c91,93
< import Control.Monad(when, filterM, unless)
< import Data.List (nub, unfoldr)
---
> import Control.Monad(when, filterM, unless, liftM)
> import Data.List (nub, unfoldr, maximumBy, length, isPrefixOf)
> import Data.Map (union, toList, fromList)
113a117,125
> f `on` op = \x y -> f x `op` f y
>
> -- --------------------------------------------------------------------------- List
> -- spits the list on element element
> splitBy :: (Eq a) => [a] -> a -> [[a]]
> splitBy list element = case break (== element) list of
> (a, []) -> [a]
> (a, b) -> a:splitBy b element
>
213a226,249
> -- FIXME/TODO: check wether tail contains only known suffixes. Only checks matching filename yet
> moduleToFilePath2 :: [FilePath] -- ^search locations
> -> String -- ^Module Name
> -> [String] -- ^possible suffixes
> -> IO [(FilePath, FilePath)]
> moduleToFilePath2 locs mname possibleSuffixes =
> let mname_parts = splitBy mname '.' -- "Data.List" -> ["Date","List"]
> m_path = init mname_parts
> joinPathElements folders = foldr1 joinFileName folders
> gDC path = catch (getDirectoryContentsWithoutSpecial path) (\_-> return [])
> maxBy [] = Nothing
> maxBy l = Just $ maximumBy (\a b -> compare (length a) (length b)) l
> -- does file match mname?
> filterFile = ( isPrefixOf ((last mname_parts) ++ ['.'] ))
> -- filter names beginning with (last mname_parts) ++ ['.'],
> -- omitting hs/lhs for compatibility (.gc, .chs, ..)
> -- only use longest filename (thus no intermediate file)
> filterModule = maxBy . (filter filterFile)
> foldr_f (loc, files) l = case filterModule files of
> Nothing -> l
> Just f -> (loc, f):l
> in do files <- mapM (\loc -> gDC $ joinPathElements (loc:m_path) ) locs
> return $ foldr foldr_f [] $ zip locs files
>
217a254
> moduleToFilePath locs mn ps = (liftM (map (uncurry joinFileName))) $ moduleToFilePath2 locs mn ps
219,238c256,280
< moduleToFilePath pref s possibleSuffixes
< = filterM doesFileExist $
< concatMap (searchModuleToPossiblePaths s possibleSuffixes) pref
< where searchModuleToPossiblePaths :: String -> [String] -> FilePath -> [FilePath]
< searchModuleToPossiblePaths s' suffs searchP
< = moduleToPossiblePaths searchP s' suffs
<
< -- |Like 'moduleToFilePath', but return the location and the rest of
< -- the path as separate results.
< moduleToFilePath2
< :: [FilePath] -- ^search locations
< -> String -- ^Module Name
< -> [String] -- ^possible suffixes
< -> IO [(FilePath, FilePath)] -- ^locations and relative names
< moduleToFilePath2 locs mname possibleSuffixes
< = filterM exists $
< [(loc, fname `joinFileExt` ext) | loc <- locs, ext <- possibleSuffixes]
< where
< fname = dotToSep mname
< exists (loc, relname) = doesFileExist (loc `joinFileName` relname)
---
> -- moduleToFilePath :: [FilePath] -- ^search locations
> -- -> String -- ^Module Name
> -- -> [String] -- ^possible suffixes
> -- -> IO [FilePath]
> --
> -- moduleToFilePath pref s possibleSuffixes
> -- = filterM doesFileExist $
> -- concatMap (searchModuleToPossiblePaths s possibleSuffixes) pref
> -- where searchModuleToPossiblePaths :: String -> [String] -> FilePath -> [FilePath]
> -- searchModuleToPossiblePaths s' suffs searchP
> -- = moduleToPossiblePaths searchP s' suffs
>
> -- -- |Like 'moduleToFilePath', but return the location and the rest of
> -- -- the path as separate results.
> -- moduleToFilePath2
> -- :: [FilePath] -- ^search locations
> -- -> String -- ^Module Name
> -- -> [String] -- ^possible suffixes
> -- -> IO [(FilePath, FilePath)] -- ^locations and relative names
> -- moduleToFilePath2 locs mname possibleSuffixes
> -- = filterM exists $
> -- [(loc, fname `joinFileExt` ext) | loc <- locs, ext <- possibleSuffixes]
> -- where
> -- fname = dotToSep mname
> -- exists (loc, relname) = doesFileExist (loc `joinFileName` relname)
diff -rN old-cabal-1.1.7-my/Setup.lhs new-cabal-1.1.7-my/Setup.lhs
1,5d0
< #!/usr/bin/runhaskell
< > module Main where
< > import Distribution.Simple
< > main :: IO ()
< > main = defaultMain
diff -rN old-cabal-1.1.7-my/multiple_extension-test/multiple_extension-test.cabal new-cabal-1.1.7-my/multiple_extension-test/multiple_extension-test.cabal
0a1,12
> Name: multipleextensiontest
> Version: 0.0
> License: BSD3
> Author: Marc Weber
> Category:
> Synopsis: test multiple extensions
> Build-Depends: haskell98 ,base ,Cabal
>
> Executable: multipleextensiontest
> hs-source-dirs: src_executable
> Main-Is: Multipleextensiontest.hs
> other-modules: Multipleextensiontest
diff -rN old-cabal-1.1.7-my/multiple_extension-test/setup.hs new-cabal-1.1.7-my/multiple_extension-test/setup.hs
0a1,56
> module Main where
> import Distribution.Simple
> import Distribution.Simple.Configure
> import Distribution.Simple.LocalBuildInfo
> import Distribution.PreProcess
> import System
> import System.Process
> import System.Exit
> import Monad
>
> import Char ( isSpace )
> -- #ifdef __GLASGOW_HASKELL__
> -- #ifndef __HADDOCK__
> -- import {-# SOURCE #-} GHC.Unicode ( isSpace )
> -- #endif
> -- import GHC.List ( replicate )
> -- import GHC.Base
> -- #else
> -- import Data.Char( isSpace )
> -- #endif
>
> import Text.ParserCombinators.ReadP
>
> main= do
> args <- getArgs -- check args to launch ghci
> when (length args > 0) $ do
> when ((args!!0) == "ghci") $ do
> lbi <- getPersistBuildConfig
> let packageArgs = (concat.concat) [ [" -package ", showPackageId pkg] | pkg <- packageDeps lbi ]
> system("ghci " ++ packageArgs)
> exitWith ExitSuccess
> defaultMainWithHooks $ defaultUserHooks { hookedPreProcessors = hp }
> where hp = map (testPreprocessor.(:[])) "123abc"
>
> testPreprocessor :: String -> PPSuffixHandler
> testPreprocessor ext = ( ext, pp)
> where pp _ _ src dest verb = do
> print $ " preprocessing file " ++ src ++ " and writing to " ++ dest
> readFile src >>= \f -> writeFile dest $ unlines . ppFile $ lines f
> return $ ExitSuccess
> ppFile :: [ String ] -> [ String ]
> ppFile =(++ [" print \"preprocessed by "++ ext ++ "\""])
> . (map preprocessLine)
> parseLine :: ReadP (String, String)
> parseLine = do spaces <- many $ satisfy isSpace
> string "--" >> (many $ satisfy isSpace)
> char 'P'
> ext <- (many1 $ satisfy (not.isSpace))
> rest <- many get
> return $ (spaces, ext)
> preprocessLine :: String -> String
> preprocessLine line = let parseResult = (readP_to_S parseLine) $ line
> in case parseResult of
> [((spaces, e),_)] -> if ext == e then spaces ++ "print \"" ++ ext ++ "\""
> else line
> _ -> line
diff -rN old-cabal-1.1.7-my/multiple_extension-test/src_executable/Multipleextensiontest.hs.1.2.3.a.b new-cabal-1.1.7-my/multiple_extension-test/src_executable/Multipleextensiontest.hs.1.2.3.a.b
0a1,11
> module Main where
>
> main = do
> print "start"
> -- P1
> -- P2
> -- P3
> -- Pa
> -- Pb
> -- Pc
> print "end"
More information about the cabal-devel
mailing list