Hugs.hs 15.3 KB
Newer Older
1
{-# OPTIONS -cpp #-}
2 3 4 5 6 7 8 9 10
-----------------------------------------------------------------------------
-- |
-- Module      :  Distribution.Simple.Hugs
-- Copyright   :  Isaac Jones 2003-2006
-- 
-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>
-- Stability   :  alpha
-- Portability :  portable
--
ijones's avatar
ijones committed
11
-- Build and install functionality for Hugs.
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44

{- Copyright (c) 2003-2005, Isaac Jones
All rights reserved.

Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:

    * Redistributions of source code must retain the above copyright
      notice, this list of conditions and the following disclaimer.

    * Redistributions in binary form must reproduce the above
      copyright notice, this list of conditions and the following
      disclaimer in the documentation and/or other materials provided
      with the distribution.

    * Neither the name of Isaac Jones nor the names of other
      contributors may be used to endorse or promote products derived
      from this software without specific prior written permission.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}

module Distribution.Simple.Hugs (
45
	configure, build, install
46 47 48 49 50 51 52 53
 ) where

import Distribution.PackageDescription
				( PackageDescription(..), BuildInfo(..),
				  withLib,
				  Executable(..), withExe, Library(..),
				  libModules, hcOptions, autogenModuleName )
import Distribution.Compiler 	( Compiler(..), CompilerFlavor(..) )
54
import Distribution.Program     ( rawSystemProgram, findProgram )
Ian Lynagh's avatar
Ian Lynagh committed
55
import Distribution.PreProcess 	( ppCpp, runSimplePreProcessor )
56 57 58
import Distribution.PreProcess.Unlit
				( unlit )
import Distribution.Simple.LocalBuildInfo
Ian Lynagh's avatar
Ian Lynagh committed
59
				( LocalBuildInfo(..), autogenModulesDir )
60
import Distribution.Simple.Utils( createDirectoryIfMissingVerbose, die,
61 62
				  dotToSep, moduleToFilePath,
				  smartCopySources, findFile, dllExtension )
63 64 65
import Language.Haskell.Extension
				( Extension(..) )
import Distribution.Compat.Directory
66
				( copyFile, removeDirectoryRecursive )
67 68
import System.FilePath        	( (</>), takeExtension, (<.>),
                                  searchPathSeparator, normalise, takeDirectory )
69
import Distribution.System
70
import Distribution.Verbosity
71
import Distribution.Package	( PackageIdentifier(..) )
72 73 74 75 76 77 78 79 80 81 82 83

import Data.Char		( isSpace )
import Data.Maybe		( mapMaybe )
import Control.Monad		( unless, when, filterM )
#ifndef __NHC__
import Control.Exception	( try )
#else
import IO			( try )
#endif
import Data.List		( nub, sort, isSuffixOf )
import System.Directory		( Permissions(..), getPermissions,
				  setPermissions )
84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
import Data.Version


-- -----------------------------------------------------------------------------
-- Configuring

configure :: Maybe FilePath -> Maybe FilePath -> Verbosity -> IO Compiler
configure hcPath _hcPkgPath verbosity = do

  -- find ffihugs
  ffihugsProg <- findProgram verbosity "ffihugs" hcPath

  -- find hugs
  hugsProg <- findProgram verbosity "hugs" hcPath

  return Compiler {
        compilerFlavor  = Hugs,
        compilerId      = PackageIdentifier "hugs" (Version [] []),
        compilerProg    = ffihugsProg,
        compilerPkgTool = hugsProg
    }
105 106

-- -----------------------------------------------------------------------------
107
-- Building
108 109

-- |Building a package for Hugs.
110 111
build :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO ()
build pkg_descr lbi verbosity = do
112
    let pref = scratchDir lbi
113
    createDirectoryIfMissingVerbose verbosity True pref
114
    withLib pkg_descr () $ \ l -> do
115 116
	copyFile (autogenModulesDir lbi </> paths_modulename)
		(pref </> paths_modulename)
117
	compileBuildInfo pref [] (libModules pkg_descr) (libBuildInfo l)
118
    withExe pkg_descr $ compileExecutable (pref </> "programs")
119
  where
120 121
	srcDir = buildDir lbi

122 123
	paths_modulename = autogenModuleName pkg_descr ++ ".hs"

124 125 126 127
	compileExecutable :: FilePath -> Executable -> IO ()
	compileExecutable destDir (exe@Executable {modulePath=mainPath, buildInfo=bi}) = do
            let exeMods = otherModules bi
	    srcMainFile <- findFile (hsSourceDirs bi) mainPath
128 129
	    let exeDir = destDir </> exeName exe
	    let destMainFile = exeDir </> hugsMainFilename exe
130
	    copyModule (CPP `elem` extensions bi) bi srcMainFile destMainFile
131 132
	    let destPathsFile = exeDir </> paths_modulename
	    copyFile (autogenModulesDir lbi </> paths_modulename)
133
		     destPathsFile
134
	    compileBuildInfo exeDir (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi
135
	    compileFiles bi exeDir [destMainFile, destPathsFile]
136
	
137
	compileBuildInfo :: FilePath -- ^output directory
138 139 140 141
                         -> [FilePath] -- ^library source dirs, if building exes
                         -> [String] -- ^Modules
                         -> BuildInfo -> IO ()
	compileBuildInfo destDir mLibSrcDirs mods bi = do
142
	    -- Pass 1: copy or cpp files from build directory to scratch directory
143
	    let useCpp = CPP `elem` extensions bi
144
	    let srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs
145 146
            when (verbosity >= verbose)
                 (putStrLn $ "Source directories: " ++ show srcDirs)
147 148
            flip mapM_ mods $ \ m -> do
                fs <- moduleToFilePath srcDirs m suffixes
Ross Paterson's avatar
Ross Paterson committed
149 150
                case fs of
                  [] ->
151
                    die ("can't find source for module " ++ m)
Ross Paterson's avatar
Ross Paterson committed
152
                  srcFile:_ -> do
153
                    let ext = takeExtension srcFile
154
                    copyModule useCpp bi srcFile
155
                        (destDir </> dotToSep m <.> ext)
156
	    -- Pass 2: compile foreign stubs in scratch directory
157 158
	    stubsFileLists <- sequence [moduleToFilePath [destDir] modu suffixes |
			modu <- mods]
159
            compileFiles bi destDir (concat stubsFileLists)
160 161 162 163 164 165

	suffixes = ["hs", "lhs"]

	-- Copy or cpp a file from the source directory to the build directory.
	copyModule :: Bool -> BuildInfo -> FilePath -> FilePath -> IO ()
	copyModule cppAll bi srcFile destFile = do
166
	    createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile)
167 168 169
	    (exts, opts, _) <- getOptionsFromSource srcFile
	    let ghcOpts = hcOptions GHC opts
	    if cppAll || CPP `elem` exts || "-cpp" `elem` ghcOpts then do
170
	    	runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity
171 172 173 174
	    	return ()
	      else
	    	copyFile srcFile destFile

175 176
        compileFiles :: BuildInfo -> FilePath -> [FilePath] -> IO ()
        compileFiles bi modDir fileList = do
177 178
	    ffiFileList <- filterM testFFI fileList
            unless (null ffiFileList) $ do
179 180
                when (verbosity >= normal) (putStrLn "Compiling FFI stubs")
                mapM_ (compileFFI bi modDir) ffiFileList
181 182 183 184 185 186 187

        -- Only compile FFI stubs for a file if it contains some FFI stuff
        testFFI :: FilePath -> IO Bool
        testFFI file = do
            inp <- readHaskellFile file
            return ("foreign" `elem` symbols (stripComments False inp))

188 189
        compileFFI :: BuildInfo -> FilePath -> FilePath -> IO ()
        compileFFI bi modDir file = do
190 191
            (_, opts, file_incs) <- getOptionsFromSource file
            let ghcOpts = hcOptions GHC opts
192
            let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi]
