Blueprint (empty) → 0.1
raw patch · 32 files changed
+3434/−0 lines, 32 filesbuild-type:Customsetup-changedbinary-added
Files
- Blueprint.cabal +39/−0
- Blueprint.leo +47/−0
- Blueprint/Cache/ExplicitDependencies.hs +132/−0
- Blueprint/Cache/ExplicitDependencies.o binary
- Blueprint/Cache/ImplicitDependencies.hs +145/−0
- Blueprint/Cache/ImplicitDependencies.o binary
- Blueprint/Configuration.hs +211/−0
- Blueprint/Configuration.o binary
- Blueprint/Error.hs +117/−0
- Blueprint/Error.o binary
- Blueprint/Main.hs +161/−0
- Blueprint/Main.o binary
- Blueprint/Miscellaneous.hs +75/−0
- Blueprint/Miscellaneous.o binary
- Blueprint/Options.hs +448/−0
- Blueprint/Options.o binary
- Blueprint/Resources.hs +149/−0
- Blueprint/Resources.o binary
- Blueprint/Tools/Ar.hs +116/−0
- Blueprint/Tools/Ar.o binary
- Blueprint/Tools/GCC.hs +155/−0
- Blueprint/Tools/GFortran.hs +164/−0
- Blueprint/Tools/GHC.hs +784/−0
- Blueprint/Tools/GHC.o binary
- Blueprint/Tools/Haddock.hs +143/−0
- Blueprint/Tools/Haddock.o binary
- Blueprint/Tools/Installer.hs +101/−0
- Blueprint/Tools/Installer.o binary
- Blueprint/Tools/Ld.hs +116/−0
- LICENSE +26/−0
- Setup.hs +250/−0
- tests/test.hs +55/−0
+ Blueprint.cabal view
@@ -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
+ Blueprint.leo view
@@ -0,0 +1,47 @@+<?xml version="1.0" encoding="utf-8"?>+<?xml-stylesheet ekr_test?>+<leo_file>+<leo_header file_format="2" tnodes="0" max_tnode_index="0" clone_windows="0"/>+<globals body_outline_ratio="0.5">+ <global_window_position top="141" left="374" height="807" width="812"/>+ <global_log_window_position top="0" left="0" height="0" width="0"/>+</globals>+<preferences/>+<find_panel_settings/>+<vnodes>+<v t="gcross.20090727161338.1229"><vh>@chapters</vh></v>+<v t="gcross.20091128000856.1485"><vh>@thin Blueprint.cabal</vh></v>+<v t="gcross.20091121210308.1291"><vh>@thin Setup.hs</vh></v>+<v t="gcross.20091121204836.1240"><vh>@path Blueprint</vh>+<v t="gcross.20091122100142.1349"><vh>@path Cache</vh>+<v t="gcross.20091122100142.1369"><vh>@thin ExplicitDependencies.hs</vh></v>+<v t="gcross.20091122100142.1310"><vh>@thin ImplicitDependencies.hs</vh></v>+</v>+<v t="gcross.20091123215917.1369"><vh>@thin Configuration.hs</vh></v>+<v t="gcross.20091127142612.1383"><vh>@thin Error.hs</vh></v>+<v t="gcross.20091128000856.1441"><vh>@thin Main.hs</vh></v>+<v t="gcross.20091127142612.1413"><vh>@thin Miscellaneous.hs</vh></v>+<v t="gcross.20091129000542.1450"><vh>@thin Options.hs</vh></v>+<v t="gcross.20091121210308.1276"><vh>@thin Resources.hs</vh></v>+<v t="gcross.20091121204836.1241"><vh>@path Tools</vh>+<v t="gcross.20091122100142.1360"><vh>@thin Ar.hs</vh></v>+<v t="gcross.20091123114318.1335"><vh>@thin GCC.hs</vh></v>+<v t="gcross.20091129000542.1552"><vh>@thin GFortran.hs</vh></v>+<v t="gcross.20091121204836.1242"><vh>@thin GHC.hs</vh></v>+<v t="gcross.20091128000856.1464"><vh>@thin Haddock.hs</vh></v>+<v t="gcross.20091129000542.1642"><vh>@thin Installer.hs</vh></v>+<v t="gcross.20091130051619.1559"><vh>@thin Ld.hs</vh></v>+</v>+</v>+<v t="gcross.20091121210308.1297"><vh>@path tests</vh>+<v t="gcross.20091121210308.1806"><vh>@thin test.hs</vh></v>+</v>+</vnodes>+<tnodes>+<t tx="gcross.20090727161338.1229" str_leo_pos="2"></t>+<t tx="gcross.20091121204836.1240"></t>+<t tx="gcross.20091121204836.1241"></t>+<t tx="gcross.20091121210308.1297"></t>+<t tx="gcross.20091122100142.1349"></t>+</tnodes>+</leo_file>
+ Blueprint/Cache/ExplicitDependencies.hs view
@@ -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
+ Blueprint/Cache/ExplicitDependencies.o view
binary file changed (absent → 26576 bytes)
+ Blueprint/Cache/ImplicitDependencies.hs view
@@ -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
+ Blueprint/Cache/ImplicitDependencies.o view
binary file changed (absent → 29172 bytes)
+ Blueprint/Configuration.hs view
@@ -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
+ Blueprint/Configuration.o view
binary file changed (absent → 49580 bytes)
+ Blueprint/Error.hs view
@@ -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
+ Blueprint/Error.o view
binary file changed (absent → 19692 bytes)
+ Blueprint/Main.hs view
@@ -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
+ Blueprint/Main.o view
binary file changed (absent → 32160 bytes)
+ Blueprint/Miscellaneous.hs view
@@ -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
+ Blueprint/Miscellaneous.o view
binary file changed (absent → 11672 bytes)
+ Blueprint/Options.hs view
@@ -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 <target> [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
+ Blueprint/Options.o view
binary file changed (absent → 86992 bytes)
+ Blueprint/Resources.hs view
@@ -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
+ Blueprint/Resources.o view
binary file changed (absent → 28292 bytes)
+ Blueprint/Tools/Ar.hs view
@@ -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
+ Blueprint/Tools/Ar.o view
binary file changed (absent → 22528 bytes)
+ Blueprint/Tools/GCC.hs view
@@ -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
+ Blueprint/Tools/GFortran.hs view
@@ -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
+ Blueprint/Tools/GHC.hs view
@@ -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
+ Blueprint/Tools/GHC.o view
binary file changed (absent → 173852 bytes)
+ Blueprint/Tools/Haddock.hs view
@@ -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
+ Blueprint/Tools/Haddock.o view
binary file changed (absent → 31776 bytes)
+ Blueprint/Tools/Installer.hs view
@@ -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
+ Blueprint/Tools/Installer.o view
binary file changed (absent → 32096 bytes)
+ Blueprint/Tools/Ld.hs view
@@ -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
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -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
+ tests/test.hs view
@@ -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