diff --git a/Blueprint.cabal b/Blueprint.cabal
new file mode 100644
--- /dev/null
+++ b/Blueprint.cabal
@@ -0,0 +1,39 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091128000856.1485:@thin Blueprint.cabal
+-- @@language Haskell
+Name: Blueprint
+Description: Preview of a new build system.
+Version: 0.1
+Cabal-Version: >= 1.2
+License: BSD3
+License-File: LICENSE
+Author: Gregory Crosswhite
+Copyright: (c) 2009 Gregory Crosswhite
+Maintainer: gcross@phys.washington.edu
+Stability: experimental
+Homepage: http://github.com/gcross/Blueprint
+Category: Distribution
+Synopsis: Preview of a new build system.
+Build-Type: Custom
+Build-Depends: base == 4.1.*,
+ containers == 0.2.*,
+ array == 0.2.*,
+ bytestring == 0.9.*,
+ mtl == 1.1.*,
+ directory == 1.0.*,
+ filepath == 1.1.*,
+ process == 1.0.*,
+ parallel == 2.1.*,
+ binary == 0.5.*,
+ stringtable-atom == 0.0.6,
+ ConfigFile == 1.0.*,
+ either-unwrap == 1.1.*,
+ pureMD5 == 1.0.*,
+ Cabal == 1.6.*,
+ ansi-wl-pprint == 0.5.*,
+ regex-tdfa == 1.1.*,
+ InfixApplicative == 1.0.*
+
+Library
+-- @-node:gcross.20091128000856.1485:@thin Blueprint.cabal
+-- @-leo
diff --git a/Blueprint.leo b/Blueprint.leo
new file mode 100644
--- /dev/null
+++ b/Blueprint.leo
@@ -0,0 +1,47 @@
+
+
+
+
+
+
+
+
+
+
+
+@chapters
+@thin Blueprint.cabal
+@thin Setup.hs
+@path Blueprint
+@path Cache
+@thin ExplicitDependencies.hs
+@thin ImplicitDependencies.hs
+
+@thin Configuration.hs
+@thin Error.hs
+@thin Main.hs
+@thin Miscellaneous.hs
+@thin Options.hs
+@thin Resources.hs
+@path Tools
+@thin Ar.hs
+@thin GCC.hs
+@thin GFortran.hs
+@thin GHC.hs
+@thin Haddock.hs
+@thin Installer.hs
+@thin Ld.hs
+
+
+@path tests
+@thin test.hs
+
+
+
+
+
+
+
+
+
+
diff --git a/Blueprint/Cache/ExplicitDependencies.hs b/Blueprint/Cache/ExplicitDependencies.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Cache/ExplicitDependencies.hs
@@ -0,0 +1,132 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091122100142.1369:@thin ExplicitDependencies.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091122100142.1372:<< Language extensions >>
+-- @-node:gcross.20091122100142.1372:<< Language extensions >>
+-- @nl
+
+module Blueprint.Cache.ExplicitDependencies where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091122100142.1374:<< Import needed modules >>
+import Control.Monad
+import Control.Parallel.Strategies
+
+import Data.Binary
+import Data.Digest.Pure.MD5
+import Data.Either.Unwrap
+import Data.Function
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+
+import Blueprint.Error
+import Blueprint.Resources
+
+-- @-node:gcross.20091122100142.1374:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091122100142.1379:Types
+-- @+node:gcross.20091122100142.1380:CachedExplicitDependencies
+data (Binary a, Eq a) => CachedExplicitDependencies a = CachedExplicitDependencies
+ { digestsOfDependencies :: Map ResourceId MD5Digest
+ , digestsOfProducts :: [MD5Digest]
+ , cachedMiscellaneousInformation :: a
+ }
+
+instance (Binary a, Eq a) => Binary (CachedExplicitDependencies a) where
+ put (CachedExplicitDependencies a b c) = put a >> put b >> put c
+ get = liftM3 CachedExplicitDependencies get get get
+-- @-node:gcross.20091122100142.1380:CachedExplicitDependencies
+-- @+node:gcross.20091122100142.1385:Builder
+type Builder = IO (Maybe ErrorMessage)
+-- @-node:gcross.20091122100142.1385:Builder
+-- @-node:gcross.20091122100142.1379:Types
+-- @+node:gcross.20091122100142.1386:Function
+-- @+node:gcross.20091122100142.1387:analyzeExplicitDependenciesAndRebuildIfNecessary
+analyzeExplicitDependenciesAndRebuildIfNecessary ::
+ (Binary a, Eq a) =>
+ Builder ->
+ FilePath ->
+ [FilePath] ->
+ a ->
+ [Resource] ->
+ Either ErrorMessage [MD5Digest]
+
+analyzeExplicitDependenciesAndRebuildIfNecessary
+ builder
+ cache_filepath
+ product_filepaths
+ miscellaneous_cache_information
+ source_resources
+ = flip (either Left) (attemptGetDigests source_resources) $ \source_digests -> unsafePerformIO $ do
+ let source_digests_as_map = Map.fromList $ zip (map resourceId source_resources) source_digests
+ rebuildIt = rebuild source_digests_as_map
+ file_exists <- doesFileExist cache_filepath
+ if not file_exists
+ then rebuildIt
+ else do
+ cached_digests <- decodeFile cache_filepath
+ let cached_digests_as_map = digestsOfDependencies cached_digests
+ compared_digests = Map.intersectionWith (==) source_digests_as_map cached_digests_as_map
+ if (Map.size source_digests_as_map /= Map.size compared_digests)
+ || (Map.size cached_digests_as_map /= Map.size compared_digests)
+ || not (Map.fold (&&) True compared_digests)
+ then rebuildIt
+ else do
+ product_files_exist <- mapM doesFileExist product_filepaths
+ if not (and product_files_exist)
+ then rebuildIt
+ else if miscellaneous_cache_information /= cachedMiscellaneousInformation cached_digests
+ then rebuildIt
+ else return . Right . digestsOfProducts $ cached_digests
+ where
+ rebuild source_digests_as_map = do
+ build_result <- builder
+ case build_result of
+ Just error_message -> return . Left $ error_message
+ Nothing -> do
+ let product_digests = map digestOf product_filepaths
+ cached_dependencies = CachedExplicitDependencies
+ { digestsOfDependencies = source_digests_as_map
+ , digestsOfProducts = product_digests
+ , cachedMiscellaneousInformation = miscellaneous_cache_information
+ }
+ createDirectoryIfMissing True . takeDirectory $ cache_filepath
+ encodeFile cache_filepath cached_dependencies
+ return . Right $ product_digests
+-- @-node:gcross.20091122100142.1387:analyzeExplicitDependenciesAndRebuildIfNecessary
+-- @+node:gcross.20091128000856.1483:analyzeDependencyAndRebuildIfNecessary
+analyzeDependencyAndRebuildIfNecessary ::
+ (Binary a, Eq a) =>
+ Builder ->
+ FilePath ->
+ [FilePath] ->
+ a ->
+ Resource ->
+ Either ErrorMessage [MD5Digest]
+analyzeDependencyAndRebuildIfNecessary
+ builder
+ cache_filepath
+ product_filepaths
+ miscellaneous_cache_information
+ source_resource
+ =
+ analyzeExplicitDependenciesAndRebuildIfNecessary
+ builder
+ cache_filepath
+ product_filepaths
+ miscellaneous_cache_information
+ [source_resource]
+-- @nonl
+-- @-node:gcross.20091128000856.1483:analyzeDependencyAndRebuildIfNecessary
+-- @-node:gcross.20091122100142.1386:Function
+-- @-others
+-- @-node:gcross.20091122100142.1369:@thin ExplicitDependencies.hs
+-- @-leo
diff --git a/Blueprint/Cache/ExplicitDependencies.o b/Blueprint/Cache/ExplicitDependencies.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Cache/ExplicitDependencies.o differ
diff --git a/Blueprint/Cache/ImplicitDependencies.hs b/Blueprint/Cache/ImplicitDependencies.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Cache/ImplicitDependencies.hs
@@ -0,0 +1,145 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091122100142.1310:@thin ImplicitDependencies.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091122100142.1370:<< Language extensions >>
+-- @-node:gcross.20091122100142.1370:<< Language extensions >>
+-- @nl
+
+module Blueprint.Cache.ImplicitDependencies where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091122100142.1313:<< Import needed modules >>
+import Control.Monad
+import Control.Parallel.Strategies
+
+import Data.Binary
+import Data.Digest.Pure.MD5
+import Data.Either.Unwrap
+import Data.Function
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+
+import Text.PrettyPrint.ANSI.Leijen
+
+import Blueprint.Error
+import Blueprint.Resources
+-- @-node:gcross.20091122100142.1313:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091122100142.1314:Types
+-- @+node:gcross.20091122100142.1321:CachedImplicitDependencies
+data (Binary a, Eq a) => CachedImplicitDependencies a = CachedImplicitDependencies
+ { digestOfSourceFile :: MD5Digest
+ , digestsOfProducedFiles :: [MD5Digest]
+ , digestOfDependentModules :: [(ResourceId,MD5Digest)]
+ , cachedMiscellaneousInformation :: a
+ }
+
+instance (Binary a, Eq a) => Binary (CachedImplicitDependencies a) where
+ put (CachedImplicitDependencies a b c d) = put a >> put b >> put c >> put d
+ get = liftM4 CachedImplicitDependencies get get get get
+-- @-node:gcross.20091122100142.1321:CachedImplicitDependencies
+-- @+node:gcross.20091122100142.1323:Builder
+type Builder = IO (Maybe ErrorMessage)
+-- @-node:gcross.20091122100142.1323:Builder
+-- @+node:gcross.20091122100142.1324:Scanner
+type Scanner = IO (Either ErrorMessage [ResourceId])
+-- @-node:gcross.20091122100142.1324:Scanner
+-- @-node:gcross.20091122100142.1314:Types
+-- @+node:gcross.20091122100142.1317:Function
+-- @+node:gcross.20091122100142.1322:analyzeImplicitDependenciesAndRebuildIfNecessary
+analyzeImplicitDependenciesAndRebuildIfNecessary ::
+ (Binary a, Eq a) =>
+ Builder ->
+ Scanner ->
+ Resources ->
+ FilePath ->
+ [FilePath] ->
+ a ->
+ Resource ->
+ Either ErrorMessage ([MD5Digest],[ResourceId])
+
+analyzeImplicitDependenciesAndRebuildIfNecessary
+ builder
+ scanner
+ resources
+ cache_filepath
+ product_filepaths
+ miscellaneous_cache_information
+ source_resource
+ = unsafePerformIO $ do
+ file_exists <- doesFileExist cache_filepath
+ if not file_exists
+ then rescanAndRebuild
+ else do
+ cached_digests <- decodeFile cache_filepath
+ if source_digest /= digestOfSourceFile cached_digests
+ then rescanAndRebuild
+ else let (resource_ids,previously_seen_digests) = unzip . digestOfDependentModules $ cached_digests
+ in attemptGetResourceDigestsAndThenRun resource_ids $
+ \current_resource_digests ->
+ let rebuildIt = rebuild resource_ids current_resource_digests
+ in if any (uncurry (/=)) $ zip current_resource_digests previously_seen_digests
+ then rebuildIt
+ else do
+ product_files_exist <- mapM doesFileExist product_filepaths
+ if not (and product_files_exist)
+ then rebuildIt
+ else if miscellaneous_cache_information /= cachedMiscellaneousInformation cached_digests
+ then rebuildIt
+ else return . Right $ (digestsOfProducedFiles cached_digests,resource_ids)
+ where
+ source_digest = (fromRight . resourceDigest) source_resource
+
+ attemptGetResourceDigestsAndThenRun resource_ids nextStep =
+ case attemptGetResourceDigests resources resource_ids of
+ Left (Left unknown_resource_ids) ->
+ return
+ .
+ Left
+ .
+ errorMessage ("finding the resources associated with the following implicit dependencies in " ++ resourceName source_resource)
+ .
+ vcat
+ .
+ map (text . show)
+ $
+ unknown_resource_ids
+ Left (Right error_message) -> return . Left $ error_message
+ Right current_resource_digests -> nextStep current_resource_digests
+
+ rescanAndRebuild = do
+ scan_result <- scanner
+ case scan_result of
+ Left error_message -> return . Left $ error_message
+ Right resource_ids ->
+ attemptGetResourceDigestsAndThenRun resource_ids $
+ \current_resource_digests -> rebuild resource_ids current_resource_digests
+
+ rebuild dependent_module_resource_ids dependent_module_digests = do
+ build_result <- builder
+ case build_result of
+ Just error_message -> return . Left $ error_message
+ Nothing -> do
+ let product_digests = map digestOf product_filepaths
+ cached_dependencies = CachedImplicitDependencies
+ { digestOfSourceFile = source_digest
+ , digestsOfProducedFiles = product_digests
+ , digestOfDependentModules = zip dependent_module_resource_ids dependent_module_digests
+ , cachedMiscellaneousInformation = miscellaneous_cache_information
+ }
+ createDirectoryIfMissing True . takeDirectory $ cache_filepath
+ encodeFile cache_filepath cached_dependencies
+ return . Right $ (product_digests,dependent_module_resource_ids)
+-- @-node:gcross.20091122100142.1322:analyzeImplicitDependenciesAndRebuildIfNecessary
+-- @-node:gcross.20091122100142.1317:Function
+-- @-others
+-- @-node:gcross.20091122100142.1310:@thin ImplicitDependencies.hs
+-- @-leo
diff --git a/Blueprint/Cache/ImplicitDependencies.o b/Blueprint/Cache/ImplicitDependencies.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Cache/ImplicitDependencies.o differ
diff --git a/Blueprint/Configuration.hs b/Blueprint/Configuration.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Configuration.hs
@@ -0,0 +1,211 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091123215917.1369:@thin Configuration.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091126122246.1386:<< Language extensions >>
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeSynonymInstances #-}
+-- @-node:gcross.20091126122246.1386:<< Language extensions >>
+-- @nl
+
+module Blueprint.Configuration where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091126122246.1381:<< Import needed modules >>
+import Control.Applicative
+import Control.Monad.Error
+import Control.Monad.Reader
+import Control.Monad.Reader.Class
+import Control.Monad.RWS (RWS(..),runRWS)
+import Control.Monad.Trans
+import Control.Monad.Writer
+
+import Data.ConfigFile
+import Data.Dynamic
+import Data.Either.Unwrap
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Typeable
+
+import StringTable.Atom
+import StringTable.AtomMap (AtomMap)
+import qualified StringTable.AtomMap as AtomMap
+
+import System.IO
+import System.IO.Error
+import System.IO.Unsafe
+
+import Blueprint.Error
+import Blueprint.Miscellaneous
+import Blueprint.Options
+-- @-node:gcross.20091126122246.1381:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091123215917.1370:Classes
+-- @+node:gcross.20091123215917.1371:ConfigurationData
+class ConfigurationData a where
+ readConfig :: ConfigurationDataReader a
+ writeConfig :: a -> ConfigurationDataWriter ()
+-- @-node:gcross.20091123215917.1371:ConfigurationData
+-- @+node:gcross.20091128000856.1408:AutomaticallyConfigurable
+class AutomaticallyConfigurable a where
+ automaticallyConfigure :: ParsedOptions -> Either ErrorMessage a
+-- @-node:gcross.20091128000856.1408:AutomaticallyConfigurable
+-- @-node:gcross.20091123215917.1370:Classes
+-- @+node:gcross.20091126122246.1387:Instances
+-- @+node:gcross.20091126122246.1388:Monoid (ConfigParser -> ConfigParser)
+instance Monoid (Automorphism a) where
+ mempty = A id
+ mappend (A g) (A f) = A (f . g)
+-- @-node:gcross.20091126122246.1388:Monoid (ConfigParser -> ConfigParser)
+-- @+node:gcross.20091127142612.1407:Applicative (ConfigurationDataWriter)
+instance Applicative ConfigurationDataWriter where
+ pure = return
+ x <*> y = WriterT . Reader $
+ \environment ->
+ let (function,w1) = (runReader . runWriterT) x $ environment
+ (argument,w2) = (runReader . runWriterT) y $ environment
+ in (function argument,w1 `mappend` w2)
+-- @-node:gcross.20091127142612.1407:Applicative (ConfigurationDataWriter)
+-- @-node:gcross.20091126122246.1387:Instances
+-- @+node:gcross.20091123215917.1372:Types
+-- @+node:gcross.20091123215917.1373:ConfigurationDataReader/Writer
+type ConfigurationDataReader = ErrorT CPError (Reader (ConfigParser,String))
+type ConfigurationDataWriter = WriterT (Automorphism ConfigParser) (Reader String)
+-- @-node:gcross.20091123215917.1373:ConfigurationDataReader/Writer
+-- @+node:gcross.20091129000542.1488:Environment
+data Environment = Environment
+ { environmentConfigParser :: ConfigParser
+ , environmentOptions :: ParsedOptions
+ }
+-- @-node:gcross.20091129000542.1488:Environment
+-- @+node:gcross.20091128000856.1411:Configurer
+type Configurer = ErrorT ErrorMessage (RWS Environment (Automorphism ConfigParser) ())
+
+-- @-node:gcross.20091128000856.1411:Configurer
+-- @+node:gcross.20091126122246.1389:Automorphism
+newtype Automorphism a = A { unA :: a -> a }
+-- @-node:gcross.20091126122246.1389:Automorphism
+-- @+node:gcross.20091129000542.1573:ConfigurationKey
+newtype ConfigurationKey = ConfigurationKey { unwrapConfigurationKey :: String }
+-- @-node:gcross.20091129000542.1573:ConfigurationKey
+-- @-node:gcross.20091123215917.1372:Types
+-- @+node:gcross.20091126122246.1379:Functions
+-- @+node:gcross.20091129000542.1574:makeConfigurationKey
+makeConfigurationKey = ConfigurationKey
+-- @-node:gcross.20091129000542.1574:makeConfigurationKey
+-- @+node:gcross.20091126122246.1380:getConfig
+getConfig :: Get_C a => ConfigurationKey -> ConfigurationDataReader a
+getConfig (ConfigurationKey key) = do
+ (cp,section) <- lift $ ask
+ get cp section key
+-- @-node:gcross.20091126122246.1380:getConfig
+-- @+node:gcross.20091126122246.1385:setConfig
+setConfig :: ConfigurationKey -> String -> ConfigurationDataWriter ()
+setConfig (ConfigurationKey key) value = do
+ section :: String <- lift ask
+ tell . A $
+ \cp ->
+ case set cp section key value of
+ Right cp -> cp
+ Left (NoSection _,_) ->
+ case (add_section cp section >>= \new_cp -> set new_cp section key value) of
+ Right cp -> cp
+ Left e -> raiseCPError section e
+ Left e -> raiseCPError section e
+ where
+ raiseCPError :: String -> CPError -> ConfigParser
+ raiseCPError section e =
+ error $ "Error adding section " ++ show section
+ ++ " key " ++ show key
+ ++ " value " ++ show value
+ ++ ":" ++ show e
+-- @-node:gcross.20091126122246.1385:setConfig
+-- @+node:gcross.20091127142612.1423:applyWriterToConfig
+applyWriterToConfig :: String -> ConfigurationDataWriter () -> (ConfigParser -> ConfigParser)
+applyWriterToConfig section_name = unA . snd . ($ section_name) . runReader . runWriterT
+-- @-node:gcross.20091127142612.1423:applyWriterToConfig
+-- @+node:gcross.20091127142612.1424:applyReaderToConfig
+applyReaderToConfig :: ConfigParser -> String -> ConfigurationDataReader a -> Either CPError a
+applyReaderToConfig config_parser section_name = ($ (config_parser,section_name)) . runReader . runErrorT
+-- @-node:gcross.20091127142612.1424:applyReaderToConfig
+-- @+node:gcross.20091128000856.1412:runConfigurer
+runConfigurer :: FilePath -> ParsedOptions -> Configurer a -> Either ErrorMessage a
+runConfigurer configuration_filepath parsed_options configurer = unsafePerformIO $ do
+ either_old_configuration <-
+ fmap (mapLeft (errorMessageText ("parsing configuration file " ++ configuration_filepath) . show))
+ (readfile emptyCP configuration_filepath)
+ `catch`
+ (\exception -> return $
+ if isDoesNotExistError exception
+ then Right emptyCP
+ else Left . errorMessageText ("opening " ++ configuration_filepath) . show $ exception
+ )
+ case either_old_configuration of
+ Left error_message -> return (Left error_message)
+ Right old_configuration ->
+ let (result,(),A modifyConfiguration) =
+ runRWS
+ (runErrorT configurer)
+ (Environment old_configuration parsed_options)
+ ()
+ in do
+ writeFile configuration_filepath . to_string . modifyConfiguration $ old_configuration
+ return result
+-- @-node:gcross.20091128000856.1412:runConfigurer
+-- @+node:gcross.20091128000856.1414:cpErrorMessage
+cpErrorMessage :: String -> CPError -> ErrorMessage
+cpErrorMessage section_name = errorMessageText ("parsing section " ++ section_name) . show
+-- @-node:gcross.20091128000856.1414:cpErrorMessage
+-- @+node:gcross.20091128000856.1415:configureUsingSection
+configureUsingSection ::
+ (ConfigurationData a, AutomaticallyConfigurable a) =>
+ String ->
+ Configurer a
+configureUsingSection = configureUsingSectionWith readConfig writeConfig automaticallyConfigure
+-- @-node:gcross.20091128000856.1415:configureUsingSection
+-- @+node:gcross.20091128201230.1464:configureUsingSectionWith
+configureUsingSectionWith ::
+ ConfigurationDataReader a ->
+ (a -> ConfigurationDataWriter ()) ->
+ (ParsedOptions -> Either ErrorMessage a) ->
+ String ->
+ Configurer a
+configureUsingSectionWith
+ config_reader
+ config_writer
+ automatic_configurer
+ section_name
+ = do
+ config_parser <- lift . asks $ environmentConfigParser
+ case applyReaderToConfig config_parser section_name config_reader of
+ Left cp_error ->
+ case fst cp_error of
+ NoSection _ -> reconfigure
+ NoOption _ -> reconfigure
+ _ -> ErrorT (return . Left . cpErrorMessage section_name $ cp_error)
+ Right result -> return result
+ where
+ reconfigure = do
+ options_data <- lift . asks $ environmentOptions
+ case automatic_configurer options_data of
+ Left error_message -> ErrorT (return . Left $ error_message)
+ Right configuration -> do
+ tell . A . applyWriterToConfig section_name . config_writer $ configuration
+ return configuration
+-- @-node:gcross.20091128201230.1464:configureUsingSectionWith
+-- @+node:gcross.20091129000542.1569:simpleReadConfig
+simpleReadConfig :: ConfigurationKey -> (String -> a) -> ConfigurationDataReader a
+simpleReadConfig configuration_key constructor = liftM constructor (getConfig configuration_key)
+-- @-node:gcross.20091129000542.1569:simpleReadConfig
+-- @+node:gcross.20091129000542.1570:simpleWriteConfig
+simpleWriteConfig :: ConfigurationKey -> (a -> String) -> a -> ConfigurationDataWriter ()
+simpleWriteConfig configuration_key extractor = setConfig configuration_key . extractor
+-- @-node:gcross.20091129000542.1570:simpleWriteConfig
+-- @-node:gcross.20091126122246.1379:Functions
+-- @-others
+-- @-node:gcross.20091123215917.1369:@thin Configuration.hs
+-- @-leo
diff --git a/Blueprint/Configuration.o b/Blueprint/Configuration.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Configuration.o differ
diff --git a/Blueprint/Error.hs b/Blueprint/Error.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Error.hs
@@ -0,0 +1,117 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091127142612.1383:@thin Error.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091127142612.1398:<< Language extensions >>
+{-# LANGUAGE TypeSynonymInstances #-}
+-- @-node:gcross.20091127142612.1398:<< Language extensions >>
+-- @nl
+
+module Blueprint.Error where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091127142612.1384:<< Import needed modules >>
+import Control.Arrow
+import Control.Applicative hiding (empty)
+import Control.Applicative.Infix
+import Control.Monad
+import Control.Monad.Error
+
+import Data.Either
+import Data.Either.Unwrap
+import Data.Monoid
+
+import StringTable.Atom
+import StringTable.AtomMap (AtomMap)
+import qualified StringTable.AtomMap as Map
+
+import Text.PrettyPrint.ANSI.Leijen
+-- @-node:gcross.20091127142612.1384:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091127142612.1391:Types
+-- @+node:gcross.20091127142612.1393:ErrorMessage
+type ErrorMessage = AtomMap Doc
+-- @-node:gcross.20091127142612.1393:ErrorMessage
+-- @-node:gcross.20091127142612.1391:Types
+-- @+node:gcross.20091127142612.1385:Instances
+-- @+node:gcross.20091127142612.1386:Applicative (Either e a)
+instance (Monoid e) => Applicative (Either e) where
+ pure = Right
+ (<*>) (Left error2) (Left error1) = Left (error1 `mappend` error2)
+ (<*>) (Left error) _ = Left error
+ (<*>) _ (Left error) = Left error
+ (<*>) (Right function) (Right argument) = Right (function argument)
+-- @-node:gcross.20091127142612.1386:Applicative (Either e a)
+-- @+node:gcross.20091127142612.1388:Applicative (ErrorT e m a)
+instance (Monoid e, Error e, Monad m) => Applicative (ErrorT e m) where
+ pure = return
+ e_fn <*> e_arg = ErrorT $ liftM2 (<*>) (runErrorT e_fn) (runErrorT e_arg)
+-- @-node:gcross.20091127142612.1388:Applicative (ErrorT e m a)
+-- @+node:gcross.20091128000856.1416:Error (ErrorMessage)
+instance Error ErrorMessage where
+ noMsg = strMsg "(and he did not even bother to include an error message! :-/)"
+ strMsg = errorMessage "caused by the programmer" . text
+-- @-node:gcross.20091128000856.1416:Error (ErrorMessage)
+-- @+node:gcross.20091129000542.1482:Monoid Doc
+instance Monoid Doc where
+ mempty = empty
+ mappend = (<$$>)
+ mconcat = vcat
+-- @-node:gcross.20091129000542.1482:Monoid Doc
+-- @+node:gcross.20091129000542.1602:Error Doc
+instance Error Doc where
+ noMsg = empty
+ strMsg = text
+-- @-node:gcross.20091129000542.1602:Error Doc
+-- @-node:gcross.20091127142612.1385:Instances
+-- @+node:gcross.20091127142612.1396:Functions
+-- @+node:gcross.20091127142612.1397:extractResultsOrError
+extractResultsOrError :: Monoid e => [Either e a] -> Either e [a]
+extractResultsOrError = mapLeft mconcat . extractResultsOrErrors
+-- @-node:gcross.20091127142612.1397:extractResultsOrError
+-- @+node:gcross.20091127142612.1400:extractResultsOrErrors
+extractResultsOrErrors :: [Either e a] -> Either [e] [a]
+extractResultsOrErrors eithers =
+ case partitionEithers (eithers) of
+ ([],results) -> Right results
+ (errors,_) -> Left errors
+-- @-node:gcross.20091127142612.1400:extractResultsOrErrors
+-- @+node:gcross.20091128000856.1425:formatErrorMessage
+formatErrorMessage :: ErrorMessage -> Doc
+formatErrorMessage = vcat . map (formatMessageWithHeading . first fromAtom) . Map.assocs
+-- @-node:gcross.20091128000856.1425:formatErrorMessage
+-- @+node:gcross.20091128000856.1427:formatMessageWithHeading
+formatMessageWithHeading :: (String,Doc) -> Doc
+formatMessageWithHeading (heading,message) =
+ text ("Error " ++ heading ++ ":")
+ <$$>
+ indent 4 message
+-- @-node:gcross.20091128000856.1427:formatMessageWithHeading
+-- @+node:gcross.20091128000856.1428:errorMessage / leftErrorMessage
+errorMessage :: String -> Doc -> ErrorMessage
+errorMessage heading message = Map.singleton (toAtom heading) message
+
+leftErrorMessage :: String -> Doc -> Either ErrorMessage a
+leftErrorMessage heading = Left . errorMessage heading
+-- @-node:gcross.20091128000856.1428:errorMessage / leftErrorMessage
+-- @+node:gcross.20091128000856.1429:errorMessageText / leftErrorMessageText
+errorMessageText :: String -> String -> ErrorMessage
+errorMessageText heading = errorMessage heading . text
+
+leftErrorMessageText :: String -> String -> Either ErrorMessage a
+leftErrorMessageText heading = Left . errorMessageText heading
+-- @-node:gcross.20091128000856.1429:errorMessageText / leftErrorMessageText
+-- @+node:gcross.20091128000856.1431:errorMessageTextWithLines / leftErrorMessageTextWithLines
+errorMessageTextWithLines :: String -> String -> ErrorMessage
+errorMessageTextWithLines heading = errorMessage heading . vcat . map text . lines
+
+leftErrorMessageTextWithLines :: String -> String -> Either ErrorMessage a
+leftErrorMessageTextWithLines heading = Left . errorMessageTextWithLines heading
+-- @-node:gcross.20091128000856.1431:errorMessageTextWithLines / leftErrorMessageTextWithLines
+-- @-node:gcross.20091127142612.1396:Functions
+-- @-others
+-- @-node:gcross.20091127142612.1383:@thin Error.hs
+-- @-leo
diff --git a/Blueprint/Error.o b/Blueprint/Error.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Error.o differ
diff --git a/Blueprint/Main.hs b/Blueprint/Main.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Main.hs
@@ -0,0 +1,161 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091128000856.1441:@thin Main.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091128000856.1442:<< Language extensions >>
+{-# LANGUAGE FlexibleInstances #-}
+-- @-node:gcross.20091128000856.1442:<< Language extensions >>
+-- @nl
+
+module Blueprint.Main where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091128000856.1443:<< Import needed modules >>
+import Control.Applicative.Infix
+import Control.Monad
+import Control.Parallel
+
+import Data.Maybe
+
+import System.Directory
+import System.Environment
+import System.Exit
+import System.IO
+import System.IO.Unsafe
+
+import Text.PrettyPrint.ANSI.Leijen
+
+import Blueprint.Error
+import Blueprint.Options
+-- @-node:gcross.20091128000856.1443:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091128000856.1481:Classes
+-- @+node:gcross.20091128000856.1482:Targetable
+class Targetable a where
+ target :: String -> a -> (String,Target)
+
+instance Targetable () where
+ target name value = (name,value `pseq` Nothing)
+
+instance Targetable (Maybe ErrorMessage) where
+ target name value = (name,value)
+
+instance Targetable (Either ErrorMessage a) where
+ target name value =
+ (name
+ ,case value of
+ Left error_message -> Just error_message
+ Right _ -> Nothing
+ )
+-- @-node:gcross.20091128000856.1482:Targetable
+-- @-node:gcross.20091128000856.1481:Classes
+-- @+node:gcross.20091128000856.1479:Types
+-- @+node:gcross.20091128000856.1480:Target
+type Target = Maybe ErrorMessage
+-- @-node:gcross.20091128000856.1480:Target
+-- @+node:gcross.20091129000542.1595:TargetList
+type TargetList = [(String,Target)]
+-- @-node:gcross.20091129000542.1595:TargetList
+-- @-node:gcross.20091128000856.1479:Types
+-- @+node:gcross.20091128000856.1445:Functions
+-- @+node:gcross.20091128000856.1444:defaultMain
+defaultMain :: Doc -> TargetList -> IO ()
+defaultMain _ [] = error "There are no targets to build!"
+defaultMain help_message targets = do
+ args <- getArgs
+ when (any isHelpFlag args) $ do
+ putDoc help_message
+ putStrLn ""
+ exitSuccess
+ case args of
+ [] -> showTargets
+ target_name:_ ->
+ case lookup target_name targets of
+ Nothing -> do
+ putStrLn $ "There is no target named " ++ show target_name
+ putStrLn ""
+ showTargets
+ Just target ->
+ case target of
+ Nothing -> putStrLn $ "Completed " ++ target_name ++ "."
+ Just error_message -> do
+ hPutDoc stderr . formatErrorMessage $ error_message
+ hPutStrLn stderr ""
+ exitFailure
+ where
+ showTargets :: IO ()
+ showTargets = do
+ putStrLn "Please choose from the following targets:"
+ forM_ targets $ \(target_name,_) -> putStrLn ('\t':target_name) --'
+-- @-node:gcross.20091128000856.1444:defaultMain
+-- @+node:gcross.20091129000542.1596:lookupOldTarget
+lookupOldTarget :: String -> String -> TargetList -> Target
+lookupOldTarget new_target_name old_target_name =
+ fromMaybe (error $ "Programmer error: The "
+ ++ show new_target_name ++
+ " target cannot find the "
+ ++ show old_target_name ++
+ " target."
+ )
+ .
+ lookup old_target_name
+-- @-node:gcross.20091129000542.1596:lookupOldTarget
+-- @+node:gcross.20091129000542.1594:makeCleanTarget
+makeCleanTarget :: [FilePath] -> TargetList -> Target
+makeCleanTarget files_and_directories_to_remove old_targets =
+ removeFilesAndDirectoriesTarget files_and_directories_to_remove
+-- @-node:gcross.20091129000542.1594:makeCleanTarget
+-- @+node:gcross.20091129000542.1600:makeDistCleanTarget
+makeDistCleanTarget :: [FilePath] -> TargetList -> Target
+makeDistCleanTarget files_and_directories_to_remove old_targets =
+ let clean = lookupOldTarget "distclean" "clean" old_targets
+ in clean `pseq` removeFilesAndDirectoriesTarget files_and_directories_to_remove
+-- @-node:gcross.20091129000542.1600:makeDistCleanTarget
+-- @+node:gcross.20091129000542.1598:makeRebuildTarget
+makeRebuildTarget :: TargetList -> Target
+makeRebuildTarget old_targets =
+ let clean = lookupOldTarget "rebuild" "clean" old_targets
+ build = lookupOldTarget "rebuild" "build" old_targets
+ in clean `pseq` build
+-- @-node:gcross.20091129000542.1598:makeRebuildTarget
+-- @+node:gcross.20091129000542.1592:makeReconfigureTarget
+makeReconfigureTarget :: FilePath -> TargetList -> Target
+makeReconfigureTarget configuration_filepath old_targets =
+ let configure = lookupOldTarget "reconfigure" "configure" old_targets
+ in unsafePerformIO $ do
+ file_exists <- doesFileExist configuration_filepath
+ when file_exists $ removeFile configuration_filepath
+ return configure
+-- @-node:gcross.20091129000542.1592:makeReconfigureTarget
+-- @+node:gcross.20091128000856.1478:removeFilesAndDirectoriesTarget
+removeFilesAndDirectoriesTarget :: [FilePath] -> Target
+removeFilesAndDirectoriesTarget items = unsafePerformIO $
+ forM_ items (\item ->
+ (liftM2 (,) (doesDirectoryExist item) (doesFileExist item))
+ >>=
+ (\(directory_exists,file_exists) ->
+ case (directory_exists,file_exists) of
+ (True,_) -> do
+ putStrLn . ("Removing directory " ++) . show $ item
+ removeDirectoryRecursive item
+ (_,True) -> do
+ putStrLn . ("Removing file " ++) . show $ item
+ removeFile item
+ _ -> return ()
+ )
+ )
+ >>
+ return Nothing
+-- @-node:gcross.20091128000856.1478:removeFilesAndDirectoriesTarget
+-- @+node:gcross.20091128000856.1446:targetFromEither
+targetFromEither :: Either ErrorMessage a -> Target
+targetFromEither (Left error_message) = Just error_message
+targetFromEither (Right _) = Nothing
+-- @-node:gcross.20091128000856.1446:targetFromEither
+-- @-node:gcross.20091128000856.1445:Functions
+-- @-others
+-- @-node:gcross.20091128000856.1441:@thin Main.hs
+-- @-leo
diff --git a/Blueprint/Main.o b/Blueprint/Main.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Main.o differ
diff --git a/Blueprint/Miscellaneous.hs b/Blueprint/Miscellaneous.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Miscellaneous.hs
@@ -0,0 +1,75 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091127142612.1413:@thin Miscellaneous.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091127142612.1414:<< Language extensions >>
+-- @-node:gcross.20091127142612.1414:<< Language extensions >>
+-- @nl
+
+module Blueprint.Miscellaneous where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091127142612.1415:<< Import needed modules >>
+import Control.Parallel
+import Control.Parallel.Strategies
+
+import Data.Dynamic
+import Data.List
+import Data.Typeable
+import Data.Version
+
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+
+import Text.ParserCombinators.ReadP
+-- @-node:gcross.20091127142612.1415:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091127142612.1416:Functions
+-- @+node:gcross.20091129000542.1704:dotsToSubdirectories
+dotsToSubdirectories :: String -> FilePath
+dotsToSubdirectories = joinPath . splitDot
+-- @-node:gcross.20091129000542.1704:dotsToSubdirectories
+-- @+node:gcross.20091129000542.1500:findProgramInPath
+findProgramInPath = unsafePerformIO . findExecutable
+-- @-node:gcross.20091129000542.1500:findProgramInPath
+-- @+node:gcross.20091129000542.1699:isDirectoryAt
+isDirectoryAt = unsafePerformIO . doesDirectoryExist
+-- @-node:gcross.20091129000542.1699:isDirectoryAt
+-- @+node:gcross.20091129000542.1503:isFileAt
+isFileAt = unsafePerformIO . doesFileExist
+-- @-node:gcross.20091129000542.1503:isFileAt
+-- @+node:gcross.20091128000856.1440:myParListWHNF
+myParListWHNF :: Strategy [a]
+myParListWHNF list = go list
+ where
+ go [] = list
+ go (x:xs) = x `par` go xs
+-- @-node:gcross.20091128000856.1440:myParListWHNF
+-- @+node:gcross.20091128000856.1484:readVersion
+readVersion :: String -> Version
+readVersion = fst . last . readP_to_S parseVersion
+-- @-node:gcross.20091128000856.1484:readVersion
+-- @+node:gcross.20091127142612.1418:splitDot
+splitDot :: String -> [String]
+splitDot "" = []
+splitDot s =
+ let (first_part, rest_string) = break (== '.') s
+ in first_part : if null rest_string then [] else splitDot . tail $ rest_string
+-- @-node:gcross.20091127142612.1418:splitDot
+-- @+node:gcross.20091127142612.1420:unsplitDot
+unsplitDot = intercalate "."
+-- @nonl
+-- @-node:gcross.20091127142612.1420:unsplitDot
+-- @+node:gcross.20091129000542.1499:unwrapDynamic
+unwrapDynamic :: Typeable a => Dynamic -> a
+unwrapDynamic dyn = fromDyn dyn (error $ "Unable to cast Dynamic to the expected type! (Type of Dynamic is " ++ show (dynTypeRep dyn) ++ ".)")
+
+-- @-node:gcross.20091129000542.1499:unwrapDynamic
+-- @-node:gcross.20091127142612.1416:Functions
+-- @-others
+-- @-node:gcross.20091127142612.1413:@thin Miscellaneous.hs
+-- @-leo
diff --git a/Blueprint/Miscellaneous.o b/Blueprint/Miscellaneous.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Miscellaneous.o differ
diff --git a/Blueprint/Options.hs b/Blueprint/Options.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Options.hs
@@ -0,0 +1,448 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091129000542.1450:@thin Options.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091129000542.1451:<< Language extensions >>
+-- @-node:gcross.20091129000542.1451:<< Language extensions >>
+-- @nl
+
+module Blueprint.Options where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091129000542.1452:<< Import needed modules >>
+import Control.Applicative hiding (empty)
+import Control.Applicative.Infix
+import Control.Arrow hiding ((<+>))
+import Control.Monad
+import Control.Monad.Error
+
+import Data.Dynamic
+import Data.Either
+import Data.Either.Unwrap
+import Data.Function
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Monoid
+
+import StringTable.Atom
+import StringTable.AtomMap (AtomMap)
+import qualified StringTable.AtomMap as AtomMap
+
+import qualified System.Console.GetOpt as GetOpt
+import System.Environment
+import System.IO.Unsafe
+
+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
+
+import Blueprint.Error
+import Blueprint.Miscellaneous
+-- @-node:gcross.20091129000542.1452:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1489:Values
+-- @+node:gcross.20091129000542.1490:noOptions
+noOptions :: ParsedOptions
+noOptions = AtomMap.empty
+-- @nonl
+-- @-node:gcross.20091129000542.1490:noOptions
+-- @-node:gcross.20091129000542.1489:Values
+-- @+node:gcross.20091129000542.1453:Types
+-- @+node:gcross.20091129000542.1454:Option
+data Option = Option
+ { optionName :: String
+ , optionShortForms :: [Char]
+ , optionLongForms :: [String]
+ , optionArgumentExpectation :: ArgumentExpectation
+ , optionDescription :: String
+ }
+-- @-node:gcross.20091129000542.1454:Option
+-- @+node:gcross.20091129000542.1462:OptionSection
+data OptionSection = OptionSection
+ { optionSectionKey :: OptionSectionKey
+ , optionSectionOptions :: [Option]
+ , optionSectionPostprocessor :: Map String [Maybe String] -> Either Doc Dynamic
+ }
+-- @-node:gcross.20091129000542.1462:OptionSection
+-- @+node:gcross.20091129000542.1575:OptionSectionKey
+newtype OptionSectionKey = OptionSectionKey { unwrapOptionSectionKey :: Atom } deriving (Eq)
+-- @-node:gcross.20091129000542.1575:OptionSectionKey
+-- @+node:gcross.20091129000542.1458:ArgumentExpectation
+data ArgumentExpectation =
+ NoArgumentExpected
+ | ArgumentRequired String
+ | ArgumentOptional String
+-- @-node:gcross.20091129000542.1458:ArgumentExpectation
+-- @+node:gcross.20091129000542.1473:ParsedOptionValue
+type ParsedOptionValue = AtomMap (Map String [Maybe String]) -> AtomMap (Map String [Maybe String])
+-- @-node:gcross.20091129000542.1473:ParsedOptionValue
+-- @+node:gcross.20091129000542.1496:ParsedOptions
+type ParsedOptions = AtomMap Dynamic
+-- @-node:gcross.20091129000542.1496:ParsedOptions
+-- @+node:gcross.20091129000542.1472:OptionDescriptor
+type OptionDescriptor = GetOpt.OptDescr ParsedOptionValue
+-- @nonl
+-- @-node:gcross.20091129000542.1472:OptionDescriptor
+-- @+node:gcross.20091129000542.1474:ArgumentDescriptor
+type ArgumentDescriptor = GetOpt.ArgDescr ParsedOptionValue
+-- @-node:gcross.20091129000542.1474:ArgumentDescriptor
+-- @-node:gcross.20091129000542.1453:Types
+-- @+node:gcross.20091129000542.1455:Functions
+-- @+node:gcross.20091129000542.1486:createDefaultHelpMessage
+createDefaultHelpMessage :: [OptionSection] -> [String] -> Doc
+createDefaultHelpMessage option_sections target_names = vcat
+ [ text "Usage: Setup [options...]"
+ , empty
+ , text "Tool Options:"
+ , indent 4 . createHelpMessageForOptionSections $ option_sections
+ , empty
+ , text "Available targets:"
+ , indent 4 . vcat . map text $ target_names
+ ]
+-- @-node:gcross.20091129000542.1486:createDefaultHelpMessage
+-- @+node:gcross.20091129000542.1477:createHelpMessageForOptionSections
+createHelpMessageForOptionSections :: [OptionSection] -> Doc
+createHelpMessageForOptionSections =
+ vcat
+ .
+ map createHelpMessageForSection
+ .
+ removeDuplicateSections
+
+-- @-node:gcross.20091129000542.1477:createHelpMessageForOptionSections
+-- @+node:gcross.20091129000542.1478:createHelpMessageForSection
+createHelpMessageForSection :: OptionSection -> Doc
+createHelpMessageForSection section =
+ vcat
+ .
+ map text
+ .
+ lines
+ .
+ GetOpt.usageInfo (fromAtom . unwrapOptionSectionKey . optionSectionKey $ section)
+ .
+ createOptionDescriptorsForSection
+ $
+ section
+-- @-node:gcross.20091129000542.1478:createHelpMessageForSection
+-- @+node:gcross.20091129000542.1471:createOptionDescriptorsForSection
+createOptionDescriptorsForSection :: OptionSection -> [OptionDescriptor]
+createOptionDescriptorsForSection =
+ liftA2 map
+ (toOptionDescriptor . optionSectionKey)
+ optionSectionOptions
+-- @-node:gcross.20091129000542.1471:createOptionDescriptorsForSection
+-- @+node:gcross.20091129000542.1461:findConflictingOptions
+findConflictingOptions :: [OptionSection] -> [(Either Char String, [(String,Int)])]
+findConflictingOptions =
+ uncurry (++)
+ .
+ (map (first Left) . findConflicts *** map (first Right) . findConflicts)
+ .
+ processSections Map.empty Map.empty
+ where
+ -- @ @+others
+ -- @+node:gcross.20091129000542.1463:processSections
+ processSections ::
+ Map Char (AtomMap Int) ->
+ Map String (AtomMap Int) ->
+ [OptionSection] ->
+ (Map Char (AtomMap Int),Map String (AtomMap Int))
+ processSections processed_short_options processed_long_options [] =
+ (processed_short_options,processed_long_options)
+ processSections processed_short_options processed_long_options (section:rest_sections) =
+ processSections
+ (processOptions processed_short_options optionShortForms)
+ (processOptions processed_long_options optionLongForms)
+ rest_sections
+ where
+ option_section_key = unwrapOptionSectionKey . optionSectionKey $ section
+ tagWithSectionHeading x = (x,AtomMap.singleton option_section_key 1)
+
+ processOptions :: Ord a => Map a (AtomMap Int) -> (Option -> [a]) -> Map a (AtomMap Int)
+ processOptions processed_options extractForms =
+ foldl' processOption processed_options -- '
+ .
+ map extractForms
+ .
+ optionSectionOptions
+ $
+ section
+
+ processOption :: Ord a => Map a (AtomMap Int) -> [a] -> Map a (AtomMap Int)
+ processOption previously_seen_options =
+ Map.unionWith (AtomMap.unionWith (+)) previously_seen_options
+ .
+ Map.fromList
+ .
+ map tagWithSectionHeading
+ -- @-node:gcross.20091129000542.1463:processSections
+ -- @+node:gcross.20091129000542.1464:findConflicts
+ findConflicts :: Ord a => Map a (AtomMap Int) -> [(a,[(String,Int)])]
+ findConflicts = catMaybes . map (uncurry findConflictsForOption) . Map.assocs
+ where
+ findConflictsForOption option_form option_appearances
+ | (head . AtomMap.elems) option_appearances > 1 || AtomMap.size option_appearances > 1
+ = Just (option_form,map (first fromAtom) . AtomMap.assocs $ option_appearances)
+ | otherwise
+ = Nothing
+ -- @-node:gcross.20091129000542.1464:findConflicts
+ -- @-others
+-- @-node:gcross.20091129000542.1461:findConflictingOptions
+-- @+node:gcross.20091129000542.1475:formatSectionPostprocessingErrorMessage
+formatSectionPostprocessingErrorMessage :: String -> Doc -> Doc
+formatSectionPostprocessingErrorMessage = curry $
+ uncurry ()
+ .
+ (text *** indent 4)
+-- @-node:gcross.20091129000542.1475:formatSectionPostprocessingErrorMessage
+-- @+node:gcross.20091129000542.1483:isHelpFlag
+isHelpFlag = (== "-h") <^(||)^> (== "--help") <^(||)^> (== "-?")
+-- @-node:gcross.20091129000542.1483:isHelpFlag
+-- @+node:gcross.20091129000542.1591:lookupAndUnwrapOptionSection
+lookupAndUnwrapOptionSection :: Typeable a => OptionSectionKey -> ParsedOptions -> Maybe a
+lookupAndUnwrapOptionSection section_key =
+ fmap unwrapDynamic
+ .
+ lookupOptionSection section_key
+-- @-node:gcross.20091129000542.1591:lookupAndUnwrapOptionSection
+-- @+node:gcross.20091129000542.1504:lookupOptionAndVerify
+lookupOptionAndVerify ::
+ (String -> Bool) ->
+ String ->
+ String ->
+ Map String [Maybe String] ->
+ Either Doc (Maybe String)
+lookupOptionAndVerify verifier verification_failure_message option_name option_map =
+ case Map.lookup option_name option_map of
+ Nothing -> Right Nothing
+ Just ((Just value):_) ->
+ if verifier value
+ then Right . Just $ value
+ else Left $ text (verification_failure_message ++ show value)
+ _ -> error "Options were incorrectly parsed."
+-- @-node:gcross.20091129000542.1504:lookupOptionAndVerify
+-- @+node:gcross.20091129000542.1697:lookupOptionAndVerifyDirectoryExists
+lookupOptionAndVerifyDirectoryExists :: String -> Map String [Maybe String] -> Either Doc (Maybe String)
+lookupOptionAndVerifyDirectoryExists =
+ lookupOptionAndVerify
+ isDirectoryAt
+ "There is no directory located at "
+-- @-node:gcross.20091129000542.1697:lookupOptionAndVerifyDirectoryExists
+-- @+node:gcross.20091129000542.1695:lookupOptionAndVerifyFileExists
+lookupOptionAndVerifyFileExists :: String -> Map String [Maybe String] -> Either Doc (Maybe String)
+lookupOptionAndVerifyFileExists =
+ lookupOptionAndVerify
+ isFileAt
+ "There is no file located at "
+-- @-node:gcross.20091129000542.1695:lookupOptionAndVerifyFileExists
+-- @+node:gcross.20091129000542.1589:lookupOptionSection
+lookupOptionSection :: OptionSectionKey -> ParsedOptions -> Maybe Dynamic
+lookupOptionSection (OptionSectionKey key) = AtomMap.lookup key
+-- @-node:gcross.20091129000542.1589:lookupOptionSection
+-- @+node:gcross.20091129000542.1588:makeOptionSectionKey
+makeOptionSectionKey :: String -> OptionSectionKey
+makeOptionSectionKey = OptionSectionKey . toAtom
+-- @-node:gcross.20091129000542.1588:makeOptionSectionKey
+-- @+node:gcross.20091129000542.1508:makeSimpleOptionSection
+makeSimpleOptionSectionForProgram program_name option_section_key =
+ OptionSection
+ { optionSectionKey = option_section_key
+ , optionSectionOptions =
+ [ Option program_name
+ [] ["with-" ++ program_name]
+ (ArgumentRequired "PROGRAM")
+ ("location of " ++ program_name)
+ ]
+ , optionSectionPostprocessor = postprocessOptions
+ }
+ where
+ postprocessOptions = fmap toDyn . lookupOptionAndVerifyFileExists program_name
+-- @-node:gcross.20091129000542.1508:makeSimpleOptionSection
+-- @+node:gcross.20091129000542.1476:parseCommandLineOptions
+parseCommandLineOptions :: [OptionSection] -> Either ErrorMessage (([String],AtomMap Dynamic))
+parseCommandLineOptions = parseOptions (tail . unsafePerformIO $ getArgs)
+-- @-node:gcross.20091129000542.1476:parseCommandLineOptions
+-- @+node:gcross.20091129000542.1466:parseOptions
+parseOptions :: [String] -> [OptionSection] -> Either ErrorMessage ([String],ParsedOptions)
+parseOptions args sections_with_possible_duplicates = do
+ when (not . null $ conflicts) $
+ -- @ << Report that there were conflicting options. >>
+ -- @+node:gcross.20091129000542.1469:<< Report that there were conflicting options. >>
+ throwError
+ .
+ errorMessage "caused by the programmer"
+ .
+ nest 4
+ .
+ (text "The following command line options appear multiple times:" <$$>)
+ .
+ vcat
+ .
+ map (uncurry formatConflictingOption)
+ $
+ conflicts
+ -- @-node:gcross.20091129000542.1469:<< Report that there were conflicting options. >>
+ -- @nl
+ let (results,non_options,error_messages) =
+ GetOpt.getOpt GetOpt.Permute option_descriptors args
+ when (not . null $ error_messages) $
+ -- @ << Report that there were problems parsing the options. >>
+ -- @+node:gcross.20091129000542.1470:<< Report that there were problems parsing the options. >>
+ throwError
+ .
+ errorMessage "parsing command-line options"
+ .
+ (<$$> text "(Use the --help option to get more information on the allowed options.)")
+ .
+ vcat
+ .
+ map text
+ $
+ error_messages
+ -- @-node:gcross.20091129000542.1470:<< Report that there were problems parsing the options. >>
+ -- @nl
+ let option_map :: AtomMap (Map String [Maybe String])
+ option_map = go AtomMap.empty results
+ where
+ go final_result [] = final_result
+ go current_result (fn:rest_fns) = go (fn current_result) rest_fns
+ (section_error_messages,processed_options) =
+ partitionEithers
+ .
+ map (\section ->
+ let OptionSectionKey key = optionSectionKey section
+ in mapBoth ((,) (fromAtom key)) ((,) key)
+ .
+ optionSectionPostprocessor section
+ .
+ fromMaybe Map.empty
+ .
+ AtomMap.lookup key
+ $
+ option_map
+ )
+ $
+ sections
+ if null section_error_messages
+ then
+ Right
+ .
+ (,) non_options
+ .
+ AtomMap.fromList
+ $
+ processed_options
+ else
+ Left
+ .
+ errorMessage "validating options"
+ .
+ vcat
+ .
+ map (uncurry formatSectionPostprocessingErrorMessage)
+ $
+ section_error_messages
+
+ where
+ sections = removeDuplicateSections sections_with_possible_duplicates
+ conflicts = findConflictingOptions sections
+ option_descriptors = concat . map createOptionDescriptorsForSection $ sections
+
+ -- @ @+others
+ -- @+node:gcross.20091129000542.1467:formatConflictingOption
+ formatConflictingOption :: Either Char String -> [(String,Int)] -> Doc
+ formatConflictingOption option_name conflicts =
+ let option_name_heading =
+ case option_name of
+ Left char -> '-':char:[]
+ Right string -> '-':'-':string
+ conflict_strings =
+ vcat
+ .
+ map (uncurry formatConflict)
+ $
+ conflicts
+ in text option_name_heading conflict_strings
+ -- @nonl
+ -- @-node:gcross.20091129000542.1467:formatConflictingOption
+ -- @+node:gcross.20091129000542.1468:formatConflict
+ formatConflict :: String -> Int -> Doc
+ formatConflict heading number_of_appearances =
+ let appearance_string = text $
+ case number_of_appearances of
+ 1 -> "once"
+ 2 -> "twice"
+ 3 -> "thrice"
+ x -> show x ++ " times"
+ in text heading <+> parens (text "appears" <+> appearance_string)
+ -- @nonl
+ -- @-node:gcross.20091129000542.1468:formatConflict
+ -- @-others
+-- @-node:gcross.20091129000542.1466:parseOptions
+-- @+node:gcross.20091129000542.1465:removeDuplicateSections
+removeDuplicateSections :: [OptionSection] -> [OptionSection]
+removeDuplicateSections = nubBy ((==) `on` optionSectionKey)
+-- @-node:gcross.20091129000542.1465:removeDuplicateSections
+-- @+node:gcross.20091129000542.1583:simpleSearchForProgram
+simpleSearchForProgram ::
+ OptionSectionKey ->
+ (FilePath -> a) ->
+ String ->
+ ParsedOptions ->
+ Either ErrorMessage a
+simpleSearchForProgram option_section_key constructor program_name parsed_options =
+ case lookupAndUnwrapOptionSection option_section_key parsed_options of
+ Just Nothing -> searchForProgram
+ Just (Just path) -> Right $ constructor path
+ Nothing -> searchForProgram
+ where
+ searchForProgram =
+ case findProgramInPath program_name of
+ Just path -> Right $ constructor path
+ Nothing ->
+ leftErrorMessageText
+ ("configuring " ++ program_name)
+ (show program_name ++ " was not found in the path")
+-- @-node:gcross.20091129000542.1583:simpleSearchForProgram
+-- @+node:gcross.20091129000542.1457:toArgumentDescriptor
+toArgumentDescriptor :: OptionSectionKey -> String -> ArgumentExpectation -> ArgumentDescriptor
+toArgumentDescriptor (OptionSectionKey section_key) option_name argument_expectation =
+ case argument_expectation of
+ NoArgumentExpected -> GetOpt.NoArg (addToSection Nothing)
+ ArgumentRequired datatype -> GetOpt.ReqArg (addToSection . Just) datatype
+ ArgumentOptional datatype -> GetOpt.OptArg (addToSection) datatype
+ where
+ addToSection :: Maybe String -> ParsedOptionValue
+ addToSection value old_map =
+ case AtomMap.lookup section_key old_map of
+ Nothing ->
+ AtomMap.insert section_key (Map.singleton option_name [value]) old_map
+ Just section_options_map ->
+ flip (AtomMap.insert section_key) old_map
+ .
+ flip (Map.insert option_name) section_options_map
+ $
+ case Map.lookup option_name section_options_map of
+ Nothing -> [value]
+ Just old_values -> (value:old_values)
+-- @-node:gcross.20091129000542.1457:toArgumentDescriptor
+-- @+node:gcross.20091129000542.1456:toOptionDescriptor
+toOptionDescriptor :: OptionSectionKey -> Option -> OptionDescriptor
+toOptionDescriptor section_key =
+ GetOpt.Option
+ <$> optionShortForms
+ <*> optionLongForms
+ <*> (liftA2 (toArgumentDescriptor section_key)
+ optionName
+ optionArgumentExpectation
+ )
+ <*> optionDescription
+-- @-node:gcross.20091129000542.1456:toOptionDescriptor
+-- @-node:gcross.20091129000542.1455:Functions
+-- @-others
+-- @-node:gcross.20091129000542.1450:@thin Options.hs
+-- @-leo
diff --git a/Blueprint/Options.o b/Blueprint/Options.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Options.o differ
diff --git a/Blueprint/Resources.hs b/Blueprint/Resources.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Resources.hs
@@ -0,0 +1,149 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091121210308.1276:@thin Resources.hs
+-- @@language Haskell
+
+module Blueprint.Resources where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091121210308.1278:<< Import needed modules >>
+import Control.Arrow
+import Control.Parallel.Strategies
+
+import qualified Data.ByteString.Lazy as L
+import Data.Digest.Pure.MD5
+import Data.Either
+import Data.Either.Unwrap
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import System.Directory
+import System.FilePath
+import System.IO.Unsafe
+
+import Blueprint.Error
+import Blueprint.Miscellaneous
+-- @-node:gcross.20091121210308.1278:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091121210308.1277:Types
+-- @+node:gcross.20091121210308.1279:Resource
+data Resource = Resource
+ { resourceName :: !String
+ , resourceType :: !String
+ , resourceFilePath :: !FilePath
+ , resourceDigest :: Either ErrorMessage MD5Digest
+ , resourceDependencies :: [ResourceId]
+ }
+-- @-node:gcross.20091121210308.1279:Resource
+-- @+node:gcross.20091121210308.1284:Resources
+type Resources = Map ResourceId Resource
+-- @-node:gcross.20091121210308.1284:Resources
+-- @+node:gcross.20091122100142.1326:ResourceId
+type ResourceId = (String,String)
+-- @-node:gcross.20091122100142.1326:ResourceId
+-- @-node:gcross.20091121210308.1277:Types
+-- @+node:gcross.20091121210308.1280:Functions
+-- @+node:gcross.20091121210308.2039:addResource
+addResource :: Resource -> Resources -> Resources
+addResource resource = Map.insert ((resourceName &&& resourceType) resource) resource
+-- @-node:gcross.20091121210308.2039:addResource
+-- @+node:gcross.20091121210308.1293:applyPrefix
+applyPrefix :: String -> String -> String
+applyPrefix "" = id
+applyPrefix prefix = (prefix ++) . ('.':)
+-- @-node:gcross.20091121210308.1293:applyPrefix
+-- @+node:gcross.20091122100142.1331:attemptGetDigests
+attemptGetDigests :: [Resource] -> Either ErrorMessage [MD5Digest]
+attemptGetDigests =
+ extractResultsOrError
+ .
+ myParListWHNF
+ .
+ map resourceDigest
+-- @-node:gcross.20091122100142.1331:attemptGetDigests
+-- @+node:gcross.20091122100142.1332:attemptGetResourceDigests
+attemptGetResourceDigests :: Resources -> [ResourceId] -> Either (Either [ResourceId] ErrorMessage) [MD5Digest]
+attemptGetResourceDigests resources resource_ids =
+ either
+ (Left . Left)
+ (mapLeft Right . attemptGetDigests)
+ $
+ attemptGetResources resources resource_ids
+-- @-node:gcross.20091122100142.1332:attemptGetResourceDigests
+-- @+node:gcross.20091122100142.1329:attemptGetResources
+attemptGetResources :: Resources -> [ResourceId] -> Either [ResourceId] [Resource]
+attemptGetResources resources =
+ extractResultsOrErrors
+ .
+ map (\resource_id ->
+ case Map.lookup resource_id resources of
+ Nothing -> Left resource_id
+ Just resource -> Right resource
+ )
+-- @-node:gcross.20091122100142.1329:attemptGetResources
+-- @+node:gcross.20091121210308.1286:createResourceFor
+createResourceFor :: String -> FilePath -> Resource
+createResourceFor prefix filepath =
+ let (name, extension) = splitExtension . takeFileName $ filepath
+ in Resource
+ { resourceName = applyPrefix prefix name
+ , resourceType = if extension == "" then "" else tail extension
+ , resourceFilePath = filepath
+ , resourceDigest = Right . digestOf $ filepath
+ , resourceDependencies = []
+ }
+-- @-node:gcross.20091121210308.1286:createResourceFor
+-- @+node:gcross.20091121210308.1285:digestOf
+digestOf :: FilePath -> MD5Digest
+digestOf = md5 . unsafePerformIO . L.readFile
+-- @-node:gcross.20091121210308.1285:digestOf
+-- @+node:gcross.20091121210308.2033:getFilePathForNameAndType
+getFilePathForNameAndType :: FilePath -> String -> String -> FilePath
+getFilePathForNameAndType directory name typ =
+ let partial_path = (joinPath (directory:splitDot name))
+ in if null typ then partial_path else partial_path <.> typ
+-- @-node:gcross.20091121210308.2033:getFilePathForNameAndType
+-- @+node:gcross.20091122100142.1388:resourceId
+resourceId :: Resource -> ResourceId
+resourceId = (resourceName &&& resourceType)
+-- @-node:gcross.20091122100142.1388:resourceId
+-- @+node:gcross.20091121210308.1292:resourcesIn
+resourcesIn = resourcesWithPrefixIn ""
+-- @-node:gcross.20091121210308.1292:resourcesIn
+-- @+node:gcross.20091121210308.1281:resourcesWithPrefixIn
+resourcesWithPrefixIn :: String -> FilePath -> Resources
+resourcesWithPrefixIn prefix directory =
+ let (resource_list,subdirectory_resources) =
+ partitionEithers
+ .
+ myParListWHNF
+ .
+ map (\filename ->
+ let filepath = combine directory filename
+ in if (unsafePerformIO . doesDirectoryExist $ filepath)
+ then Right . resourcesWithPrefixIn (applyPrefix prefix filename) $ filepath
+ else Left . createResourceFor prefix $ filepath
+ )
+ .
+ filter ((/= '.') . head)
+ .
+ unsafePerformIO
+ .
+ getDirectoryContents
+ $
+ directory
+ in Map.unions . (toResources resource_list:) $ subdirectory_resources
+-- @-node:gcross.20091121210308.1281:resourcesWithPrefixIn
+-- @+node:gcross.20091121210308.1288:toResources
+toResources :: [Resource] -> Resources
+toResources =
+ Map.fromList
+ .
+ map ((resourceName &&& resourceType) &&& id)
+-- @-node:gcross.20091121210308.1288:toResources
+-- @-node:gcross.20091121210308.1280:Functions
+-- @-others
+-- @-node:gcross.20091121210308.1276:@thin Resources.hs
+-- @-leo
diff --git a/Blueprint/Resources.o b/Blueprint/Resources.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Resources.o differ
diff --git a/Blueprint/Tools/Ar.hs b/Blueprint/Tools/Ar.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Tools/Ar.hs
@@ -0,0 +1,116 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091122100142.1360:@thin Ar.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091122100142.1361:<< Language extensions >>
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+-- @nonl
+-- @-node:gcross.20091122100142.1361:<< Language extensions >>
+-- @nl
+
+module Blueprint.Tools.Ar where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091122100142.1362:<< Import needed modules >>
+import Control.Monad
+
+import Data.Dynamic
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO.Unsafe
+import System.Process
+
+import Blueprint.Configuration
+import Blueprint.Cache.ExplicitDependencies
+import Blueprint.Error
+import Blueprint.Miscellaneous
+import Blueprint.Options
+import Blueprint.Resources
+-- @-node:gcross.20091122100142.1362:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1572:Keys
+arOptionSectionKey = makeOptionSectionKey "ar"
+arConfigurationKey = makeConfigurationKey "path to ar"
+-- @-node:gcross.20091129000542.1572:Keys
+-- @+node:gcross.20091122100142.1363:Types
+-- @+node:gcross.20091122100142.1364:ArConfiguration
+data ArConfiguration = ArConfiguration { arPath :: FilePath } deriving (Show)
+-- @-node:gcross.20091122100142.1364:ArConfiguration
+-- @-node:gcross.20091122100142.1363:Types
+-- @+node:gcross.20091128000856.1422:Instances
+-- @+node:gcross.20091128000856.1423:ConfigurationData ArConfiguration
+instance ConfigurationData ArConfiguration where
+ readConfig = simpleReadConfig arConfigurationKey ArConfiguration
+ writeConfig = simpleWriteConfig arConfigurationKey arPath
+-- @-node:gcross.20091128000856.1423:ConfigurationData ArConfiguration
+-- @+node:gcross.20091128000856.1424:AutomaticallyConfigurable ArConfiguration
+instance AutomaticallyConfigurable ArConfiguration where
+ automaticallyConfigure = simpleSearchForProgram arOptionSectionKey ArConfiguration "ar"
+-- @-node:gcross.20091128000856.1424:AutomaticallyConfigurable ArConfiguration
+-- @-node:gcross.20091128000856.1422:Instances
+-- @+node:gcross.20091129000542.1502:Options processing
+arOptions = makeSimpleOptionSectionForProgram "ar" arOptionSectionKey
+-- @-node:gcross.20091129000542.1502:Options processing
+-- @+node:gcross.20091122100142.1367:Tools
+-- @+node:gcross.20091122100142.1368:formStaticLibrary
+formStaticLibrary ::
+ ArConfiguration ->
+ FilePath ->
+ [Resource] ->
+ String ->
+ FilePath ->
+ Resource
+formStaticLibrary
+ tools
+ cache_directory
+ object_resources
+ library_resource_name
+ library_resource_filepath
+ = Resource
+ { resourceName = library_resource_name
+ , resourceType = "a"
+ , resourceFilePath = library_resource_filepath
+ , resourceDigest = library_digest
+ , resourceDependencies = map resourceId object_resources
+ }
+ where
+ library_digest = either Left (Right . head) $
+ analyzeExplicitDependenciesAndRebuildIfNecessary
+ builder
+ (cache_directory library_resource_name <.> "a")
+ [library_resource_filepath]
+ ()
+ object_resources
+
+ builder = do
+ createDirectoryIfMissing True . takeDirectory $ library_resource_filepath
+ let arguments = ("cqs":library_resource_filepath:map resourceFilePath object_resources)
+ command = (arPath tools)
+ putStrLn . unwords . (command:) $ arguments
+ compilation_result <-
+ readProcessWithExitCode
+ command
+ arguments
+ ""
+ case compilation_result of
+ (ExitFailure _,_,error_message) ->
+ return
+ .
+ Just
+ .
+ errorMessageTextWithLines ("linking " ++ library_resource_name)
+ $
+ error_message
+ (ExitSuccess,_,_) -> return Nothing
+
+-- @-node:gcross.20091122100142.1368:formStaticLibrary
+-- @-node:gcross.20091122100142.1367:Tools
+-- @-others
+-- @-node:gcross.20091122100142.1360:@thin Ar.hs
+-- @-leo
diff --git a/Blueprint/Tools/Ar.o b/Blueprint/Tools/Ar.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Tools/Ar.o differ
diff --git a/Blueprint/Tools/GCC.hs b/Blueprint/Tools/GCC.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Tools/GCC.hs
@@ -0,0 +1,155 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091123114318.1335:@thin GCC.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091123114318.1337:<< Language extensions >>
+-- @-node:gcross.20091123114318.1337:<< Language extensions >>
+-- @nl
+
+module Blueprint.Tools.GCC where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091123114318.1339:<< Import needed modules >>
+import Control.Applicative.Infix
+import Control.Monad
+
+import Data.Map (Map)
+import qualified Data.Map as Map
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO.Unsafe
+import System.Process
+
+import Text.PrettyPrint.ANSI.Leijen hiding (())
+
+import Blueprint.Cache.ExplicitDependencies
+import Blueprint.Configuration
+import Blueprint.Error
+import Blueprint.Options
+import Blueprint.Resources
+-- @-node:gcross.20091123114318.1339:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1577:Keys
+gccOptionSectionKey = makeOptionSectionKey "GCC"
+gccConfigurationKey = makeConfigurationKey "path to gcc"
+-- @-node:gcross.20091129000542.1577:Keys
+-- @+node:gcross.20091123114318.1342:Types
+-- @+node:gcross.20091123114318.1343:GCCConfiguration
+data GCCConfiguration = GCCConfiguration { gccCompilerPath :: FilePath } deriving (Show)
+-- @-node:gcross.20091123114318.1343:GCCConfiguration
+-- @-node:gcross.20091123114318.1342:Types
+-- @+node:gcross.20091128000856.1436:Instances
+-- @+node:gcross.20091128000856.1437:ConfigurationData GCCConfiguration
+instance ConfigurationData GCCConfiguration where
+ readConfig = simpleReadConfig gccConfigurationKey GCCConfiguration
+ writeConfig = simpleWriteConfig gccConfigurationKey gccCompilerPath
+-- @-node:gcross.20091128000856.1437:ConfigurationData GCCConfiguration
+-- @+node:gcross.20091128000856.1438:AutomaticallyConfigurable GCCConfiguration
+instance AutomaticallyConfigurable GCCConfiguration where
+ automaticallyConfigure = simpleSearchForProgram gccOptionSectionKey GCCConfiguration "gcc"
+-- @-node:gcross.20091128000856.1438:AutomaticallyConfigurable GCCConfiguration
+-- @-node:gcross.20091128000856.1436:Instances
+-- @+node:gcross.20091129000542.1585:Options processing
+gccOptions = makeSimpleOptionSectionForProgram "gcc" gccOptionSectionKey
+-- @-node:gcross.20091129000542.1585:Options processing
+-- @+node:gcross.20091123114318.1372:Tools
+-- @+node:gcross.20091123114318.1368:gccCompile
+gccCompile ::
+ GCCConfiguration ->
+ [String] ->
+ FilePath ->
+ FilePath ->
+ Resource ->
+ Resource
+gccCompile
+ tools
+ options
+ object_destination_directory
+ cache_directory
+ source_resource
+ =
+ Resource
+ { resourceName = source_name
+ , resourceType = "o"
+ , resourceFilePath = object_filepath
+ , resourceDigest = object_digest
+ , resourceDependencies = [resourceId source_resource]
+ }
+ where
+ source_filepath = resourceFilePath source_resource
+ source_name = resourceName source_resource
+ object_filepath = getFilePathForNameAndType object_destination_directory source_name "o"
+
+ builder =
+ let arguments =
+ options ++
+ ["-c",source_filepath
+ ,"-o",object_filepath
+ ]
+ path_to_gcc = gccCompilerPath tools
+ in do
+ createDirectoryIfMissing True . takeDirectory $ object_filepath
+ putStrLn . unwords $ (path_to_gcc:arguments)
+ compilation_result <- readProcessWithExitCode path_to_gcc arguments ""
+ case compilation_result of
+ (ExitFailure _,_,error_message) ->
+ return
+ .
+ Just
+ .
+ errorMessageTextWithLines ("compiling " ++ source_name)
+ $
+ error_message
+ (ExitSuccess,_,_) -> return Nothing
+
+ object_digest =
+ case analyzeDependencyAndRebuildIfNecessary
+ builder
+ (cache_directory source_name <.> "o")
+ [object_filepath]
+ (unwords options)
+ source_resource
+ of Left error_message -> Left error_message
+ Right [object_digest] -> Right object_digest
+ x -> error $ "Programmer error: Builder returned the wrong number of digests! (" ++ show x ++ ")"
+-- @-node:gcross.20091123114318.1368:gccCompile
+-- @+node:gcross.20091123114318.1371:gccCompileAll
+gccCompileAll ::
+ GCCConfiguration ->
+ [String] ->
+ FilePath ->
+ FilePath ->
+ Resources ->
+ Resources
+gccCompileAll
+ tools
+ options
+ object_destination_directory
+ cache_directory
+ old_resources
+ =
+ new_resources
+ where
+ new_resources = go old_resources (Map.elems old_resources)
+ go accum_resources [] = accum_resources
+ go accum_resources (resource:rest_resources) =
+ if resourceType (resource) == "c"
+ then let object_resource =
+ gccCompile
+ tools
+ options
+ object_destination_directory
+ cache_directory
+ resource
+ in go (addResource object_resource accum_resources) rest_resources
+ else go accum_resources rest_resources
+-- @-node:gcross.20091123114318.1371:gccCompileAll
+-- @-node:gcross.20091123114318.1372:Tools
+-- @-others
+-- @-node:gcross.20091123114318.1335:@thin GCC.hs
+-- @-leo
diff --git a/Blueprint/Tools/GFortran.hs b/Blueprint/Tools/GFortran.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Tools/GFortran.hs
@@ -0,0 +1,164 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091129000542.1552:@thin GFortran.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091129000542.1553:<< Language extensions >>
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+-- @nonl
+-- @-node:gcross.20091129000542.1553:<< Language extensions >>
+-- @nl
+
+module Blueprint.Tools.GFortran where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091129000542.1554:<< Import needed modules >>
+import Control.Monad
+
+import Data.Dynamic
+import qualified Data.Map as Map
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO.Unsafe
+import System.Process
+
+import Blueprint.Configuration
+import Blueprint.Cache.ExplicitDependencies
+import Blueprint.Error
+import Blueprint.Miscellaneous
+import Blueprint.Options
+import Blueprint.Resources
+-- @-node:gcross.20091129000542.1554:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1579:Keys
+gfortranOptionSectionKey = makeOptionSectionKey "gfortran"
+gfortranConfigurationKey = makeConfigurationKey "path to gfortran"
+-- @-node:gcross.20091129000542.1579:Keys
+-- @+node:gcross.20091129000542.1555:Types
+-- @+node:gcross.20091129000542.1556:GFortranConfiguration
+data GFortranConfiguration = GFortranConfiguration { gfortranCompilerPath :: FilePath } deriving (Show)
+-- @-node:gcross.20091129000542.1556:GFortranConfiguration
+-- @-node:gcross.20091129000542.1555:Types
+-- @+node:gcross.20091129000542.1557:Instances
+-- @+node:gcross.20091129000542.1558:ConfigurationData GFortranTools
+instance ConfigurationData GFortranConfiguration where
+ readConfig = simpleReadConfig gfortranConfigurationKey GFortranConfiguration
+ writeConfig = simpleWriteConfig gfortranConfigurationKey gfortranCompilerPath
+-- @-node:gcross.20091129000542.1558:ConfigurationData GFortranTools
+-- @+node:gcross.20091129000542.1559:AutomaticallyConfigurable GFortranTools
+instance AutomaticallyConfigurable GFortranConfiguration where
+ automaticallyConfigure = simpleSearchForProgram gfortranOptionSectionKey GFortranConfiguration "gfortran"
+-- @-node:gcross.20091129000542.1559:AutomaticallyConfigurable GFortranTools
+-- @-node:gcross.20091129000542.1557:Instances
+-- @+node:gcross.20091129000542.1560:Options processing
+gfortranOptions = makeSimpleOptionSectionForProgram "gfortran" gfortranOptionSectionKey
+-- @-node:gcross.20091129000542.1560:Options processing
+-- @+node:gcross.20091129000542.1566:Tools
+-- @+node:gcross.20091129000542.1567:gfortranCompile
+gfortranCompile ::
+ GFortranConfiguration ->
+ [String] ->
+ FilePath ->
+ FilePath ->
+ FilePath ->
+ Resource ->
+ Resource
+gfortranCompile
+ tools
+ options
+ object_destination_directory
+ interface_destination_directory
+ cache_directory
+ source_resource
+ =
+ Resource
+ { resourceName = source_name
+ , resourceType = "o"
+ , resourceFilePath = object_filepath
+ , resourceDigest = object_digest
+ , resourceDependencies = [resourceId source_resource]
+ }
+ where
+ source_filepath = resourceFilePath source_resource
+ source_name = resourceName source_resource
+ object_filepath = getFilePathForNameAndType object_destination_directory source_name "o"
+
+ builder =
+ let arguments =
+ options ++
+ ["-J"++interface_destination_directory
+ ,"-c",source_filepath
+ ,"-o",object_filepath
+ ]
+ path_to_gfortran = gfortranCompilerPath tools
+ in do
+ createDirectoryIfMissing True . takeDirectory $ interface_destination_directory
+ createDirectoryIfMissing True . takeDirectory $ object_filepath
+ putStrLn . unwords $ (path_to_gfortran:arguments)
+ compilation_result <- readProcessWithExitCode path_to_gfortran arguments ""
+ case compilation_result of
+ (ExitFailure _,_,error_message) ->
+ return
+ .
+ Just
+ .
+ errorMessageTextWithLines ("compiling " ++ source_name)
+ $
+ error_message
+ (ExitSuccess,_,_) -> return Nothing
+
+ object_digest =
+ case analyzeDependencyAndRebuildIfNecessary
+ builder
+ (cache_directory source_name <.> "o")
+ [object_filepath]
+ (unwords options)
+ source_resource
+ of Left error_message -> Left error_message
+ Right [object_digest] -> Right object_digest
+ x -> error $ "Programmer error: Builder returned the wrong number of digests! (" ++ show x ++ ")"
+-- @-node:gcross.20091129000542.1567:gfortranCompile
+-- @+node:gcross.20091129000542.1568:gfortranCompileAll
+gfortranCompileAll ::
+ GFortranConfiguration ->
+ [String] ->
+ FilePath ->
+ FilePath ->
+ FilePath ->
+ Resources ->
+ Resources
+gfortranCompileAll
+ tools
+ options
+ object_destination_directory
+ interface_destination_directory
+ cache_directory
+ old_resources
+ =
+ new_resources
+ where
+ new_resources = go old_resources (Map.elems old_resources)
+ go accum_resources [] = accum_resources
+ go accum_resources (resource:rest_resources) =
+ if resourceType (resource) `elem` ["f","f77","f90","f95"]
+ then let object_resource =
+ gfortranCompile
+ tools
+ options
+ object_destination_directory
+ interface_destination_directory
+ cache_directory
+ resource
+ in go (addResource object_resource $ accum_resources) rest_resources
+ else go accum_resources rest_resources
+
+-- @-node:gcross.20091129000542.1568:gfortranCompileAll
+-- @-node:gcross.20091129000542.1566:Tools
+-- @-others
+-- @-node:gcross.20091129000542.1552:@thin GFortran.hs
+-- @-leo
diff --git a/Blueprint/Tools/GHC.hs b/Blueprint/Tools/GHC.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Tools/GHC.hs
@@ -0,0 +1,784 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091121204836.1242:@thin GHC.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091122100142.1309:<< Language extensions >>
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+-- @-node:gcross.20091122100142.1309:<< Language extensions >>
+-- @nl
+
+module Blueprint.Tools.GHC where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091121210308.1269:<< Import needed modules >>
+import Prelude hiding (catch)
+
+import Control.Arrow hiding ((<+>))
+import Control.Applicative
+import Control.Applicative.Infix
+import Control.Exception
+import Control.Monad
+
+import Data.Array
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Data
+import Data.Digest.Pure.MD5
+import Data.Dynamic
+import Data.Either
+import Data.Either.Unwrap
+import Data.List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Version
+
+import Distribution.ModuleName
+import Distribution.InstalledPackageInfo
+ (InstalledPackageInfo_(..)
+ ,InstalledPackageInfo
+ ,showInstalledPackageInfo
+ )
+import Distribution.Package
+import Distribution.PackageDescription as Package
+import qualified Distribution.PackageDescription.Parse
+import Distribution.Text
+import Distribution.Verbosity
+import Distribution.Version
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO
+import System.IO.Unsafe
+import System.Process
+
+import Text.PrettyPrint.ANSI.Leijen hiding ((),(<$>))
+
+import Text.Regex.TDFA
+import Text.Regex.TDFA.ByteString.Lazy
+
+import Blueprint.Cache.ExplicitDependencies
+import Blueprint.Cache.ImplicitDependencies
+import Blueprint.Configuration
+import Blueprint.Error
+import Blueprint.Miscellaneous
+import Blueprint.Options
+import Blueprint.Resources
+import Blueprint.Tools.Installer
+
+import Debug.Trace
+-- @-node:gcross.20091121210308.1269:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1587:Keys
+ghcOptionSectionKey = makeOptionSectionKey "GHC"
+
+ghcVersionKey = makeConfigurationKey "ghc version"
+ghcCompilerPathKey = makeConfigurationKey "path to ghc"
+ghcPackageManagerKey = makeConfigurationKey "path to ghc-pkg"
+ghcPackagesKey = makeConfigurationKey "packages"
+-- @-node:gcross.20091129000542.1587:Keys
+-- @+node:gcross.20091121210308.1270:Types
+-- @+node:gcross.20091121210308.1271:GHCConfiguration
+data GHCConfiguration = GHCConfiguration
+ { ghcVersion :: Version
+ , ghcCompilerPath :: String
+ , ghcPackageManagerPath :: String
+ } deriving (Show)
+-- @-node:gcross.20091121210308.1271:GHCConfiguration
+-- @+node:gcross.20091129000542.1481:GHCOptions
+data GHCOptions = GHCOptions
+ { ghcOptionCompilerPath :: Maybe FilePath
+ , ghcOptionPackageManagerPath :: Maybe FilePath
+ } deriving (Typeable, Show)
+
+-- @-node:gcross.20091129000542.1481:GHCOptions
+-- @+node:gcross.20091121210308.2025:PackageModules
+type PackageModules = Map String String
+-- @-node:gcross.20091121210308.2025:PackageModules
+-- @+node:gcross.20091128201230.1462:ResolvedPackages
+newtype ResolvedPackages = ResolvedPackages [String]
+-- @-node:gcross.20091128201230.1462:ResolvedPackages
+-- @-node:gcross.20091121210308.1270:Types
+-- @+node:gcross.20091127142612.1405:Instances
+-- @+node:gcross.20091127142612.1406:ConfigurationData GHCConfiguration
+instance ConfigurationData GHCConfiguration where
+ readConfig =
+ liftM3 GHCConfiguration
+ (fmap readVersion $ getConfig ghcVersionKey)
+ (getConfig ghcCompilerPathKey)
+ (getConfig ghcPackageManagerKey)
+ writeConfig =
+ (setConfig ghcVersionKey . showVersion . ghcVersion)
+ <^(>>)^>
+ (setConfig ghcCompilerPathKey . ghcCompilerPath)
+ <^(>>)^>
+ (setConfig ghcPackageManagerKey . ghcPackageManagerPath)
+-- @-node:gcross.20091127142612.1406:ConfigurationData GHCConfiguration
+-- @+node:gcross.20091128000856.1410:AutomaticallyConfigurable GHCConfiguration
+instance AutomaticallyConfigurable GHCConfiguration where
+ automaticallyConfigure parsed_options =
+ case lookupAndUnwrapOptionSection ghcOptionSectionKey parsed_options of
+ Nothing -> configureFromScratch
+ Just opt@(GHCOptions maybe_path_to_ghc maybe_path_to_ghc_pkg) ->
+ case (maybe_path_to_ghc,maybe_path_to_ghc_pkg) of
+ (Nothing,Nothing) ->
+ configureFromScratch
+ (Just path_to_ghc,Just path_to_ghc_pkg) ->
+ verifyConsistentVersionsAndReturn path_to_ghc path_to_ghc_pkg
+ (Just path_to_ghc,Nothing) ->
+ findProgramUsingPath "ghc-pkg" path_to_ghc
+ >>=
+ verifyConsistentVersionsAndReturn path_to_ghc
+ (Nothing, Just path_to_ghc_pkg) ->
+ findProgramUsingPath "ghc" path_to_ghc_pkg
+ >>=
+ flip verifyConsistentVersionsAndReturn path_to_ghc_pkg
+ where
+ -- @ @+others
+ -- @+node:gcross.20091129000542.1491:configurationError
+ configurationError = leftErrorMessageText "configuring GHC"
+ -- @nonl
+ -- @-node:gcross.20091129000542.1491:configurationError
+ -- @+node:gcross.20091129000542.1492:configureFromScratch
+ configureFromScratch :: Either ErrorMessage GHCConfiguration
+ configureFromScratch =
+ case unsafePerformIO . findExecutable $ "ghc" of
+ Nothing -> configurationError "Unable to find ghc in the path"
+ Just path_to_ghc -> do
+ path_to_ghc_pkg <- findProgramUsingPath "ghc-pkg" path_to_ghc
+ verifyConsistentVersionsAndReturn path_to_ghc path_to_ghc_pkg
+ -- @-node:gcross.20091129000542.1492:configureFromScratch
+ -- @+node:gcross.20091129000542.1493:findProgramUsingPath
+ findProgramUsingPath program_name = findProgramUsingDirectory program_name . takeDirectory
+ -- @nonl
+ -- @-node:gcross.20091129000542.1493:findProgramUsingPath
+ -- @+node:gcross.20091129000542.1494:findProgramUsingDirectory
+ findProgramUsingDirectory :: String -> FilePath -> Either ErrorMessage FilePath
+ findProgramUsingDirectory program_name directory_to_search
+ | unsafePerformIO . doesFileExist $ first_location_to_check
+ = Right first_location_to_check
+ | Just location <- unsafePerformIO . findExecutable $ program_name
+ = Right location
+ | otherwise
+ = configurationError $ "Unable to find " ++ show program_name
+ where
+ first_location_to_check = directory_to_search program_name
+ -- @-node:gcross.20091129000542.1494:findProgramUsingDirectory
+ -- @+node:gcross.20091129000542.1495:verifyConsistentVersionsAndReturn
+ verifyConsistentVersionsAndReturn :: FilePath -> FilePath -> Either ErrorMessage GHCConfiguration
+ verifyConsistentVersionsAndReturn path_to_ghc path_to_ghc_pkg =
+ mapLeft (errorMessage "configuring GHC") $ do
+ (ghc_version,ghc_pkg_version) <- liftA2 (,) (getVersionOf path_to_ghc) (getVersionOf path_to_ghc_pkg)
+ if ghc_version == ghc_pkg_version
+ then return $
+ GHCConfiguration
+ { ghcVersion = ghc_version
+ , ghcCompilerPath = path_to_ghc
+ , ghcPackageManagerPath = path_to_ghc_pkg
+ }
+ else Left . text $
+ "'ghc' and 'ghc-pkg' have different version! ("
+ ++ showVersion ghc_version ++
+ " /= "
+ ++ showVersion ghc_pkg_version ++
+ ")"
+ where
+ getVersionOf :: String -> Either Doc Version
+ getVersionOf path_to_program =
+ mapLeft (\(_ :: SomeException) ->
+ text $ "Unable to determine the version of " ++ path_to_program
+ )
+ .
+ unsafePerformIO
+ .
+ try
+ $
+ (
+ readProcess path_to_program ["--version"] ""
+ >>=
+ evaluate
+ .
+ readVersion
+ .
+ last
+ .
+ words
+ )
+ -- @-node:gcross.20091129000542.1495:verifyConsistentVersionsAndReturn
+ -- @-others
+-- @-node:gcross.20091128000856.1410:AutomaticallyConfigurable GHCConfiguration
+-- @-node:gcross.20091127142612.1405:Instances
+-- @+node:gcross.20091121210308.2014:Values
+-- @+node:gcross.20091121210308.2015:regular expressions
+import_matching_regex = fromRight . compile defaultCompOpt defaultExecOpt . L8.pack $ "\\s*import +(qualified +)?([A-Z][A-Za-z0-9_.]+)[\\s;]?"
+-- @-node:gcross.20091121210308.2015:regular expressions
+-- @-node:gcross.20091121210308.2014:Values
+-- @+node:gcross.20091121210308.2016:Functions
+-- @+node:gcross.20091121210308.2017:readDependenciesOf
+readDependenciesOf :: FilePath -> IO [String]
+readDependenciesOf =
+ L.readFile
+ >=>
+ return
+ .
+ map (L8.unpack . fst . (! 2))
+ .
+ matchAllText import_matching_regex
+-- @-node:gcross.20091121210308.2017:readDependenciesOf
+-- @+node:gcross.20091122100142.1335:prefixWith
+prefixWith :: String -> [String] -> [String]
+prefixWith _ [] = []
+prefixWith s list = s:intersperse s list
+-- @-node:gcross.20091122100142.1335:prefixWith
+-- @+node:gcross.20091127142612.1403:findAllObjectDependenciesOf
+findAllObjectDependenciesOf :: Resources -> Resource -> [Resource]
+findAllObjectDependenciesOf known_resources object_resource =
+ Map.elems $ findAsMapAllObjectDependenciesOf known_resources object_resource
+-- @-node:gcross.20091127142612.1403:findAllObjectDependenciesOf
+-- @+node:gcross.20091127142612.1404:findAsMapAllObjectDependenciesOf
+findAsMapAllObjectDependenciesOf :: Resources -> Resource -> Map ResourceId Resource
+findAsMapAllObjectDependenciesOf known_resources object_resource =
+ Map.insert (resourceId object_resource) object_resource
+ .
+ Map.unions
+ .
+ catMaybes
+ .
+ map (\(resource_name,resource_type) ->
+ if resource_type /= "hi"
+ then Nothing
+ else
+ case Map.lookup (resource_name,"o") known_resources of
+ Nothing ->
+ error $ "Unable to find in known resources the dependent resource with id " ++ show (resource_name,"o")
+ Just object_resource ->
+ Just (findAsMapAllObjectDependenciesOf known_resources object_resource)
+ )
+ .
+ resourceDependencies
+ $
+ object_resource
+-- @-node:gcross.20091127142612.1404:findAsMapAllObjectDependenciesOf
+-- @+node:gcross.20091129000542.1705:qualifiedNameToPackageIdentifier
+qualifiedNameToPackageIdentifier :: String -> PackageIdentifier
+qualifiedNameToPackageIdentifier name =
+ uncurry PackageIdentifier
+ .
+ (PackageName *** (readVersion . tail))
+ .
+ flip splitAt name
+ .
+ last
+ .
+ elemIndices '-'
+ $
+ name
+-- @-node:gcross.20091129000542.1705:qualifiedNameToPackageIdentifier
+-- @+node:gcross.20091129000542.1709:makeEverythingReadableIn
+makeEverythingReadableIn :: FilePath -> IO ()
+makeEverythingReadableIn path = do
+ putStrLn $ "Setting read permissions on " ++ path
+ is_file <- doesFileExist path
+ if is_file
+ then setPermissions path (Permissions True False False False)
+ else
+ setPermissions path (Permissions True False False True)
+ >>
+ fmap (filter ((/= '.') . head)) (getDirectoryContents path)
+ >>=
+ mapM_ (makeEverythingReadableIn . (path ))
+-- @-node:gcross.20091129000542.1709:makeEverythingReadableIn
+-- @+node:gcross.20091129000542.1710:createDirectoryNoisilyIfMissing
+createDirectoryNoisilyIfMissing directory =
+ doesDirectoryExist directory
+ >>=
+ flip unless (
+ do
+ putStrLn $ "Creating directory " ++ directory
+ createDirectoryIfMissing True directory
+ )
+-- @-node:gcross.20091129000542.1710:createDirectoryNoisilyIfMissing
+-- @-node:gcross.20091121210308.2016:Functions
+-- @+node:gcross.20091129000542.1479:Options processing
+ghcOptions =
+ OptionSection
+ { optionSectionKey = ghcOptionSectionKey
+ , optionSectionOptions =
+ [ Option "ghc"
+ [] ["with-ghc"]
+ (ArgumentRequired "PROGRAM")
+ "location of the Glasglow Haskell Compiler"
+ , Option "ghc-pkg"
+ [] ["with-ghc-pkg"]
+ (ArgumentRequired "PROGRAM")
+ "location of the GHC package database management tool"
+ ]
+ , optionSectionPostprocessor = postprocessOptions
+ }
+ where
+ postprocessOptions :: Map String [Maybe String] -> Either Doc Dynamic
+ postprocessOptions option_map = fmap toDyn $
+ liftA2 GHCOptions
+ (lookupOptionAndVerifyFileExists "ghc" option_map)
+ (lookupOptionAndVerifyFileExists "ghc-pkg" option_map)
+-- @-node:gcross.20091129000542.1479:Options processing
+-- @+node:gcross.20091121210308.2023:Package queries
+-- @+node:gcross.20091121210308.2018:queryPackage
+queryPackage :: GHCConfiguration -> String -> String -> Maybe [String]
+queryPackage tools field_name package_name =
+ case unsafePerformIO $
+ readProcessWithExitCode (ghcPackageManagerPath tools) ["field",package_name,field_name] ""
+ of (ExitSuccess,response,_) -> Just . filter (/= (field_name ++ ":")) . words $ response
+ _ -> Nothing
+-- @-node:gcross.20091121210308.2018:queryPackage
+-- @+node:gcross.20091121210308.2019:getPackage
+getPackage :: GHCConfiguration -> String -> Maybe (Map String String)
+getPackage configuration name =
+ fmap (Map.fromList . map (flip (,) name))
+ $
+ queryPackage configuration "exposed-modules" name
+
+-- @-node:gcross.20091121210308.2019:getPackage
+-- @+node:gcross.20091121210308.2021:getPackages
+getPackages :: GHCConfiguration -> [String] -> Either [String] PackageModules
+getPackages tools names =
+ let either_packages =
+ flip map names $ \name -> maybe (Left name) Right (getPackage tools name)
+ in case partitionEithers either_packages of
+ ([],packages) -> Right . Map.unions $ packages
+ (not_found,_) -> Left not_found
+-- @-node:gcross.20091121210308.2021:getPackages
+-- @+node:gcross.20091121210308.2024:findPackagesExposingModule
+findPackagesExposingModule :: GHCConfiguration -> String -> [String]
+findPackagesExposingModule tools package_name =
+ words
+ .
+ unsafePerformIO
+ .
+ readProcess (ghcPackageManagerPath tools) ["--simple-output","find-module",package_name]
+ $
+ ""
+-- @-node:gcross.20091121210308.2024:findPackagesExposingModule
+-- @+node:gcross.20091128201230.1459:readPackageDescription
+readPackageDescription :: FilePath -> PackageDescription
+readPackageDescription =
+ packageDescription
+ .
+ unsafePerformIO
+ .
+ Distribution.PackageDescription.Parse.readPackageDescription silent
+-- @-node:gcross.20091128201230.1459:readPackageDescription
+-- @+node:gcross.20091128201230.1461:configurePackageResolutions
+configurePackageResolutions :: GHCConfiguration -> PackageDescription -> String -> Configurer [String]
+configurePackageResolutions tools package_description =
+ configureUsingSectionWith config_reader config_writer automatic_configurer
+ where
+ config_reader = fmap words (getConfig ghcPackagesKey)
+ config_writer = setConfig ghcPackagesKey . unwords
+ automatic_configurer _ =
+ (\(unresolved_packages,resolved_packages) ->
+ if null unresolved_packages
+ then Right resolved_packages
+ else Left
+ .
+ errorMessage "resolving package dependencies for"
+ .
+ vcat
+ .
+ map (
+ (\(package_name,versions_found) ->
+ text package_name
+ <+>
+ (list . map (text . showVersion) $ versions_found)
+ )
+ )
+ $
+ unresolved_packages
+ )
+ .
+ partitionEithers
+ .
+ myParListWHNF
+ .
+ map resolvePackage
+ .
+ buildDepends
+ $
+ package_description
+
+ resolvePackage dependency@(Dependency (PackageName package_name) version_range) =
+ let versions_found =
+ map readVersion
+ .
+ fromMaybe []
+ .
+ queryPackage tools "version"
+ $
+ package_name
+ in case find (flip withinRange version_range) versions_found of
+ Nothing -> Left (package_name,versions_found)
+ Just version -> Right $ package_name ++ "-" ++ showVersion version
+-- @-node:gcross.20091128201230.1461:configurePackageResolutions
+-- @+node:gcross.20091129000542.1711:registerPackage
+registerPackage :: GHCConfiguration -> InstalledPackageInfo -> IO (Maybe Doc)
+registerPackage configuration = do
+ readProcessWithExitCode
+ (ghcPackageManagerPath configuration)
+ ["update","-"]
+ .
+ showInstalledPackageInfo
+ >=>
+ \(exit_code,_,error_message) ->
+ return $ case exit_code of
+ ExitSuccess -> Nothing
+ ExitFailure _ -> Just . vcat . map text . lines $ error_message
+-- @-node:gcross.20091129000542.1711:registerPackage
+-- @-node:gcross.20091121210308.2023:Package queries
+-- @+node:gcross.20091129000542.1701:Package installation
+-- @+node:gcross.20091129000542.1702:createInstalledPackageInfo
+createInstalledPackageInfoFromPackageDescription ::
+ Package.PackageDescription ->
+ Bool -> -- is library exposed?
+ [ModuleName] -> -- exposed modules
+ [ModuleName] -> -- hidden modules
+ [FilePath] -> -- import directories
+ [FilePath] -> -- library directories
+ [String] -> -- haskell libraries
+ [String] -> -- extra libraries
+ [String] -> -- extra GHCI libraries
+ [FilePath] -> -- include directories
+ [String] -> -- includes
+ [PackageIdentifier] -> -- package dependencies
+ [String] -> -- hugs options
+ [String] -> -- cc options
+ [String] -> -- ld options
+ [FilePath] -> -- framework directories
+ [String] -> -- frameworks
+ [FilePath] -> -- haddock interfaces
+ [FilePath] -> -- haddock HTMLs
+ InstalledPackageInfo
+createInstalledPackageInfoFromPackageDescription
+ = InstalledPackageInfo
+ <$> Package.package
+ <*> Package.license
+ <*> Package.copyright
+ <*> Package.maintainer
+ <*> Package.author
+ <*> Package.stability
+ <*> Package.homepage
+ <*> Package.pkgUrl
+ <*> Package.description
+ <*> Package.category
+-- @-node:gcross.20091129000542.1702:createInstalledPackageInfo
+-- @+node:gcross.20091129000542.1703:installSimplePackage
+installSimplePackage ::
+ GHCConfiguration ->
+ InstallerConfiguration ->
+ Package.PackageDescription ->
+ [String] ->
+ [Resource] ->
+ Maybe ErrorMessage
+installSimplePackage
+ ghc_configuration
+ installer_configuration
+ package_description
+ dependency_package_names
+ resources_to_install
+ = let PackageIdentifier (PackageName name) version = Package.package package_description
+ qualified_package_name = name ++ "-" ++ showVersion version
+ library_destination_path =
+ installerLibraryPath installer_configuration
+
+ qualified_package_name
+
+ (("ghc-" ++) . showVersion . ghcVersion $ ghc_configuration)
+ haskell_libraries :: [FilePath]
+ haskell_libraries =
+ map (drop 3 . dotsToSubdirectories . resourceName)
+ .
+ filter ((=="a") . resourceType)
+ $
+ resources_to_install
+
+ exposed_modules :: [ModuleName]
+ exposed_modules =
+ map (fromJust . simpleParse . resourceName)
+ .
+ filter ((== "hi") . resourceType)
+ $
+ resources_to_install
+
+ installed_package_info :: InstalledPackageInfo
+ installed_package_info =
+ createInstalledPackageInfoFromPackageDescription
+ package_description
+ True
+ exposed_modules
+ []
+ [library_destination_path]
+ [library_destination_path]
+ haskell_libraries
+ []
+ []
+ []
+ []
+ (map qualifiedNameToPackageIdentifier dependency_package_names)
+ []
+ []
+ []
+ []
+ []
+ []
+ []
+
+ installation_result = unsafePerformIO . try $ do
+ createDirectoryNoisilyIfMissing library_destination_path
+ forM_ resources_to_install $ \resource ->
+ let source_filepath = resourceFilePath resource
+ destination_filepath =
+ library_destination_path
+
+ (dotsToSubdirectories . resourceName $ resource)
+ <.>
+ (resourceType resource)
+ destination_directory = takeDirectory destination_filepath
+ in do
+ createDirectoryNoisilyIfMissing destination_directory
+ putStrLn $ "Copying " ++ source_filepath ++ " --> " ++ destination_filepath
+ copyFile source_filepath destination_filepath
+ makeEverythingReadableIn library_destination_path
+ putStrLn $ "Registering " ++ qualified_package_name
+ fmap (fmap (errorMessage "installing package")) $
+ registerPackage ghc_configuration installed_package_info
+
+ in case installation_result of
+ Right Nothing -> Nothing
+ Right (Just error_message) -> Just $ error_message
+ Left (e :: SomeException) -> Just $ errorMessageText "installing package" (show e)
+-- @-node:gcross.20091129000542.1703:installSimplePackage
+-- @-node:gcross.20091129000542.1701:Package installation
+-- @+node:gcross.20091121210308.2031:Error reporting
+-- @+node:gcross.20091121210308.2032:reportUnknownModules
+reportUnknownModules :: GHCConfiguration -> String -> [String] -> ErrorMessage
+reportUnknownModules tools source_name =
+ errorMessage ("tracing the following module dependencies for " ++ source_name)
+ .
+ vcat
+ .
+ map (\module_name -> text $
+ case findPackagesExposingModule tools module_name of
+ [] -> module_name ++ " (no idea where to find it)"
+ packages -> module_name ++ " which appears in packages " ++ (show packages)
+ )
+-- @-node:gcross.20091121210308.2032:reportUnknownModules
+-- @-node:gcross.20091121210308.2031:Error reporting
+-- @+node:gcross.20091121210308.1275:Tools
+-- @+node:gcross.20091121210308.2022:ghcCompile
+ghcCompile ::
+ GHCConfiguration ->
+ [String] ->
+ PackageModules ->
+ Resources ->
+ FilePath ->
+ FilePath ->
+ FilePath ->
+ Resource ->
+ (Resource,Resource)
+ghcCompile
+ tools
+ options
+ known_package_modules
+ known_resources
+ object_destination_directory
+ interface_destination_directory
+ cache_directory
+ source_resource
+ =
+ (Resource
+ { resourceName = source_name
+ , resourceType = "o"
+ , resourceFilePath = object_filepath
+ , resourceDigest = object_digest
+ , resourceDependencies = source_id:implicit_dependencies
+ }
+ ,Resource
+ { resourceName = source_name
+ , resourceType = "hi"
+ , resourceFilePath = interface_filepath
+ , resourceDigest = interface_digest
+ , resourceDependencies = source_id:implicit_dependencies
+ }
+ )
+ where
+ source_filepath = resourceFilePath source_resource
+ source_name = resourceName source_resource
+ source_id = resourceId source_resource
+ object_filepath = getFilePathForNameAndType object_destination_directory source_name "o"
+ interface_filepath = getFilePathForNameAndType interface_destination_directory source_name "hi"
+
+ scanner = do
+ dependencies <- readDependenciesOf source_filepath
+
+ let (unknown_dependencies,resource_dependencies) =
+ partitionEithers
+ .
+ catMaybes
+ .
+ map (\module_name ->
+ if Map.member module_name known_package_modules
+ then Nothing
+ else let resource_id = (module_name,"hi")
+ in if Map.member resource_id known_resources
+ then Just . Right $ resource_id
+ else Just . Left $ module_name
+ )
+ $
+ dependencies
+
+ if null unknown_dependencies
+ then return . Right $ resource_dependencies
+ else return . Left . reportUnknownModules tools source_name $ unknown_dependencies
+
+ builder =
+ let arguments =
+ options ++
+ ["-i"++interface_destination_directory
+ ,"-c",source_filepath
+ ,"-o",object_filepath
+ ,"-ohi",interface_filepath
+ ]
+ path_to_ghc = ghcCompilerPath tools
+ in do
+ createDirectoryIfMissing True . takeDirectory $ object_filepath
+ createDirectoryIfMissing True . takeDirectory $ interface_filepath
+ putStrLn . unwords $ (path_to_ghc:arguments)
+ compilation_result <- readProcessWithExitCode path_to_ghc arguments ""
+ case compilation_result of
+ (ExitFailure _,_,error_message) ->
+ return
+ .
+ Just
+ .
+ errorMessageTextWithLines ("compiling " ++ source_name)
+ $
+ error_message
+ (ExitSuccess,_,_) -> return Nothing
+
+ ((object_digest,interface_digest),implicit_dependencies) =
+ case analyzeImplicitDependenciesAndRebuildIfNecessary
+ builder
+ scanner
+ known_resources
+ (cache_directory source_name <.> "o")
+ [object_filepath,interface_filepath]
+ (unwords options)
+ source_resource
+ of Left error_message -> ((Left error_message,Left error_message),[])
+ Right ([object_digest,interface_digest],implicit_dependencies) ->
+ ((Right object_digest,Right interface_digest),implicit_dependencies)
+ x -> error $ "Programmer error: Builder returned the wrong number of digests! (" ++ show x ++ ")"
+-- @-node:gcross.20091121210308.2022:ghcCompile
+-- @+node:gcross.20091121210308.2038:ghcCompileAll
+ghcCompileAll ::
+ GHCConfiguration ->
+ [String] ->
+ PackageModules ->
+ FilePath ->
+ FilePath ->
+ FilePath ->
+ Resources ->
+ Resources
+ghcCompileAll
+ tools
+ options
+ known_package_modules
+ object_destination_directory
+ interface_destination_directory
+ cache_directory
+ old_resources
+ =
+ let new_resources = go old_resources (Map.elems old_resources)
+ go accum_resources [] = accum_resources
+ go accum_resources (resource:rest_resources) =
+ if resourceType (resource) == "hs"
+ then let (object_resource,interface_resource) =
+ ghcCompile
+ tools
+ options
+ known_package_modules
+ new_resources
+ object_destination_directory
+ interface_destination_directory
+ cache_directory
+ resource
+ in go (addResource object_resource . addResource interface_resource $ accum_resources) rest_resources
+ else go accum_resources rest_resources
+ in new_resources
+-- @-node:gcross.20091121210308.2038:ghcCompileAll
+-- @+node:gcross.20091127142612.1402:ghcLinkProgram
+ghcLinkProgram ::
+ GHCConfiguration ->
+ [String] ->
+ FilePath ->
+ [Resource] ->
+ String ->
+ FilePath ->
+ Resource
+ghcLinkProgram
+ tools
+ options
+ cache_directory
+ object_resources
+ program_resource_name
+ program_resource_filepath
+ = Resource
+ { resourceName = program_resource_name
+ , resourceType = ""
+ , resourceFilePath = program_resource_filepath
+ , resourceDigest = program_digest
+ , resourceDependencies = map resourceId object_resources
+ }
+ where
+ program_digest = either Left (Right . head) $
+ analyzeExplicitDependenciesAndRebuildIfNecessary
+ builder
+ (cache_directory program_resource_name <.> "")
+ [program_resource_filepath]
+ ()
+ object_resources
+
+ builder = do
+ createDirectoryIfMissing True . takeDirectory $ program_resource_filepath
+ let arguments =
+ options ++
+ ["-o",program_resource_filepath
+ ] ++
+ (map resourceFilePath object_resources)
+ command = ghcCompilerPath tools
+ putStrLn . unwords . (command:) $ arguments
+ compilation_result <-
+ readProcessWithExitCode
+ command
+ arguments
+ ""
+ case compilation_result of
+ (ExitFailure _,_,error_message) ->
+ return
+ .
+ Just
+ .
+ errorMessageTextWithLines ("linking " ++ program_resource_name)
+ $
+ error_message
+ (ExitSuccess,_,_) -> return Nothing
+-- @-node:gcross.20091127142612.1402:ghcLinkProgram
+-- @-node:gcross.20091121210308.1275:Tools
+-- @-others
+-- @-node:gcross.20091121204836.1242:@thin GHC.hs
+-- @-leo
diff --git a/Blueprint/Tools/GHC.o b/Blueprint/Tools/GHC.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Tools/GHC.o differ
diff --git a/Blueprint/Tools/Haddock.hs b/Blueprint/Tools/Haddock.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Tools/Haddock.hs
@@ -0,0 +1,143 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091128000856.1464:@thin Haddock.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091128000856.1465:<< Language extensions >>
+-- @-node:gcross.20091128000856.1465:<< Language extensions >>
+-- @nl
+
+module Blueprint.Tools.Haddock where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091128000856.1466:<< Import needed modules >>
+import Control.Monad
+
+import Data.Maybe
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO.Unsafe
+import System.Process
+
+import Blueprint.Configuration
+import Blueprint.Cache.ExplicitDependencies
+import Blueprint.Error
+import Blueprint.Resources
+import Blueprint.Options
+import Blueprint.Tools.GHC
+-- @-node:gcross.20091128000856.1466:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1581:Keys
+haddockOptionSectionKey = makeOptionSectionKey "Haddock"
+haddockConfigurationKey = makeConfigurationKey "path to hadhock"
+-- @-node:gcross.20091129000542.1581:Keys
+-- @+node:gcross.20091128000856.1467:Types
+-- @+node:gcross.20091128000856.1468:HaddockConfiguration
+data HaddockConfiguration = HaddockConfiguration { haddockPath :: FilePath } deriving (Show)
+-- @-node:gcross.20091128000856.1468:HaddockConfiguration
+-- @-node:gcross.20091128000856.1467:Types
+-- @+node:gcross.20091128000856.1469:Instances
+-- @+node:gcross.20091128000856.1470:ConfigurationData HaddockConfiguration
+instance ConfigurationData HaddockConfiguration where
+ readConfig = simpleReadConfig haddockConfigurationKey HaddockConfiguration
+ writeConfig = simpleWriteConfig haddockConfigurationKey haddockPath
+-- @-node:gcross.20091128000856.1470:ConfigurationData HaddockConfiguration
+-- @+node:gcross.20091128000856.1471:AutomaticallyConfigurable HaddockConfiguration
+instance AutomaticallyConfigurable HaddockConfiguration where
+ automaticallyConfigure = simpleSearchForProgram haddockOptionSectionKey HaddockConfiguration "haddock"
+-- @-node:gcross.20091128000856.1471:AutomaticallyConfigurable HaddockConfiguration
+-- @-node:gcross.20091128000856.1469:Instances
+-- @+node:gcross.20091129000542.1510:Options processing
+haddockOptions = makeSimpleOptionSectionForProgram "haddock" haddockOptionSectionKey
+-- @-node:gcross.20091129000542.1510:Options processing
+-- @+node:gcross.20091128000856.1472:Tools
+-- @+node:gcross.20091128000856.1473:createDocumentation
+createDocumentation ::
+ HaddockConfiguration ->
+ GHCConfiguration ->
+ [String] ->
+ [String] ->
+ FilePath ->
+ [Resource] ->
+ FilePath ->
+ Resource
+createDocumentation _ _ _ _ _ [] _ = error "No source resources specified for the documentation!"
+createDocumentation
+ tools
+ ghc_tools
+ options
+ package_names
+ cache_directory
+ source_resources
+ documentation_destination
+ = Resource
+ { resourceName = "interface"
+ , resourceType = "haddock"
+ , resourceFilePath = interface_filepath
+ , resourceDigest = interface_digest
+ , resourceDependencies = map resourceId source_resources
+ }
+ where
+ interface_filepath = documentation_destination "interface.haddock"
+
+ interface_digest = either Left (Right . head) $
+ analyzeExplicitDependenciesAndRebuildIfNecessary
+ builder
+ (cache_directory "interface.haddock")
+ [interface_filepath]
+ ()
+ source_resources
+
+ builder = do
+ createDirectoryIfMissing True . takeDirectory $ interface_filepath
+ let arguments =
+ ["--odir="++documentation_destination
+ ,"--dump-interface="++interface_filepath
+ ,"--html"
+ ]
+ ++ (map ("--read-interface="++)
+ .
+ filter (unsafePerformIO . doesFileExist)
+ .
+ concat
+ .
+ catMaybes
+ .
+ map (queryPackage ghc_tools "haddock-interfaces")
+ $
+ package_names
+ )
+ ++ options
+ ++ map resourceFilePath source_resources
+ command = (haddockPath tools)
+ putStrLn . unwords . (command:) $ arguments
+ compilation_result <-
+ readProcessWithExitCode
+ command
+ arguments
+ ""
+ case compilation_result of
+ (ExitFailure _,_,error_message) ->
+ return
+ .
+ Just
+ .
+ errorMessageTextWithLines ("creating documentation")
+ $
+ error_message
+ (ExitSuccess,_,_) ->
+ doesFileExist interface_filepath
+ >>= \interface_file_exists -> return $
+ if interface_file_exists
+ then Nothing
+ else Just . errorMessageText "creating documentaton" $
+ "For unknown reasons, the interface file " ++ show interface_filepath ++ " was not created."
+-- @-node:gcross.20091128000856.1473:createDocumentation
+-- @-node:gcross.20091128000856.1472:Tools
+-- @-others
+-- @-node:gcross.20091128000856.1464:@thin Haddock.hs
+-- @-leo
diff --git a/Blueprint/Tools/Haddock.o b/Blueprint/Tools/Haddock.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Tools/Haddock.o differ
diff --git a/Blueprint/Tools/Installer.hs b/Blueprint/Tools/Installer.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Tools/Installer.hs
@@ -0,0 +1,101 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091129000542.1642:@thin Installer.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091129000542.1643:<< Language extensions >>
+{-# LANGUAGE DeriveDataTypeable #-}
+-- @-node:gcross.20091129000542.1643:<< Language extensions >>
+-- @nl
+
+module Blueprint.Tools.Installer where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091129000542.1644:<< Import needed modules >>
+import Control.Applicative
+import Control.Monad
+
+import Data.Dynamic
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Data.Typeable
+
+import System.FilePath
+
+import Text.PrettyPrint.ANSI.Leijen hiding (())
+
+import Blueprint.Error
+import Blueprint.Options
+import Blueprint.Configuration
+-- @-node:gcross.20091129000542.1644:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1645:Keys
+installerOptionSectionKey = makeOptionSectionKey "Installer"
+
+installerLibraryPathKey = makeConfigurationKey "destination for libraries"
+-- @-node:gcross.20091129000542.1645:Keys
+-- @+node:gcross.20091129000542.1646:Types
+-- @+node:gcross.20091129000542.1647:InstallerConfiguration
+data InstallerConfiguration = InstallerConfiguration
+ { installerLibraryPath :: FilePath
+ } deriving (Show)
+-- @-node:gcross.20091129000542.1647:InstallerConfiguration
+-- @+node:gcross.20091129000542.1648:InstallerOptions
+data InstallerOptions = InstallerOptions
+ { installerOptionPrefix :: Maybe FilePath
+ , installerOptionLibraryPath :: Maybe FilePath
+ } deriving (Typeable, Show)
+
+-- @-node:gcross.20091129000542.1648:InstallerOptions
+-- @-node:gcross.20091129000542.1646:Types
+-- @+node:gcross.20091129000542.1651:Instances
+-- @+node:gcross.20091129000542.1652:ConfigurationData InstallerConfiguration
+instance ConfigurationData InstallerConfiguration where
+ readConfig =
+ liftM InstallerConfiguration
+ (getConfig installerLibraryPathKey)
+ writeConfig =
+ (setConfig installerLibraryPathKey . installerLibraryPath)
+-- @-node:gcross.20091129000542.1652:ConfigurationData InstallerConfiguration
+-- @+node:gcross.20091129000542.1700:AutomaticallyConfigurable InstallerConfiguration
+instance AutomaticallyConfigurable InstallerConfiguration where
+ automaticallyConfigure parsed_options =
+ case lookupAndUnwrapOptionSection installerOptionSectionKey parsed_options of
+ Nothing -> configureUsingPrefixOnly "/usr/local"
+ Just (InstallerOptions maybe_prefix maybe_libdir) ->
+ case (maybe_prefix,maybe_libdir) of
+ (Nothing,Nothing) -> configureUsingPrefixOnly "/usr/local"
+ (Just prefix,Nothing) -> configureUsingPrefixOnly "/usr/prefix"
+ (_,Just libdir) -> Right $ InstallerConfiguration libdir
+ where
+ configureUsingPrefixOnly prefix = Right $ InstallerConfiguration (prefix "lib")
+-- @-node:gcross.20091129000542.1700:AutomaticallyConfigurable InstallerConfiguration
+-- @-node:gcross.20091129000542.1651:Instances
+-- @+node:gcross.20091129000542.1666:Options processing
+installerOptions =
+ OptionSection
+ { optionSectionKey = installerOptionSectionKey
+ , optionSectionOptions =
+ [ Option "prefix"
+ [] ["prefix"]
+ (ArgumentRequired "PREFIX")
+ "install files in PREFIX [/usr/local]"
+ , Option "libraries"
+ [] ["libdir"]
+ (ArgumentRequired "DIRECTORY")
+ "install libraries in DIRECTORY [PREFIX/lib]"
+ ]
+ , optionSectionPostprocessor = postprocessOptions
+ }
+ where
+ postprocessOptions :: Map String [Maybe String] -> Either Doc Dynamic
+ postprocessOptions option_map = fmap toDyn $
+ liftA2 InstallerOptions
+ (lookupOptionAndVerifyDirectoryExists "prefix" option_map)
+ (lookupOptionAndVerifyDirectoryExists "libraries" option_map)
+-- @-node:gcross.20091129000542.1666:Options processing
+-- @-others
+-- @-node:gcross.20091129000542.1642:@thin Installer.hs
+-- @-leo
diff --git a/Blueprint/Tools/Installer.o b/Blueprint/Tools/Installer.o
new file mode 100644
Binary files /dev/null and b/Blueprint/Tools/Installer.o differ
diff --git a/Blueprint/Tools/Ld.hs b/Blueprint/Tools/Ld.hs
new file mode 100644
--- /dev/null
+++ b/Blueprint/Tools/Ld.hs
@@ -0,0 +1,116 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091130051619.1559:@thin Ld.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091129000542.1729:<< Language extensions >>
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+-- @nonl
+-- @-node:gcross.20091129000542.1729:<< Language extensions >>
+-- @nl
+
+module Blueprint.Tools.Ld where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091129000542.1730:<< Import needed modules >>
+import Control.Monad
+
+import Data.Dynamic
+
+import System.Directory
+import System.Exit
+import System.FilePath
+import System.IO.Unsafe
+import System.Process
+
+import Blueprint.Configuration
+import Blueprint.Cache.ExplicitDependencies
+import Blueprint.Error
+import Blueprint.Miscellaneous
+import Blueprint.Options
+import Blueprint.Resources
+-- @-node:gcross.20091129000542.1730:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1731:Keys
+ldOptionSectionKey = makeOptionSectionKey "ld"
+ldConfigurationKey = makeConfigurationKey "path to ld"
+-- @-node:gcross.20091129000542.1731:Keys
+-- @+node:gcross.20091129000542.1732:Types
+-- @+node:gcross.20091129000542.1733:ArConfiguration
+data LdConfiguration = LdConfiguration { ldPath :: FilePath } deriving (Show)
+-- @-node:gcross.20091129000542.1733:ArConfiguration
+-- @-node:gcross.20091129000542.1732:Types
+-- @+node:gcross.20091129000542.1734:Instances
+-- @+node:gcross.20091129000542.1735:ConfigurationData LdConfiguration
+instance ConfigurationData LdConfiguration where
+ readConfig = simpleReadConfig ldConfigurationKey LdConfiguration
+ writeConfig = simpleWriteConfig ldConfigurationKey ldPath
+-- @-node:gcross.20091129000542.1735:ConfigurationData LdConfiguration
+-- @+node:gcross.20091129000542.1736:AutomaticallyConfigurable LdConfiguration
+instance AutomaticallyConfigurable LdConfiguration where
+ automaticallyConfigure = simpleSearchForProgram ldOptionSectionKey LdConfiguration "ld"
+-- @-node:gcross.20091129000542.1736:AutomaticallyConfigurable LdConfiguration
+-- @-node:gcross.20091129000542.1734:Instances
+-- @+node:gcross.20091129000542.1737:Options processing
+ldOptions = makeSimpleOptionSectionForProgram "ld" ldOptionSectionKey
+-- @-node:gcross.20091129000542.1737:Options processing
+-- @+node:gcross.20091129000542.1738:Tools
+-- @+node:gcross.20091129000542.1739:linkIntoObject
+linkIntoObject ::
+ LdConfiguration ->
+ FilePath ->
+ [Resource] ->
+ String ->
+ FilePath ->
+ Resource
+linkIntoObject
+ tools
+ cache_directory
+ object_resources
+ library_resource_name
+ library_resource_filepath
+ = Resource
+ { resourceName = library_resource_name
+ , resourceType = "o"
+ , resourceFilePath = library_resource_filepath
+ , resourceDigest = library_digest
+ , resourceDependencies = map resourceId object_resources
+ }
+ where
+ library_digest = either Left (Right . head) $
+ analyzeExplicitDependenciesAndRebuildIfNecessary
+ builder
+ (cache_directory library_resource_name <.> "a")
+ [library_resource_filepath]
+ ()
+ object_resources
+
+ builder = do
+ createDirectoryIfMissing True . takeDirectory $ library_resource_filepath
+ let arguments = ("-x":"-r":"-o":library_resource_filepath:map resourceFilePath object_resources)
+ command = (ldPath tools)
+ putStrLn . unwords . (command:) $ arguments
+ compilation_result <-
+ readProcessWithExitCode
+ command
+ arguments
+ ""
+ case compilation_result of
+ (ExitFailure _,_,error_message) ->
+ return
+ .
+ Just
+ .
+ errorMessageTextWithLines ("linking " ++ library_resource_name)
+ $
+ error_message
+ (ExitSuccess,_,_) -> return Nothing
+
+-- @-node:gcross.20091129000542.1739:linkIntoObject
+-- @-node:gcross.20091129000542.1738:Tools
+-- @-others
+-- @-node:gcross.20091130051619.1559:@thin Ld.hs
+-- @-leo
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,26 @@
+Copyright (c) 2009 Gregory M. Crosswhite
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+2. 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.
+3. Neither the name of the author nor the names of his contributors
+ may be used to endorse or promote products derived from this software
+ without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,250 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091121210308.1291:@thin Setup.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091129000542.1713:<< Language extensions >>
+{-# LANGUAGE PackageImports #-}
+-- @-node:gcross.20091129000542.1713:<< Language extensions >>
+-- @nl
+
+module Main where
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091128000856.1439:<< Import needed modules >>
+import Control.Applicative
+import Control.Applicative.Infix
+import Control.Exception
+import Control.Monad
+import Control.Parallel
+
+import Data.ConfigFile hiding (options)
+import Data.Either.Unwrap
+import Data.Maybe
+import qualified Data.Map as Map
+import Data.Version
+
+import Distribution.Package
+import qualified Distribution.PackageDescription as Package
+
+import System.Directory
+import System.IO.Unsafe
+
+import Text.PrettyPrint.ANSI.Leijen hiding ((<$>))
+
+import Blueprint.Configuration
+import Blueprint.Error
+import Blueprint.Main
+import Blueprint.Miscellaneous
+import Blueprint.Options
+import Blueprint.Resources
+import Blueprint.Tools.Ar
+import Blueprint.Tools.GHC
+import Blueprint.Tools.Haddock
+import Blueprint.Tools.Installer
+import Blueprint.Tools.Ld
+-- @-node:gcross.20091128000856.1439:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091129000542.1484:Options
+options =
+ [ installerOptions
+ , arOptions
+ , ldOptions
+ , ghcOptions
+ , haddockOptions
+ ]
+-- @-node:gcross.20091129000542.1484:Options
+-- @+node:gcross.20091128000856.1452:Flags
+bootstrap_ghc_flags = ["-O","-threaded"]
+
+ghc_flags = ("-package-name="++qualified_package_name):bootstrap_ghc_flags
+-- @nonl
+-- @-node:gcross.20091128000856.1452:Flags
+-- @+node:gcross.20091129000542.1707:Types
+-- @+node:gcross.20091129000542.1708:Configuration
+data Configuration = Configuration
+ { ghcConfiguration :: GHCConfiguration
+ , arConfiguration :: ArConfiguration
+ , ldConfiguration :: LdConfiguration
+ , haddockConfiguration :: HaddockConfiguration
+ , installerConfiguration :: InstallerConfiguration
+ , packageDependencies :: [String]
+ }
+-- @-node:gcross.20091129000542.1708:Configuration
+-- @-node:gcross.20091129000542.1707:Types
+-- @+node:gcross.20091128000856.1475:Values
+-- @+node:gcross.20091128000856.1476:source resources
+source_resources = resourcesWithPrefixIn "Blueprint" "Blueprint"
+-- @-node:gcross.20091128000856.1476:source resources
+-- @+node:gcross.20091128201230.1460:package description
+package_description = readPackageDescription "Blueprint.cabal"
+-- @-node:gcross.20091128201230.1460:package description
+-- @+node:gcross.20091129000542.1593:configuration file path
+configurationFilePath = "Blueprint.cfg"
+-- @-node:gcross.20091129000542.1593:configuration file path
+-- @+node:gcross.20091129000542.1712:qualified package name
+qualified_package_name =
+ let PackageIdentifier (PackageName name) version = Package.package package_description
+ in name ++ "-" ++ showVersion version
+-- @-node:gcross.20091129000542.1712:qualified package name
+-- @-node:gcross.20091128000856.1475:Values
+-- @+node:gcross.20091128000856.1448:Targets
+targets =
+ [target "configure" configure
+ ,target "reconfigure" $ makeReconfigureTarget configurationFilePath targets
+ ,target "bootstrap" bootstrap
+ ,target "build" build
+ ,target "rebuild" $ makeRebuildTarget targets
+ ,target "haddock" haddock
+ ,target "install" install
+ ,target "clean" $
+ makeCleanTarget
+ ["objects"
+ ,"digest-cache"
+ ,"haskell-interfaces"
+ ,"libraries"
+ ,"haddock"
+ ,"bootstrap"
+ ]
+ targets
+ ,target "distclean" $
+ makeDistCleanTarget
+ [configurationFilePath
+ ]
+ targets
+ ]
+-- @+node:gcross.20091128000856.1449:configure
+configure = parseCommandLineOptions options >>= \(_,options) -> runConfigurer "Blueprint.cfg" options $ do
+ configurations@
+ (ghc_configuration
+ ,ar_configuration
+ ,ld_configuration
+ ,haddock_configuration
+ ,install_configuration
+ ) <- (,,,,)
+ <$> (configureUsingSection "GHC")
+ <*> (configureUsingSection "Binutils")
+ <*> (configureUsingSection "Binutils")
+ <*> (configureUsingSection "Haddock")
+ <*> (configureUsingSection "Installation Directories")
+ package_dependencies <- configurePackageResolutions ghc_configuration package_description "GHC"
+ return $
+ Configuration
+ ghc_configuration
+ ar_configuration
+ ld_configuration
+ haddock_configuration
+ install_configuration
+ package_dependencies
+-- @-node:gcross.20091128000856.1449:configure
+-- @+node:gcross.20091128000856.1450:build
+build = configure >>= \configuration ->
+ let Right package_modules = getPackages <$> ghcConfiguration <*> packageDependencies $ configuration
+ compiled_resources =
+ ghcCompileAll
+ (ghcConfiguration configuration)
+ ghc_flags
+ package_modules
+ "objects"
+ "haskell-interfaces"
+ "digest-cache"
+ source_resources
+ object_resources =
+ map snd
+ .
+ filter ((=="o"). snd . fst)
+ .
+ Map.toList
+ $
+ compiled_resources
+ library = formStaticLibrary
+ (arConfiguration configuration)
+ "digest-cache"
+ object_resources
+ "libblueprint"
+ "libraries/libblueprint.a"
+ ghci_library = linkIntoObject
+ (ldConfiguration configuration)
+ "digest-cache"
+ object_resources
+ "blueprint"
+ "libraries/blueprint.o"
+ in do
+ attemptGetDigests [library,ghci_library]
+ >>
+ return (library,ghci_library,compiled_resources)
+-- @-node:gcross.20091128000856.1450:build
+-- @+node:gcross.20091129000542.1715:bootstrap
+bootstrap = configure >>= \configuration ->
+ let Right package_modules = getPackages <$> ghcConfiguration <*> packageDependencies $ configuration
+ compiled_resources =
+ ghcCompileAll
+ (ghcConfiguration configuration)
+ bootstrap_ghc_flags
+ package_modules
+ "bootstrap/objects"
+ "bootstrap/haskell-interfaces"
+ "bootstrap/digest-cache"
+ source_resources
+ (setup_object,_) =
+ ghcCompile
+ (ghcConfiguration configuration)
+ bootstrap_ghc_flags
+ package_modules
+ compiled_resources
+ "bootstrap/objects"
+ "bootstrap/haskell-interfaces"
+ "bootstrap/digest-cache"
+ (createResourceFor "" "Setup.hs")
+
+ setup_program = ghcLinkProgram
+ (ghcConfiguration configuration)
+ (((bootstrap_ghc_flags ++) . map ("-package" ++) . packageDependencies $ configuration))
+ "bootstrap/digest-cache"
+ (findAllObjectDependenciesOf compiled_resources setup_object)
+ "Setup"
+ "Setup"
+ in attemptGetDigests [setup_program]
+-- @-node:gcross.20091129000542.1715:bootstrap
+-- @+node:gcross.20091129000542.1706:install
+install = do
+ configuration <- configure
+ (library_resource,ghci_library_resource,compiled_resources) <- build
+ let interface_resources = filter ((=="hi") . resourceType) . Map.elems $ compiled_resources
+ installation_result =
+ installSimplePackage
+ (ghcConfiguration configuration)
+ (installerConfiguration configuration)
+ package_description
+ (packageDependencies configuration)
+ (library_resource
+ :ghci_library_resource
+ :interface_resources
+ )
+ case installation_result of
+ Nothing -> Right ()
+ Just error_message -> Left error_message
+-- @-node:gcross.20091129000542.1706:install
+-- @+node:gcross.20091128000856.1474:haddock
+haddock = configure >>= \configuration ->
+ resourceDigest $
+ createDocumentation
+ (haddockConfiguration configuration)
+ (ghcConfiguration configuration)
+ []
+ []
+ "digest-cache"
+ (Map.elems source_resources)
+ "haddock"
+-- @-node:gcross.20091128000856.1474:haddock
+-- @-node:gcross.20091128000856.1448:Targets
+-- @+node:gcross.20091129000542.1485:main
+main = defaultMain
+ (createDefaultHelpMessage options . map fst $ targets)
+ targets
+-- @-node:gcross.20091129000542.1485:main
+-- @-others
+-- @-node:gcross.20091121210308.1291:@thin Setup.hs
+-- @-leo
diff --git a/tests/test.hs b/tests/test.hs
new file mode 100644
--- /dev/null
+++ b/tests/test.hs
@@ -0,0 +1,55 @@
+-- @+leo-ver=4-thin
+-- @+node:gcross.20091121210308.1806:@thin test.hs
+-- @@language Haskell
+
+-- @<< Language extensions >>
+-- @+node:gcross.20091121210308.1807:<< Language extensions >>
+{-# LANGUAGE ScopedTypeVariables #-}
+-- @-node:gcross.20091121210308.1807:<< Language extensions >>
+-- @nl
+
+-- @<< Import needed modules >>
+-- @+node:gcross.20091121210308.1808:<< Import needed modules >>
+import Control.Arrow
+
+import Data.List
+
+import Debug.Trace
+
+import Test.HUnit
+import Test.Framework
+import Test.Framework.Providers.HUnit
+import Test.Framework.Providers.QuickCheck2
+import Test.QuickCheck
+
+import Blueprint.Miscellaneous
+-- @-node:gcross.20091121210308.1808:<< Import needed modules >>
+-- @nl
+
+-- @+others
+-- @+node:gcross.20091121210308.1844:Functions
+-- @+node:gcross.20091121210308.1845:echo
+echo x = trace (show x) x
+-- @-node:gcross.20091121210308.1845:echo
+-- @-node:gcross.20091121210308.1844:Functions
+-- @-others
+
+main = defaultMain
+ -- @ << Tests >>
+ -- @+node:gcross.20091121210308.1816:<< Tests >>
+ -- @+others
+ -- @+node:gcross.20091121210308.1817:Blueprint.Resources
+ [testGroup "Blueprint.Resources"
+ -- @ @+others
+ -- @+node:gcross.20091121210308.1818:splitDot
+ [testProperty "splitDot" $ (uncurry (==)) . (id &&& splitDot . unsplitDot) . filter (not . null) . map (filter (/= '.'))
+ -- @-node:gcross.20091121210308.1818:splitDot
+ -- @-others
+ ]
+ -- @-node:gcross.20091121210308.1817:Blueprint.Resources
+ -- @-others
+ -- @-node:gcross.20091121210308.1816:<< Tests >>
+ -- @nl
+ ]
+-- @-node:gcross.20091121210308.1806:@thin test.hs
+-- @-leo