193
            let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs))
194 195
            let pathFlag = "-P" ++ modDir ++ [searchPathSeparator]
            let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs
196 197 198 199 200 201 202 203 204
            cfiles <- getCFiles file
            let cArgs =
                    ["-I" ++ dir | dir <- includeDirs bi] ++
                    ccOptions bi ++
                    cfiles ++
                    ["-L" ++ dir | dir <- extraLibDirs bi] ++
                    ldOptions bi ++
                    ["-l" ++ lib | lib <- extraLibs bi] ++
                    concat [["-framework", f] | f <- frameworks bi]
205
            rawSystemProgram verbosity ffihugs (hugsArgs ++ file : cArgs)
206

207
	ffihugs = compilerProg (compiler lbi)
208 209 210 211 212 213 214 215 216 217

	includeOpts :: [String] -> [String]
	includeOpts [] = []
	includeOpts ("-#include" : arg : opts) = arg : includeOpts opts
	includeOpts (_ : opts) = includeOpts opts

	-- get C file names from CFILES pragmas throughout the source file
	getCFiles :: FilePath -> IO [String]
	getCFiles file = do
	    inp <- readHaskellFile file
218
	    return [normalise cfile |
219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299
		"{-#" : "CFILES" : rest <-
			map words $ lines $ stripComments True inp,
		last rest == "#-}",
		cfile <- init rest]

	-- List of terminal symbols in a source file.
	symbols :: String -> [String]
	symbols cs = case lex cs of
	    (sym, cs'):_ | not (null sym) -> sym : symbols cs'
	    _ -> []

	-- Get the non-literate source of a Haskell module.
	readHaskellFile :: FilePath -> IO String
	readHaskellFile file = do
	    text <- readFile file
	    return $ if ".lhs" `isSuffixOf` file then unlit file text else text

-- ------------------------------------------------------------
-- * options in source files
-- ------------------------------------------------------------

-- |Read the initial part of a source file, before any Haskell code,
-- and return the contents of any LANGUAGE, OPTIONS and INCLUDE pragmas.
getOptionsFromSource
    :: FilePath
    -> IO ([Extension],                 -- LANGUAGE pragma, if any
           [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas
           [String]                     -- INCLUDE pragmas
          )
getOptionsFromSource file = do
    text <- readFile file
    return $ foldr appendOptions ([],[],[]) $ map getOptions $
	takeWhileJust $ map getPragma $
	filter textLine $ map (dropWhile isSpace) $ lines $
	stripComments True $
	if ".lhs" `isSuffixOf` file then unlit file text else text
  where textLine [] = False
	textLine ('#':_) = False
	textLine _ = True

	getPragma :: String -> Maybe [String]
	getPragma line = case words line of
	    ("{-#" : rest) | last rest == "#-}" -> Just (init rest)
	    _ -> Nothing

	getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], [])
	getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], [])
	getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], [])
	getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], [])
	getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], [])
	  where	readExtension :: String -> Maybe Extension
		readExtension w = case reads w of
		    [(ext, "")] -> Just ext
		    [(ext, ",")] -> Just ext
		    _ -> Nothing
	getOptions ("INCLUDE":ws) = ([], [], ws)
	getOptions _ = ([], [], [])

	appendOptions (exts, opts, incs) (exts', opts', incs')
          = (exts++exts', opts++opts', incs++incs')

-- takeWhileJust f = map fromJust . takeWhile isJust
takeWhileJust :: [Maybe a] -> [a]
takeWhileJust (Just x:xs) = x : takeWhileJust xs
takeWhileJust _ = []

-- |Strip comments from Haskell source.
stripComments
    :: Bool	-- ^ preserve pragmas?
    -> String	-- ^ input source text
    -> String
stripComments keepPragmas = stripCommentsLevel 0
  where stripCommentsLevel :: Int -> String -> String
	stripCommentsLevel 0 ('"':cs) = '"':copyString cs
	stripCommentsLevel 0 ('-':'-':cs) =	-- FIX: symbols like -->
	    stripCommentsLevel 0 (dropWhile (/= '\n') cs)
	stripCommentsLevel 0 ('{':'-':'#':cs)
	  | keepPragmas = '{' : '-' : '#' : copyPragma cs
	stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs
	stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs
	stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs
Ian Lynagh's avatar
Ian Lynagh committed
300
	stripCommentsLevel n (_:cs) = stripCommentsLevel n cs
301 302 303 304 305 306 307 308 309 310 311 312
	stripCommentsLevel _ [] = []

	copyString ('\\':c:cs) = '\\' : c : copyString cs
	copyString ('"':cs) = '"' : stripCommentsLevel 0 cs
	copyString (c:cs) = c : copyString cs
	copyString [] = []

	copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs
	copyPragma (c:cs) = c : copyPragma cs
	copyPragma [] = []

-- -----------------------------------------------------------------------------
ijones's avatar
ijones committed
313
-- |Install for Hugs.
314
-- For install, copy-prefix = prefix, but for copy they're different.
ijones's avatar
ijones committed
315 316 317 318 319 320
-- The library goes in \<copy-prefix>\/lib\/hugs\/packages\/\<pkgname>
-- (i.e. \<prefix>\/lib\/hugs\/packages\/\<pkgname> on the target system).
-- Each executable goes in \<copy-prefix>\/lib\/hugs\/programs\/\<exename>
-- (i.e. \<prefix>\/lib\/hugs\/programs\/\<exename> on the target system)
-- with a script \<copy-prefix>\/bin\/\<exename> pointing at
-- \<prefix>\/lib\/hugs\/programs\/\<exename>.
321
install
322 323 324 325 326 327
    :: Verbosity -- ^verbosity
    -> FilePath  -- ^Library install location
    -> FilePath  -- ^Program install location
    -> FilePath  -- ^Executable install location
    -> FilePath  -- ^Program location on target system
    -> FilePath  -- ^Build location
328 329
    -> PackageDescription
    -> IO ()
330
install verbosity libDir installProgDir binDir targetProgDir buildPref pkg_descr = do
Ian Lynagh's avatar
Ian Lynagh committed
331
    try $ removeDirectoryRecursive libDir
332
    smartCopySources verbosity [buildPref] libDir (libModules pkg_descr) hugsInstallSuffixes True False
333
    let buildProgDir = buildPref </> "programs"
334
    when (any (buildable . buildInfo) (executables pkg_descr)) $
335
        createDirectoryIfMissingVerbose verbosity True binDir
336
    withExe pkg_descr $ \ exe -> do
337 338 339
        let theBuildDir = buildProgDir </> exeName exe
        let installDir = installProgDir </> exeName exe
        let targetDir = targetProgDir </> exeName exe
340
        try $ removeDirectoryRecursive installDir
341
        smartCopySources verbosity [theBuildDir] installDir
342
            ("Main" : autogenModuleName pkg_descr : otherModules (buildInfo exe)) hugsInstallSuffixes True False
343
        let targetName = "\"" ++ (targetDir </> hugsMainFilename exe) ++ "\""
344 345 346
        -- FIX (HUGS): use extensions, and options from file too?
        -- see http://hackage.haskell.org/trac/hackage/ticket/43
        let hugsOptions = hcOptions Hugs (options (buildInfo exe))
347 348 349 350 351 352 353 354 355 356 357 358
        let exeFile = case os of
                          Windows _ -> binDir </> exeName exe <.> ".bat"
                          _         -> binDir </> exeName exe
        let script = case os of
                         Windows _ ->
                             let args = hugsOptions ++ [targetName, "%*"]
                             in unlines ["@echo off",
                                         unwords ("runhugs" : args)]
                         _ ->
                             let args = hugsOptions ++ [targetName, "\"$@\""]
                             in unlines ["#! /bin/sh",
                                         unwords ("runhugs" : args)]
359 360 361 362 363
        writeFile exeFile script
        perms <- getPermissions exeFile
        setPermissions exeFile perms { executable = True, readable = True }

hugsInstallSuffixes :: [String]
364
hugsInstallSuffixes = [".hs", ".lhs", dllExtension]
365 366 367 368 369

-- |Filename used by Hugs for the main module of an executable.
-- This is a simple filename, so that Hugs will look for any auxiliary
-- modules it uses relative to the directory it's in.
hugsMainFilename :: Executable -> FilePath
370 371
hugsMainFilename exe = "Main" <.> ext
  where ext = takeExtension (modulePath exe)