Patch using multiple preprocessors ...

28 Dec 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"