Setup.lhs

   1 #!/usr/bin/env runhaskell
   2
   3 > import Distribution.Simple
   4 > import System.FilePath
   5 > import System.Directory
   6 > import Data.List
   7 > import Control.Monad
   8 > import System.Time (ClockTime)
   9 > import System.Process
  10 > import System.Exit
  11
  12 > heads = unfoldr step . Just
  13 >    where
  14 >       step Nothing        = Nothing
  15 >       step (Just [])      = Just ([], Nothing)
  16 >       step (Just (x:xs))  = Just (x, Just xs)
  17
  18 > preludeSrcDir = "prelude"
  19 > preludePath = "gen/Kaos/Prelude.hs"
  20 > preludeDir  = fst $ splitFileName preludePath
  21 > preludeDirs = reverse $ map combine $ heads $ splitPath preludeDir
  22
  23 > hooks = defaultUserHooks { preBuild = checkPrelude, cleanHook = cleanPreludeHook, runTests = testhook }
  24 > main = defaultMainWithHooks hooks
  25
  26 > cleanPreludeHook pd lbi uh cf = do
  27 >   cleanPrelude
  28 >   cleanHook defaultUserHooks pd lbi uh cf
  29
  30 > checkPreludeDirs = createDirectoryIfMissing True preludeDir
  31 > cleanPrelude = do
  32 >       checkPreludeDirs
  33 >       removeDirectoryRecursive "gen"
  34
  35 > loadPreludeSource :: IO ([(String, String)], ClockTime)
  36 > loadPreludeSource = do
  37 >   entries <- liftM sort $ getDirectoryContents preludeSrcDir
  38 >   l <- mapM (scanEnt . ((preludeSrcDir ++ "/")++)) entries
  39 >   let (strs, modTimes) = unzip $ concat l
  40 >   return $ (strs, maximum modTimes)
  41 >   where
  42 >     scanEnt e
  43 >       | not (".k" `isSuffixOf` e)
  44 >       = return []
  45 >               | otherwise
  46 >               = do
  47 >                       contents <- readFile e
  48 >                       modTime  <- getModificationTime e
  49 >                       return [((e, contents), modTime)]
  50
  51 > checkPrelude args buildflags = do
  52 >   checkPreludeDirs
  53 >   (preludeSrc, preludeModTime) <- loadPreludeSource
  54 >   pe <- doesFileExist preludePath
  55 >   when (not pe) $ genPrelude preludeSrc
  56 >   lastGen <- getModificationTime preludePath
  57 >   when (preludeModTime >= lastGen) $ genPrelude preludeSrc
  58 >   preBuild defaultUserHooks args buildflags
  59
  60 > genPrelude src = do
  61 >   writeFile preludePath $ unlines [
  62 >       "module Kaos.Prelude (preludeStr) where",
  63 >       "preludeStr :: [(String, String)]",
  64 >       "preludeStr = " ++ show src
  65 >       ]
  66
  67 > testhook args _ _ _ = do
  68 >       ph <- runProcess "perl" ("runtests.pl":args) Nothing Nothing Nothing Nothing Nothing
  69 >       exitCode <- waitForProcess ph
  70 >       case exitCode of
  71 >               ExitSuccess -> return ()
  72 >               _ -> exitWith exitCode