weekdaze-0.0.0.1: src-exe/Main.hs
{-# LANGUAGE CPP #-}
#ifdef MIN_TOOL_VERSION_ghc /* CAVEAT: early versions of Cabal don't define this */
#if MIN_TOOL_VERSION_ghc(8,0,1)
{-# OPTIONS_GHC -freduction-depth=22 #-}
#endif
#else
{-# OPTIONS_GHC -fcontext-stack=22 #-}
#endif
{-
Copyright (C) 2013-2015 Dr. Alistair Ward
This file is part of WeekDaze.
WeekDaze is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
(at your option) any later version.
WeekDaze is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with WeekDaze. If not, see <http://www.gnu.org/licenses/>.
-}
{- |
[@AUTHOR@] Dr. Alistair Ward
[@DESCRIPTION@]
* Reads the configuration, either from the specified local XML file, or from the specified database on the referenced DBMS.
* Override this, by parsing the remainder of the command-line arguments, to determine transient configuration.
* Attempts to solves the configured problem.
* Present the results in each of the specified output file-formats.
* <https://en.wikipedia.org/wiki/School_timetable>.
-}
module Main(main) where
import Control.Arrow((***), (&&&))
import Control.Category((>>>))
import qualified Control.Arrow
import qualified Control.Exception
import qualified Control.Monad
import qualified Control.Monad.Writer -- The lazy instance.
import qualified Data.Default
import qualified Data.List
import qualified Data.Map
import qualified Data.Maybe
import qualified Data.Set
import qualified Data.Time.Clock
import qualified Data.Version
import qualified Distribution.Verbosity
import qualified Factory.Data.Interval
import qualified Paths_weekdaze as Paths -- Either local stub, or package-instance autogenerated by 'Setup build'.
import qualified System.Console.GetOpt as G
import qualified System.Directory
import qualified System.Environment
import qualified System.Exit
import qualified System.FilePath
import System.FilePath((</>), (<.>))
import qualified System.IO
import qualified System.Info
import qualified System.Random
import qualified Text.Printf
import qualified Text.XML.HXT.Core as HXT
import qualified ToolShed.Data.List
import qualified ToolShed.SelfValidate
import qualified ToolShed.System.File
import qualified WeekDaze.Aggregate.StudentBody as Aggregate.StudentBody
import qualified WeekDaze.Configuration as Configuration
import qualified WeekDaze.Data.Group as Data.Group
import qualified WeekDaze.Data.Subject as Data.Subject
import qualified WeekDaze.Dynamic.StudentViewTimetableUtilities as Dynamic.StudentViewTimetableUtilities
-- import WeekDaze.Enhanced.EnhancedDouble() -- Required when some of the 'Rational' types below are replaced by 'Double'.
import WeekDaze.Enhanced.EnhancedRatio()
import qualified WeekDaze.ExecutionConfiguration.EvolutionStrategies as ExecutionConfiguration.EvolutionStrategies
import qualified WeekDaze.ExecutionConfiguration.ExecutionOptions as ExecutionConfiguration.ExecutionOptions
import qualified WeekDaze.ExecutionConfiguration.OptimiseLessonCriteriaWeights as ExecutionConfiguration.OptimiseLessonCriteriaWeights
import qualified WeekDaze.Identifiers.Campus as Identifiers.Campus
import qualified WeekDaze.Identifiers.Level as Identifiers.Level
import qualified WeekDaze.Identifiers.LocationId as Identifiers.LocationId
import qualified WeekDaze.Identifiers.Stream as Identifiers.Stream
import qualified WeekDaze.Identifiers.SynchronisationId as Identifiers.SynchronisationId
import qualified WeekDaze.Identifiers.TeacherId as Identifiers.TeacherId
import qualified WeekDaze.Identifiers.TimeslotId as Identifiers.TimeslotId
import qualified WeekDaze.Implementation.EvolutionaryAlgorithm as Implementation.EvolutionaryAlgorithm
import qualified WeekDaze.Implementation.TimetableFitness as Implementation.TimetableFitness
import qualified WeekDaze.Input.CommandLineOption as Input.CommandLineOption
import qualified WeekDaze.Input.ConfigVersion as Input.ConfigVersion
import qualified WeekDaze.Input.Options as Input.Options
import qualified WeekDaze.LocationView.LessonResourceIds as LocationView.LessonResourceIds
import qualified WeekDaze.LocationView.Timetable as LocationView.Timetable
import qualified WeekDaze.Model.Timetable as Model.Timetable
import qualified WeekDaze.OutputConfiguration.FileFormat as OutputConfiguration.FileFormat
import qualified WeekDaze.OutputConfiguration.Format as OutputConfiguration.Format
import qualified WeekDaze.OutputConfiguration.Options as OutputConfiguration.Options
import qualified WeekDaze.OutputConfiguration.Style as OutputConfiguration.Style
import qualified WeekDaze.OutputConfiguration.Verbosity as OutputConfiguration.Verbosity
import qualified WeekDaze.OutputConfiguration.View as OutputConfiguration.View
import qualified WeekDaze.OutputFormat.XHTMLFormat as OutputFormat.XHTMLFormat
import qualified WeekDaze.OutputFormat.XHTMLFormatLocationViewTimetable as OutputFormat.XHTMLFormatLocationViewTimetable
import qualified WeekDaze.OutputFormat.XHTMLFormatStudentViewTimetable as OutputFormat.XHTMLFormatStudentViewTimetable
import qualified WeekDaze.OutputFormat.XHTMLFormatTeacherViewTimetable as OutputFormat.XHTMLFormatTeacherViewTimetable
import qualified WeekDaze.OutputFormat.DeterministicStudentViewTimetableSelection as OutputFormat.DeterministicStudentViewTimetableSelection
import qualified WeekDaze.OutputFormat.EvolutionStrategyStatistics as OutputFormat.EvolutionStrategyStatistics
import qualified WeekDaze.ProblemConfiguration.ProblemAnalysis as ProblemConfiguration.ProblemAnalysis
import qualified WeekDaze.ProblemConfiguration.ProblemParameters as ProblemConfiguration.ProblemParameters
import qualified WeekDaze.StudentView.LessonResourceIds as StudentView.LessonResourceIds
import qualified WeekDaze.TeacherView.LessonResourceIds as TeacherView.LessonResourceIds
import qualified WeekDaze.TeacherView.Timetable as TeacherView.Timetable
import qualified WeekDaze.Text.CSS as Text.CSS
#ifdef TOOL_VERSION_ghc
import qualified GHC.Conc
#endif
#ifdef USE_HDBC
import qualified Crypto.Hash
import qualified Database.HDBC
import qualified Data.Byteable
import qualified Data.ByteString
import qualified Data.ByteString.Char8
import qualified WeekDaze.Database.Selector as Database.Selector
#ifdef USE_HDBC_ODBC
import qualified Database.HDBC.ODBC
import qualified WeekDaze.Database.ODBC as Database.ODBC
#endif
#ifdef USE_HDBC_MYSQL
import qualified WeekDaze.Database.MySQL as Database.MySQL
#endif
#endif /* USE_HDBC */
#ifdef USE_UNIX
import qualified WeekDaze.SignalHandlers as SignalHandlers
#endif
-- | Define a concrete type for the value of a criterion.
type CriterionValue = Rational -- CAVEAT: avoid arithmetic on bounded rationals, which can easily overflow.
-- | Define a concrete type for the weighting applied to criteria, used to bias their significance in the selection of /lesson/s or /timetable/s.
type CriterionWeight = CriterionValue -- There's no obvious reason for it to differ from this.
-- | Define a concrete type for the factor by which the fecundity of the breeding-program is amended, when the diversity of the population of candidates falls beneath the minimum acceptable.
type FecundityDecayRatio = Rational -- CAVEAT: avoid arithmetic on bounded rationals, which can easily overflow.
-- | Define a concrete type for the diversity-ratio in the population of candidates.
type PopulationDiversityRatio = FecundityDecayRatio -- There's no obvious reason for it to differ from this.
{- |
* The concrete type used for IO of Fractional values.
* This allows one to read 'Rational' values from the command-line, into this intermediate type, before conversion to the correct internal type,
-}
type FractionalIOFormat = Double
-- | Define a concrete type for the ratio of a /teacher/'s working-week which is actually devoted to teaching.
type TeachingRatio = Rational -- CAVEAT: avoid arithmetic on bounded rationals, which can easily overflow.
-- | Define a concrete type for the weighted mean of; the criteria by which /lesson/s or /timetable/s, are selected.
type WeightedMean = CriterionWeight -- There's no obvious reason for it to differ from this.
-- | Define a concrete type for the mean of the values of /lesson-criteria/.
type Mean = CriterionValue -- There's no obvious reason for it to differ from this.
-- | Define a concrete type for the standard deviation of the criteria by which /lesson/s, are selected.
type StandardDeviation = Double -- There's little choice, since it must implement 'Floating'.
-- | Define a concrete instance of the underlying polymorphic type.
type ProblemParameters = ProblemConfiguration.ProblemParameters.ProblemParameters Identifiers.Campus.Campus Identifiers.Level.Level Identifiers.LocationId.LocationId Identifiers.Stream.Stream Identifiers.SynchronisationId.SynchronisationId Identifiers.TeacherId.TeacherId TeachingRatio Identifiers.TimeslotId.TimeslotId
-- | Define a concrete instance of the underlying polymorphic type.
type ExecutionOptions = ExecutionConfiguration.ExecutionOptions.ExecutionOptions CriterionWeight FecundityDecayRatio PopulationDiversityRatio
-- | Define a concrete type for the minimum acceptable contrast-ratio between the automatically generated foreground & complementary background-colours.
type MinimumContrastRatio = Rational
-- | Define a concrete instance of the underlying polymorphic type.
type Options = Input.Options.Options Identifiers.Campus.Campus CriterionWeight FecundityDecayRatio Identifiers.Level.Level Identifiers.LocationId.LocationId MinimumContrastRatio PopulationDiversityRatio Identifiers.Stream.Stream Identifiers.SynchronisationId.SynchronisationId Identifiers.TeacherId.TeacherId TeachingRatio Identifiers.TimeslotId.TimeslotId
-- | Define a concrete instance of the underlying polymorphic type.
type ProblemAnalysis = ProblemConfiguration.ProblemAnalysis.ProblemAnalysis Identifiers.Level.Level Identifiers.LocationId.LocationId Identifiers.SynchronisationId.SynchronisationId Identifiers.TeacherId.TeacherId Identifiers.TimeslotId.TimeslotId
-- | Express the specified file in XML, citing the referenced DTD (whether it exists or not), & write it to the file-system.
writeXMLToFile
:: HXT.XmlPickler a
=> System.FilePath.FilePath
-> String
-> System.FilePath.FilePath
-> a -- ^ The pickleable.
-> IO ()
writeXMLToFile destinationFilePath rootElementTag dtdFilePath x = do
-- System.IO.hPutStrLn System.IO.stderr . showString "INFO:\twriting " . showString rootElementTag . showString "-configuration to file=" $ shows destinationFilePath "."
System.IO.withFile destinationFilePath System.IO.WriteMode (
`System.IO.hPutStrLn` (
showString "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<!DOCTYPE " . showString rootElementTag . showString " SYSTEM " . shows dtdFilePath $ showString ">\n" (
HXT.showPickled [
HXT.withIndent HXT.yes -- CAVEAT: corresponding input-option 'HXT.withRemoveWS' may subsequently be required.
] x
)
)
) -- Section.
{- |
* Defines the permissible command-line arguments.
* Parses the XML configuration-file, to determine the persistent configuration.
* Override this, by parsing the command-line arguments, to determine transient configuration.
* Solve the resulting problem.
* Present the results in each of the specified output file-formats.
-}
main :: IO ()
main = do
-- Inspect the environment.
startUTCTime <- Data.Time.Clock.getCurrentTime
progName <- System.Environment.getProgName
args <- System.Environment.getArgs
dataDir <- fmap System.FilePath.normalise Paths.getDataDir -- Defined using 'cabal configure --datadir="<dir>" --datasubdir="<dir>"'.
appUserDataDir <- System.Directory.getAppUserDataDirectory progName -- CAVEAT: on Unix/Gnu-Linux, requires the '$HOME' environment-variable to have been defined.
let
packageIdentifier, author :: String
packageIdentifier = showString progName . showChar '-' $ showString (Input.ConfigVersion.toString $ Data.Version.versionBranch Paths.version) ""
author = "Dr. Alistair Ward"
inputConfigFilePathFlag :: Input.CommandLineOption.Flag
inputConfigFilePathFlag = "inputConfigFilePath"
#ifdef USE_HDBC
#ifdef USE_HDBC_ODBC
dsnFlag :: Input.CommandLineOption.Flag
dsnFlag = "dsn"
defaultDSN :: String
defaultDSN = progName
#else
_x :: [Input.CommandLineOption.Flag]
_x@[dataServerHostFlag, dataServerPortFlag, dataServerUserIdFlag, dataServerPasswordFlag, databaseNameFlag] = ["dataServerHost", "dataServerPort", "dataServerUserId", "dataServerPassword", "databaseName"]
defaultDataServerUserId, defaultDatabaseName :: String
defaultDataServerUserId = "root"
defaultDatabaseName = progName
#endif
_y :: [Input.CommandLineOption.Flag]
_y@[databaseUserIdFlag, databasePasswordFlag, databaseProjectNameFlag] = ["databaseUserId", "databasePassword", "databaseProjectName"]
mandatoryDBFlags :: [Input.CommandLineOption.Flag]
mandatoryDBFlags@[databaseUserIdFlag', databaseProjectNameFlag'] = map (showString Input.CommandLineOption.longFlagPrefix) [databaseUserIdFlag, databaseProjectNameFlag]
#endif /* USE_HDBC */
odbcPackageName :: String
odbcPackageName = "HDBC-odbc"
mySQLPackageName :: String
mySQLPackageName = "HDBC-mysql"
{-
Define all permissible command-line options.
This specification is fairly complicated:
Each command-line option is categorised as one of:
an "IO-action", which is subsequently sequenced with other IO-actions, before exiting;
a "Config-location Parameter", which if specified, locates a file or database containing more options;
an "Options-mutator", which if specified, defines a function used to transform 'Input.CommandLineOption.CommandLineOption'.
Additionally, the command-line options are recorded as they're processed, to enable display of the command-line in the results;
if one merely displays 'args', then security-sensitive details may be revealed, & it's difficult to find & remove such options, since the associated flag may be truncated to a minimum unique string.
-}
optDescrList :: [
G.OptDescr (
Maybe (String {-flag-}, Maybe String {-optional value-}), -- Record command-line specifications.
Input.CommandLineOption.CommandLineOption Options -- Defines the action to take on receipt of a command-line option.
) -- Pair.
]
optDescrList = [
G.Option "?" ["help"] (
G.NoArg (Nothing {-N/A-}, Input.CommandLineOption.mkIOAction printHelp)
) $ showString infoString "print this help, & then exit.",
G.Option "v" ["version"] (
G.NoArg (Nothing {-N/A-}, Input.CommandLineOption.mkIOAction printVersion)
) $ showString infoString "print version-information, & then exit.",
G.Option "i" [inputConfigFilePathFlag] (
G.ReqArg (Just . (,) inputConfigFilePathFlag . Just &&& Input.CommandLineOption.mkConfigLocationParameter inputConfigFilePathFlag) $ mkTypeString filePathString
) (
showString inputString $ showString "define the path to an XML-file from which the configuration can be read"
#ifdef USE_HDBC
. showString ", as an alternative to " $ shows mandatoryDBFlags
#endif
"."
),
#ifdef USE_HDBC
#ifdef USE_HDBC_ODBC
G.Option "" [dsnFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter dsnFlag) $ mkTypeString stringString
) . showString inputString . showString "define the data-source name from which to read ODBC DBMS connection-parameters; default " $ shows defaultDSN ".",
#else
G.Option "" [dataServerHostFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter dataServerHostFlag) $ mkTypeString stringString
) . showString inputString . showString "define the name or IP-address, of the host on which the RDBMS is running; default " $ shows Database.MySQL.defaultHost ".",
G.Option "" [dataServerPortFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter dataServerPortFlag) $ mkTypeString intString
) . showString inputString . showString "define the port on which the RDBMS is listening; default '" $ shows Database.MySQL.defaultPort "'.",
G.Option "" [dataServerUserIdFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter dataServerUserIdFlag) $ mkTypeString stringString
) . showString inputString . showString "define the user-id with which to authenticate with the referenced RDBMS; default " $ shows defaultDataServerUserId ".",
G.Option "" [dataServerPasswordFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter dataServerPasswordFlag) $ mkTypeString stringString
) . showString inputString . showString "define the password common to all users, required for authentication with the referenced RDBMS; cf. " $ shows databasePasswordFlag ".",
G.Option "" [databaseNameFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter databaseNameFlag) $ mkTypeString stringString
) . showString inputString . showString "define the name of the database on the referenced RDBMS; default " $ shows defaultDatabaseName ".",
#endif
G.Option "" [databaseProjectNameFlag] (
G.ReqArg (Just . (,) databaseProjectNameFlag . Just &&& Input.CommandLineOption.mkConfigLocationParameter databaseProjectNameFlag) $ mkTypeString stringString
) $ showString inputString "define the name of the project in the database from which to read the configuration.",
G.Option "" [databaseUserIdFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter databaseUserIdFlag) $ mkTypeString stringString
) $ showString inputString "used to identify a user's configuration amongst all those in the database; typically one's email-address, since this is naturally unique.",
G.Option "" [databasePasswordFlag] (
G.ReqArg ((,) Nothing {-security-sensitive-} . Input.CommandLineOption.mkConfigLocationParameter databasePasswordFlag) $ mkTypeString stringString
) $ showString inputString "define the password required to grant access to the user's personal configuration in the database.",
#endif /* USE_HDBC */
G.Option "" [ExecutionConfiguration.EvolutionStrategies.fecundityDecayRatioTag] (
G.ReqArg (Just . (,) ExecutionConfiguration.EvolutionStrategies.fecundityDecayRatioTag . Just &&& Input.CommandLineOption.mkOptionsMutator . setFecundityDecayRatio) $ mkTypeString floatString
) . showString executionString $ "define the factor (in the closed unit-interval) by which the fecundity of the breeding-program for future generations, is multiplied (& thus reduced), when the population-diversity ratio falls beneath " ++ show ExecutionConfiguration.EvolutionStrategies.minimumPopulationDiversityRatioTag ++ "; default '" ++ Text.Printf.printf "%.*f" defaultNDecimalDigits (
ExecutionConfiguration.EvolutionStrategies.getFecundityDecayRatio defaultEvolutionStrategies
) ++ "'.",
G.Option "" [ExecutionConfiguration.ExecutionOptions.inputStudentViewTimetableTag] (
G.ReqArg (Just . (,) ExecutionConfiguration.ExecutionOptions.inputStudentViewTimetableTag . Just &&& Input.CommandLineOption.mkOptionsMutator . setInputStudentViewTimetableFilePath) $ mkTypeString filePathString
) $ showString executionString "define the path to a file, from which an initial timetable (viewed from the perspective of student-bodies, & formatted in XML), can be read.",
G.Option "" [ExecutionConfiguration.EvolutionStrategies.minimumPopulationDiversityRatioTag] (
G.ReqArg (Just . (,) ExecutionConfiguration.EvolutionStrategies.minimumPopulationDiversityRatioTag . Just &&& Input.CommandLineOption.mkOptionsMutator . setMinimumPopulationDiversityRatio) $ mkTypeString floatString
) . showString executionString $ "define the population-diversity ratio (in the closed unit-interval), beneath which a reduction in the fecundity of the breeding-program for future generations, by a factor of " ++ show ExecutionConfiguration.EvolutionStrategies.fecundityDecayRatioTag ++ ", is triggered; default '" ++ Text.Printf.printf "%.*f" defaultNDecimalDigits (
ExecutionConfiguration.EvolutionStrategies.getMinimumPopulationDiversityRatio defaultEvolutionStrategies
) ++ "'.",
G.Option "" [ExecutionConfiguration.EvolutionStrategies.nInitialScoutsTag] (
G.OptArg (Just . (,) ExecutionConfiguration.EvolutionStrategies.nInitialScoutsTag &&& Input.CommandLineOption.mkOptionsMutator . setNInitialScouts) $ mkTypeString intString
) $ showString executionString "define the initial number of candidates to select from each generation in the evolution of the timetable; if the argument is unspecified then the number of scouts varies depending on the quality of the candidates; which is also the default.",
G.Option "" [ExecutionConfiguration.OptimiseLessonCriteriaWeights.tag] (
G.ReqArg (Just . (,) ExecutionConfiguration.OptimiseLessonCriteriaWeights.tag . Just &&& Input.CommandLineOption.mkOptionsMutator . setOptimiseLessonCriteriaWeights) "<Quadruple>"
) . showString executionString $ "optimise the weights of lesson-criteria, using the weighted mean over timetable-criteria, over all specified raster-scans of the initial deterministic timetable; default '" ++ show (
let
defaultOptimiseLessonCriteriaWeights = ExecutionConfiguration.ExecutionOptions.getOptimiseLessonCriteriaWeights defaultExecutionOptions
in ExecutionConfiguration.OptimiseLessonCriteriaWeights.mkOptimiseLessonCriteriaWeights (
ExecutionConfiguration.OptimiseLessonCriteriaWeights.getNTrials defaultOptimiseLessonCriteriaWeights
) (
realToFrac $ ExecutionConfiguration.OptimiseLessonCriteriaWeights.getChangeMagnitude defaultOptimiseLessonCriteriaWeights :: FractionalIOFormat
) (
realToFrac $ ExecutionConfiguration.OptimiseLessonCriteriaWeights.getReductionFactor defaultOptimiseLessonCriteriaWeights
) (
ExecutionConfiguration.OptimiseLessonCriteriaWeights.getUseMeanOverRasterScans defaultOptimiseLessonCriteriaWeights
)
) ++ "'.",
G.Option "" [ExecutionConfiguration.ExecutionOptions.permitTemporaryStudentBodyMergerTag] (
G.OptArg (Just . (,) ExecutionConfiguration.ExecutionOptions.permitTemporaryStudentBodyMergerTag &&& Input.CommandLineOption.mkOptionsMutator . setPermitTemporaryStudentBodyMerger) $ mkTypeString boolString
) . showString executionString . showString "permit a temporary merger between student-bodies, to permit a teacher & location to be shared for the duration of a course; default '" $ shows (
ExecutionConfiguration.ExecutionOptions.getPermitTemporaryStudentBodyMerger defaultExecutionOptions
) "'. If the argument is unspecified, then 'True' will be inferred.",
G.Option "r" [ExecutionConfiguration.ExecutionOptions.randomSeedTag] (
G.OptArg (Just . (,) ExecutionConfiguration.ExecutionOptions.randomSeedTag &&& Input.CommandLineOption.mkOptionsMutator . setRandomSeed) $ mkTypeString intString
) . showString executionString . showString "seed the pseudo-random number-generator with the specified integer, to produce a repeatable sequence; if this option is unspecified then the seed is unpredictable, but if only its argument is unspecified then the seed defaults to '" $ shows defaultRandomSeed "'.",
G.Option "" [ExecutionConfiguration.ExecutionOptions.reduceStudentBodyRegisterTag] (
G.OptArg (Just . (,) ExecutionConfiguration.ExecutionOptions.reduceStudentBodyRegisterTag &&& Input.CommandLineOption.mkOptionsMutator . setReduceStudentBodyRegister) $ mkTypeString boolString
) . showString executionString . showString "permit a permanent merger between student-bodies with identical profiles, to reduce the number of independently schedulable entities; default '" $ shows (
ExecutionConfiguration.ExecutionOptions.getReduceStudentBodyRegister defaultExecutionOptions
) "'. If the argument is unspecified, then 'True' will be inferred.",
G.Option "" [ExecutionConfiguration.ExecutionOptions.removeRedundantCoursesTag] (
G.OptArg (Just . (,) ExecutionConfiguration.ExecutionOptions.removeRedundantCoursesTag &&& Input.CommandLineOption.mkOptionsMutator . setRemoveRedundantCourses) $ mkTypeString boolString
) . showString executionString . showString "define whether to automatically remove any courses which aren't required by any student-body; default '" $ shows (
ExecutionConfiguration.ExecutionOptions.getRemoveRedundantCourses defaultExecutionOptions
) "'. If the argument is unspecified, then 'True' will be inferred.",
G.Option "" [OutputConfiguration.Verbosity.tag] (
G.ReqArg (Just . (,) OutputConfiguration.Verbosity.tag . Just &&& Input.CommandLineOption.mkOptionsMutator . setVerbosity) "<Verbosity>"
) . showString outputString . showString "define the log-level; default '" $ shows (OutputConfiguration.Options.getVerbosity defaultOutputOptions) "'.",
let
tag :: String
tag = "displayRuntimeLog"
in G.Option "" [tag] (
G.OptArg (Just . (,) tag &&& Input.CommandLineOption.mkOptionsMutator . setDisplayRuntimeInformation) $ mkTypeString boolString
) . showString outputString . showString "requests that the runtime-log is rendered in all XHTML output-streams; default '" $ shows (OutputConfiguration.Style.getDisplayRuntimeInformation defaultStyle) "'. If the argument is unspecified, then 'True' will be inferred.",
G.Option "" [OutputConfiguration.Options.nDecimalDigitsTag] (
G.ReqArg (Just . (,) OutputConfiguration.Options.nDecimalDigitsTag . Just &&& Input.CommandLineOption.mkOptionsMutator . setNDecimalDigits) $ mkTypeString intString
) . showString outputString . showString "define the precision with which fractional auxiliary data is displayed; default '" $ shows defaultNDecimalDigits "'.",
G.Option "" [OutputConfiguration.Options.outputConfigFilePathTag] (
G.ReqArg (Just . (,) OutputConfiguration.Options.outputConfigFilePathTag . Just &&& Input.CommandLineOption.mkOptionsMutator . setOutputConfigFilePath) $ mkTypeString filePathString
) $ showString outputString "define the path to a file into which the unprocessed configuration, formatted in XML, should be written.",
let
tag :: String
tag = "outputStudentViewTimetable"
in G.Option "" [tag] (
G.ReqArg (Just . (,) tag . Just &&& Input.CommandLineOption.mkOptionsMutator . appendOutputStudentViewTimetableFilePath) $ mkTypeString filePathString
) $ showString outputString "define the path to a file into which the resulting timetable (viewed from the perspective of student-bodies & formatted in XML), should be written.",
G.Option "" ["printInputOptionsXMLDTD"] (
G.NoArg (Nothing {-N/A-}, Input.CommandLineOption.mkIOAction printInputOptionsXMLDTD)
) $ showString outputString "generate a rough Document Type Definition (DTD), defining the XML-format of the configuration-file, & then exit. CAVEAT: it must be manually amended to identify 'IMPLIED', 'ID', & 'IDREF' attributes.",
G.Option "" ["printTimetableXMLDTD"] (
G.ReqArg ((,) Nothing {-N/A-} . Input.CommandLineOption.mkIOAction . printTimetableXMLDTD) "<View>"
) $ showString outputString "generate the Document Type Definition (DTD), defining the XML-format of the resulting timetable viewed from the specified perspective, & then exit."
] where
mkTypeString :: ShowS
mkTypeString s = showChar '<' $ showString s ">"
boolString, floatString, intString, filePathString, executionString, infoString, inputString, outputString :: String
boolString = "Bool"
floatString = "Float"
intString = "Int"
filePathString = "File-path"
executionString = "Execution: "
infoString = "Info: "
inputString = "Input: "
outputString = "Output: "
#ifdef USE_HDBC
stringString :: String
stringString = "String"
#endif
defaultEvolutionStrategies :: ExecutionConfiguration.EvolutionStrategies.EvolutionStrategies FractionalIOFormat FractionalIOFormat
defaultExecutionOptions :: ExecutionOptions
defaultOutputOptions :: OutputConfiguration.Options.Options MinimumContrastRatio
defaultStyle :: OutputConfiguration.Style.Style MinimumContrastRatio
((defaultEvolutionStrategies, defaultExecutionOptions), (defaultOutputOptions, defaultStyle)) = Data.Default.def
defaultRandomSeed :: ExecutionConfiguration.ExecutionOptions.RandomSeed
defaultRandomSeed = 0
defaultNDecimalDigits :: OutputConfiguration.Options.NDecimalDigits
defaultNDecimalDigits = OutputConfiguration.Options.getNDecimalDigits defaultOutputOptions
-- Unary options-mutators.
appendOutputStudentViewTimetableFilePath, setFecundityDecayRatio, setInputStudentViewTimetableFilePath, setMinimumPopulationDiversityRatio, setNDecimalDigits, setOptimiseLessonCriteriaWeights, setOutputConfigFilePath, setVerbosity :: String -> Options -> Options
appendOutputStudentViewTimetableFilePath = Input.Options.appendOutputStudentViewTimetableFilePath
setFecundityDecayRatio = Input.Options.setFecundityDecayRatio . realToFrac . (Input.CommandLineOption.readArg :: String -> FractionalIOFormat)
setInputStudentViewTimetableFilePath = Input.Options.setInputStudentViewTimetableFilePath -- CAVEAT: this can over-ride a specific raster-scan.
setMinimumPopulationDiversityRatio = Input.Options.setMinimumPopulationDiversityRatio . realToFrac . (Input.CommandLineOption.readArg :: String -> FractionalIOFormat)
setNDecimalDigits = Input.Options.setNDecimalDigits . Input.CommandLineOption.readBoundedIntegral
setOptimiseLessonCriteriaWeights = Input.Options.setOptimiseLessonCriteriaWeights . (
\optimiseLessonCriteriaWeights -> ExecutionConfiguration.OptimiseLessonCriteriaWeights.mkOptimiseLessonCriteriaWeights (
ExecutionConfiguration.OptimiseLessonCriteriaWeights.getNTrials optimiseLessonCriteriaWeights
) (
realToFrac (ExecutionConfiguration.OptimiseLessonCriteriaWeights.getChangeMagnitude optimiseLessonCriteriaWeights :: FractionalIOFormat)
) (
realToFrac (ExecutionConfiguration.OptimiseLessonCriteriaWeights.getReductionFactor optimiseLessonCriteriaWeights :: FractionalIOFormat)
) (
ExecutionConfiguration.OptimiseLessonCriteriaWeights.getUseMeanOverRasterScans optimiseLessonCriteriaWeights
)
) . Input.CommandLineOption.readArg
setOutputConfigFilePath = Input.Options.setMaybeOutputConfigFilePath . Just
setVerbosity = Input.Options.setVerbosity . Input.CommandLineOption.readArg
setDisplayRuntimeInformation, setNInitialScouts, setPermitTemporaryStudentBodyMerger, setRandomSeed, setReduceStudentBodyRegister, setRemoveRedundantCourses :: Maybe String -> Options -> Options
setDisplayRuntimeInformation = Input.Options.setDisplayRuntimeInformation . Data.Maybe.maybe True {-default-} Input.CommandLineOption.readArg
setNInitialScouts = Input.Options.setMaybeNInitialScouts . fmap Input.CommandLineOption.readBoundedIntegral
setPermitTemporaryStudentBodyMerger = Input.Options.setPermitTemporaryStudentBodyMerger . Data.Maybe.maybe True {-default-} Input.CommandLineOption.readArg
setRandomSeed = Input.Options.setMaybeRandomSeed . Just . Data.Maybe.maybe defaultRandomSeed Input.CommandLineOption.readBoundedIntegral
setReduceStudentBodyRegister = Input.Options.setReduceStudentBodyRegister . Data.Maybe.maybe True {-default-} Input.CommandLineOption.readArg
setRemoveRedundantCourses = Input.Options.setRemoveRedundantCourses . Data.Maybe.maybe True {-default-} Input.CommandLineOption.readArg
-- Nullary I/O-actions.
printHelp, printVersion, printInputOptionsXMLDTD :: IO ()
printHelp = Control.Monad.void $ Text.Printf.printf "Usage:\t%s\nEBNF argument-format:\n\t%-9s = %-40s%s;\n\t%-9s = %s;\n\t%-9s = %s;\n\t%-9s = %s;\n\t%-9s = %s;\n\t%-9s = %-40s%s;\n\t%-9s = %-40s%s;\n" (
G.usageInfo progName optDescrList
) boolString (
ToolShed.Data.List.showListWith listDelimiters [minBound :: Bool .. maxBound] ""
) "(* Case-sensitive *)" filePathString (
"File-name ('" ++ [System.FilePath.pathSeparator] ++ "' File-name)*"
) floatString "Int ('.' Int)?" "Int" "[0-9]+" "Triple" "'(', Int, ',', Float, ',', Float, ')'" "Verbosity" (
ToolShed.Data.List.showListWith listDelimiters OutputConfiguration.Verbosity.range ""
) "(* Case-sensitive *)" "View" (
ToolShed.Data.List.showListWith listDelimiters OutputConfiguration.View.range ""
) "(* Case-sensitive *)" {-CAVEAT: requires increase to default context-stack-} where
listDelimiters = ('(', '|', ')')
printVersion = putStrLn (
Data.List.intercalate "\n" [
s | (True, s) <- [
(
True, packageIdentifier
), (
True,
showString "Compiled by " . shows (
showString System.Info.compilerName . showChar '-' . Data.List.intercalate "." . map show $ Data.Version.versionBranch System.Info.compilerVersion
) . showString ", with Cabal-flags " $ shows [
showChar
#ifdef USE_HDBC_MYSQL
'+'
#else
'-'
#endif
mySQLPackageName,
showChar
#ifdef USE_HDBC_ODBC
'+'
#else
'-'
#endif
odbcPackageName,
showChar
#ifdef PRINT_DB_QUERIES
'+'
#else
'-'
#endif
"printDBQueries",
showChar
#ifdef PRINT_DB_ROWS
'+'
#else
'-'
#endif
"printDBRows",
showChar
#ifdef QUERY_DB_CONCURRENTLY
'+'
#else
'-'
#endif
"queryDBConcurrently",
showChar
#ifdef USE_UNIX
'+'
#else
'-'
#endif
"unix"
] "."
), (
True, showString "Written by " $ shows author "."
), (
True, showString "Copyright (C) 2013-2015 " $ showString author "."
), (
True, "This program comes with ABSOLUTELY NO WARRANTY."
), (
False, "This is free software, and you are welcome to redistribute it under certain conditions." -- TODO: review.
)
]
] -- List-comprehension.
) >> System.Exit.exitSuccess
outputSysConfig :: HXT.SysConfigList
outputSysConfig = [HXT.withTrace 0 {-valid values in range [0 .. 4]-}]
printInputOptionsXMLDTD = Control.Monad.void . HXT.runX $ HXT.constA (
undefined :: Options
) >>> HXT.xpickleWriteDTD HXT.xpickle outputSysConfig OutputConfiguration.FileFormat.stdoutProxy -- CAVEAT: this DTD requires manual correction of defaulted attributes, which are erroneously defined as 'REQUIRED' rather than 'IMPLIED'.
-- Unary I/O-actions.
printTimetableXMLDTD :: String -> IO ()
printTimetableXMLDTD = Control.Monad.void . HXT.runX . (
\view -> case view of
OutputConfiguration.View.LocationView -> HXT.constA (
undefined :: Model.Timetable.Wrapper Identifiers.LocationId.LocationId Identifiers.TimeslotId.TimeslotId (
LocationView.LessonResourceIds.LessonResourceIds Identifiers.TeacherId.TeacherId
) Identifiers.Level.Level
) >>> HXT.xpickleWriteDTD HXT.xpickle outputSysConfig OutputConfiguration.FileFormat.stdoutProxy
OutputConfiguration.View.StudentView -> HXT.constA (
undefined :: Model.Timetable.Wrapper Aggregate.StudentBody.StudentBody Identifiers.TimeslotId.TimeslotId (
StudentView.LessonResourceIds.LessonResourceIds Identifiers.LocationId.LocationId Identifiers.TeacherId.TeacherId
) Identifiers.Level.Level
) >>> HXT.xpickleWriteDTD HXT.xpickle outputSysConfig OutputConfiguration.FileFormat.stdoutProxy
OutputConfiguration.View.TeacherView -> HXT.constA (
undefined :: Model.Timetable.Wrapper Identifiers.TeacherId.TeacherId Identifiers.TimeslotId.TimeslotId (
TeacherView.LessonResourceIds.LessonResourceIds Identifiers.LocationId.LocationId
) Identifiers.Level.Level
) >>> HXT.xpickleWriteDTD HXT.xpickle outputSysConfig OutputConfiguration.FileFormat.stdoutProxy
) . Input.CommandLineOption.readArg
#ifdef USE_UNIX
SignalHandlers.handleSignals
#endif
-- Use the list of possible options, to process the actual list of arguments, & to record those we want to display in the XHTML-results.
case G.getOpt G.RequireOrder optDescrList args of
(commandLineOptions, [{-non-options-}], [{-errors-}]) -> let
visibleArgs :: [(String, Maybe String)]
ioActions :: [IO ()]
optionsMutators :: [Options -> Options]
configLocationParameters :: Data.Map.Map Input.CommandLineOption.Flag String
(visibleArgs, (ioActions, optionsMutators, configLocationParameters)) = Data.Maybe.catMaybes *** Input.CommandLineOption.partition3 $ unzip commandLineOptions -- Categorise the specified command-line options.
in if not $ null ioActions
then do
sequence_ ioActions
if null optionsMutators && Data.Map.null configLocationParameters
then System.Exit.exitSuccess
else error "incompatible command-line options."
else if Data.Map.null configLocationParameters
then error . shows (Input.CommandLineOption.longFlagPrefix ++ inputConfigFilePathFlag)
#ifdef USE_HDBC
. showString " or " . shows mandatoryDBFlags
#endif
$ " must be specified."
else {-config-location specified-} let
{-
The strategy is to either parse XML or query the database, for the input-options, then over-ride them with each of the command-line options-mutators,
but regrettably "verbosity" (a command-line option) is needed while doing so.
This is resolved by reading the "verbosity" from the command-line first.
-}
preVerbosity :: Distribution.Verbosity.Verbosity
preVerbosity
| null verbosityArgs = Data.Default.def
| otherwise = Input.CommandLineOption.readArg $ head verbosityArgs
where
verbosityArgs :: [String]
verbosityArgs = Input.CommandLineOption.getArgs (
map (showString Input.CommandLineOption.longFlagPrefix) . drop 4 {-those prefixes ambiguous with "version"-} $ Data.List.inits OutputConfiguration.Verbosity.tag -- Generate all unique abbreviations.
) args
inputSysConfig :: HXT.SysConfigList
inputSysConfig = [
HXT.withRemoveWS HXT.yes, -- Remove white-space, e.g. any indentation which might have been introduced by 'HXT.withIndent'.
HXT.withStrictInput HXT.yes, -- Read the input file strictly (cf. lazily), this ensures file-closure even if not completely read.
HXT.withValidate HXT.yes -- Validate against any DTD referenced from the specified XML-file.
]
processInputOptions :: Options -> IO ()
processInputOptions inputOptions
| null configVersion = error . showString "undefined " $ shows Input.ConfigVersion.tag "."
| not $ Factory.Data.Interval.elem' configVersion tolerableConfigVersionInterval = error . showString Input.ConfigVersion.tag . showChar '=' . shows (Input.ConfigVersion.toString configVersion) . showString ", falls outside tolerable bounds " $ shows (Input.ConfigVersion.toString *** Input.ConfigVersion.toString $ tolerableConfigVersionInterval) "."
| not $ ToolShed.SelfValidate.isValid inputOptions'' = error $ ToolShed.SelfValidate.getFirstError inputOptions'' -- Now that the input-options have been amended according to the command-line options, check that they're valid.
| otherwise = do
#ifdef TOOL_VERSION_ghc
numProcessors <- GHC.Conc.getNumProcessors
Control.Monad.when (verbosity /= minBound && numProcessors > 1 && GHC.Conc.numCapabilities == 1) . System.IO.hPutStrLn System.IO.stderr . showString "WARNING:\tthis application would benefit from " . shows numProcessors . showString " CPU-cores; try '" . showString progName . showChar ' ' $ showString (unwords args) " +RTS -N'."
#endif
Control.Monad.when (verbosity == maxBound) $ fmap (
showString "INFO:\tconfiguration read after " . (`showString` ".") . show . (`Data.Time.Clock.diffUTCTime` startUTCTime)
) Data.Time.Clock.getCurrentTime >>= System.IO.hPutStrLn System.IO.stderr -- CAVEAT: this is only meaningful when there's no password-dialogue.
Control.Monad.when (Data.Maybe.isJust maybeOutputConfigFilePath) $ let
outputConfigFilePath = Data.Maybe.fromJust maybeOutputConfigFilePath
in Control.Exception.catch (
writeXMLToFile outputConfigFilePath Input.Options.tag (
dtdDir </> progName <.> dtdSuffix
) inputOptions {-the original-}
) $ \e -> System.IO.hPutStrLn System.IO.stderr . showString "WARNING:\tfailed to write the configuration in XML, to " . showString OutputConfiguration.Options.outputConfigFilePathTag . showChar '=' . shows outputConfigFilePath . showString "; " $ shows (e :: Control.Exception.SomeException) "." -- This error isn't fatal, so continue.
Control.Monad.unless (verbosity == minBound) $ mapM_ (System.IO.hPutStrLn System.IO.stderr) warnings -- Issue any warnings regarding inputOptions'.
-- Construct an initial deterministic timetable.
let maybeHint = ExecutionConfiguration.ExecutionOptions.getMaybeHint executionOptions
maybeStudentViewTimetables <- Data.Maybe.maybe (
return {-to IO-monad-} [Nothing] -- Neither a traversalOrder nor an input-filePath were specified.
) (
const (
return {-to IO-monad-} [Nothing] -- A traversalOrder was specified.
) `either` (
\studentViewTimetableFilePath -> HXT.runX $ HXT.xunpickleDocument HXT.xpickle (
HXT.withTrace (fromEnum verbosity `min` 2) : inputSysConfig -- CAVEAT: the maximum trace-level is actually 4; but that's VERY verbose.
) studentViewTimetableFilePath >>> HXT.arrIO (
\wrapper -> let
studentViewTimetable = Model.Timetable.deconstruct wrapper
maybeErrorMessage = Dynamic.StudentViewTimetableUtilities.isTimetableValid problemParameters executionOptions problemAnalysis studentViewTimetable
in Data.Maybe.maybe (
return {-to IO-monad-} $ Just studentViewTimetable
) (
error . shows studentViewTimetableFilePath . showString " failed validation; "
) maybeErrorMessage
)
)
) maybeHint
randomGen <- Data.Maybe.maybe (
do
Control.Monad.when (verbosity > Data.Default.def) $ System.IO.hPutStrLn System.IO.stderr "WARNING:\tseeding the pseudo-random number-generator from the operating-system; the result will not typically be repeatable."
System.Random.getStdGen
) (
return {-to IO-monad-} . System.Random.mkStdGen -- Seed the pseudo-random number-generator with the specified integer.
) $ ExecutionConfiguration.ExecutionOptions.getMaybeRandomSeed executionOptions
if null maybeStudentViewTimetables
then error . showString "failed to parse a StudentView-timetable from " . showString ExecutionConfiguration.ExecutionOptions.inputStudentViewTimetableTag . showChar '=' $ show maybeHint
else let
deterministicStudentViewTimetableSelection :: OutputFormat.DeterministicStudentViewTimetableSelection.DeterministicStudentViewTimetableSelection CriterionValue CriterionWeight Identifiers.Level.Level Identifiers.LocationId.LocationId Mean StandardDeviation Identifiers.TeacherId.TeacherId Identifiers.TimeslotId.TimeslotId WeightedMean
(
(executionOptions', deterministicStudentViewTimetableSelection),
optimiseLessonCriteriaWeightsResults
) = Control.Monad.Writer.runWriter $ Implementation.EvolutionaryAlgorithm.optimiseLessonCriteriaWeights problemParameters executionOptions problemAnalysis (
head {-it's a singleton-} maybeStudentViewTimetables
) randomGen {-used if ExecutionConfiguration.OptimiseLessonCriteriaWeights.isRequired-}
deterministicStudentViewTimetable = OutputFormat.DeterministicStudentViewTimetableSelection.getStudentViewTimetable deterministicStudentViewTimetableSelection -- Access.
evolutionStrategyStatisticsList :: [OutputFormat.EvolutionStrategyStatistics.EvolutionStrategyStatistics WeightedMean CriterionValue]
(studentViewTimetable, evolutionStrategyStatisticsList) = Control.Monad.Writer.runWriter $ Implementation.EvolutionaryAlgorithm.evolveStudentViewTimetable randomGen problemParameters executionOptions' problemAnalysis deterministicStudentViewTimetable -- Evolve the initial deterministic timetable.
-- Analyse the results.
in do
if verbosity == Data.Default.def -- Print either a progress-bar or the 'runtimeLog'.
then let
stagingPost :: Char
stagingPost = '.'
in System.IO.hPutStrLn System.IO.stderr $ seq deterministicStudentViewTimetable stagingPost : map (
(`seq` stagingPost) . OutputFormat.EvolutionStrategyStatistics.getWeightedMeanOfTimetableCriteria
) evolutionStrategyStatisticsList -- Print progress-bar.
else Control.Monad.when (verbosity > Data.Default.def) . mapM_ (System.IO.hPutStrLn System.IO.stderr) $ (
"INFO:\t" ++ Data.Maybe.maybe "a variable number of" (
(++ " initial") . show
) (
ExecutionConfiguration.EvolutionStrategies.getMaybeNInitialScouts $ ExecutionConfiguration.ExecutionOptions.getEvolutionStrategies executionOptions -- CAVEAT: unnecessary use of "executionOptions'" here, will block output until it's evaluated.
) ++ " scouts will be dispatched during evolution."
) : map (
\(key, value) -> key ++ ": " ++ value
) (
OutputFormat.EvolutionStrategyStatistics.composeRuntimeLog executionOptions' nDecimalDigits (
ExecutionConfiguration.ExecutionOptions.hintWasSpecified executionOptions {- CAVEAT: unnecessary use of executionOptions' here, will block output until it's evaluated-}
) (
ExecutionConfiguration.EvolutionStrategies.areAllZero $ ExecutionConfiguration.ExecutionOptions.getEvolutionStrategies executionOptions
) lessonCriteriaWeights (
ExecutionConfiguration.OptimiseLessonCriteriaWeights.getUseMeanOverRasterScans $ ExecutionConfiguration.ExecutionOptions.getOptimiseLessonCriteriaWeights executionOptions -- CAVEAT: unnecessary use of executionOptions' here, will block output until it's evaluated.
) optimiseLessonCriteriaWeightsResults deterministicStudentViewTimetableSelection evolutionStrategyStatisticsList . snd {-[Maybe timetableCriterion]-} . Control.Arrow.first (
\x -> x :: WeightedMean -- Define the type of the discarded datum.
) . Control.Monad.Writer.runWriter $ Implementation.TimetableFitness.evaluateFitness problemParameters executionOptions' problemAnalysis studentViewTimetable
)
-- Present the 'timetable' in each of the requested output-formats.
mapM_ (
\fileFormat -> let
filePath = OutputConfiguration.FileFormat.getFilePath fileFormat
in Control.Exception.catch (
case OutputConfiguration.FileFormat.getFormat fileFormat of
OutputConfiguration.Format.XHTML style -> let
description, documentTitle :: String
description = "The proposed solution to the specified school-timetable problem"
documentTitle = unwords $ progName : map (
uncurry showString . (
showString Input.CommandLineOption.longFlagPrefix *** Data.Maybe.maybe "" (showString "='" . (`showString` "'"))
)
) visibleArgs
in do
Control.Monad.when (verbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . showString "INFO:\tdataDir=" . shows dataDir . showString ", appUserDataDir=" $ shows appUserDataDir "."
maybeCSSURL <- Data.Maybe.maybe (
let
cssFileName :: System.FilePath.FilePath
cssFileName = progName <.> Text.CSS.cssSuffix -- The default CSS-filename.
searchPath = [
".", -- CWD.
appUserDataDir </> Text.CSS.cssSuffix, -- Under the user's home-directory.
dataDir </> Text.CSS.cssSuffix -- Under the installation-directory defined during 'cabal configure'.
] -- CAVEAT: not "css/", i.e. relative to the root of the source-tree, which one wouldn't typically install.
in ToolShed.System.File.locate cssFileName searchPath >>= Data.Maybe.maybe (
do
Control.Monad.unless (verbosity == minBound) . System.IO.hPutStrLn System.IO.stderr . showString "WARNING:\tthe default CSS-filename " . shows cssFileName . showString ", wasn't found in any of " . (`showString` ".") $ show searchPath
return {-to IO-monad-} Nothing
) (
\cssFilePath -> do
Control.Monad.when (verbosity > Data.Default.def) . System.IO.hPutStrLn System.IO.stderr . showString "INFO:\twriting the CSS-filepath " $ shows cssFilePath " into the XHTML-output."
return {-to IO-monad-} $ Just cssFilePath
) . Data.Maybe.listToMaybe
) (
return {-to IO-monad-} . Just
) $ OutputConfiguration.Style.getMaybeCSSURL style
Control.Exception.catch (
(
\document -> if filePath == OutputConfiguration.FileFormat.stdoutProxy
then putStrLn document
else System.IO.withFile filePath System.IO.WriteMode (`System.IO.hPutStrLn` document)
) . OutputFormat.XHTMLFormat.renderDocument maybeCSSURL author description (
Data.List.intercalate ", " [packageIdentifier, "Timetable", "Haskell", "Evolutionary algorithm"] -- Key-words.
) progName documentTitle $ OutputFormat.XHTMLFormat.composeBody problemParameters executionOptions' outputOptions problemAnalysis (
if OutputConfiguration.Style.getDisplayRuntimeInformation style
then Just (
warnings,
OutputFormat.EvolutionStrategyStatistics.toHtml executionOptions' nDecimalDigits lessonCriteriaWeights optimiseLessonCriteriaWeightsResults deterministicStudentViewTimetableSelection evolutionStrategyStatisticsList
)
else Nothing
) (
OutputConfiguration.Style.getDisplayViews style
) (
OutputConfiguration.Style.getDisplaySupplementaryInformation style
) (
OutputConfiguration.Style.getMergeDuplicateTimeslots style
) (
OutputConfiguration.Style.getDisplayAxisLabels style
) (
OutputConfiguration.Style.getWeekend style
) (
OutputConfiguration.Style.getMaybeGenerateLessonColour style
) studentViewTimetable
) $ \e -> System.IO.hPutStrLn System.IO.stderr . showString "WARNING:\tfailed to render the results in XHTML; \"" $ shows (e :: Control.Exception.SomeException) "\"." -- There may be other file-formats to process, so continue.
OutputConfiguration.Format.XML view -> let
permitTemporaryStudentBodyMerger :: Bool
permitTemporaryStudentBodyMerger = ExecutionConfiguration.ExecutionOptions.getPermitTemporaryStudentBodyMerger executionOptions'
in Control.Exception.catch (
(
case view of
OutputConfiguration.View.LocationView -> writeXMLToFile filePath Model.Timetable.tag (
dtdDir </> OutputFormat.XHTMLFormatLocationViewTimetable.locationViewTimetableTag <.> dtdSuffix -- Reference the corresponding packaged DTD.
) . Model.Timetable.MkWrapper . LocationView.Timetable.fromStudentViewTimetable permitTemporaryStudentBodyMerger (ProblemConfiguration.ProblemAnalysis.getFreeLocationViewTimetable problemAnalysis)
OutputConfiguration.View.StudentView -> writeXMLToFile filePath Model.Timetable.tag (
dtdDir </> OutputFormat.XHTMLFormatStudentViewTimetable.studentViewTimetableTag <.> dtdSuffix -- Reference the corresponding packaged DTD.
) . Model.Timetable.MkWrapper
OutputConfiguration.View.TeacherView -> writeXMLToFile filePath Model.Timetable.tag (
dtdDir </> OutputFormat.XHTMLFormatTeacherViewTimetable.teacherViewTimetableTag <.> dtdSuffix -- Reference the corresponding packaged DTD.
) . Model.Timetable.MkWrapper . TeacherView.Timetable.fromStudentViewTimetable permitTemporaryStudentBodyMerger (ProblemConfiguration.ProblemAnalysis.getFreeTeacherViewTimetable problemAnalysis)
) studentViewTimetable
) $ \e -> System.IO.hPutStrLn System.IO.stderr . showString "WARNING:\tfailed to write the solution in XML, to path=" . shows filePath . showString "; \"" $ shows (e :: Control.Exception.SomeException) "\"." -- There may be other file-formats to process, so continue.
) $ \e -> System.IO.hPutStrLn System.IO.stderr . showString "WARNING:\tfailed to process " . shows fileFormat . showString "; \"" $ shows (e :: Control.Exception.SomeException) "\"." -- There may be other file-formats to process, so continue.
) outputFileFormats
Control.Monad.when (verbosity == maxBound) $ fmap (
showString "INFO:\ttotal elapsed time " . (`showString` ".") . show . (`Data.Time.Clock.diffUTCTime` startUTCTime)
) Data.Time.Clock.getCurrentTime >>= System.IO.hPutStrLn System.IO.stderr
where
configVersion :: Input.ConfigVersion.ConfigVersion
configVersion = Input.ConfigVersion.normalise $ Input.Options.getConfigVersion inputOptions
tolerableConfigVersionInterval :: Factory.Data.Interval.Interval Input.ConfigVersion.ConfigVersion
tolerableConfigVersionInterval = Factory.Data.Interval.precisely $ Input.ConfigVersion.normalise [1, 0] -- Only version "1.0" is tolerable.
inputOptions' :: Options
inputOptions' = foldr ($) inputOptions {-initial value-} optionsMutators -- Sequentially mutate the configuration, using each of the options-mutators specified on the command-line.
outputOptions = Input.Options.getOutputOptions inputOptions' -- Deconstruct.
nDecimalDigits = OutputConfiguration.Options.getNDecimalDigits outputOptions
-- Amend the problemParameters according to the executionOptions, logging any changes.
problemParameters :: ProblemParameters
mergedStudentBodies :: [[Aggregate.StudentBody.StudentBody]]
pointlessGroupIds, unsubscribedGroupIds :: [Data.Group.Id]
redundantKnowledgeByTeacherId :: [(Identifiers.TeacherId.TeacherId, Data.Subject.Knowledge Identifiers.Level.Level)]
disabledProblemValidationSwitches :: [String]
(((((problemParameters, mergedStudentBodies), pointlessGroupIds), unsubscribedGroupIds), redundantKnowledgeByTeacherId), disabledProblemValidationSwitches) = Control.Arrow.first (
Control.Arrow.first (
Control.Arrow.first (
Control.Arrow.first (
Control.Monad.Writer.runWriter . (
if ExecutionConfiguration.ExecutionOptions.getReduceStudentBodyRegister e
then ProblemConfiguration.ProblemParameters.reduceStudentBodyRegister (OutputConfiguration.Options.getStudentBodyMnemonicSeparator outputOptions) -- Which returns a Writer.
else return {-to Writer-monad-}
) . ProblemConfiguration.ProblemParameters.mergeConstraintsOnSynchronisedCourses
) . Control.Monad.Writer.runWriter . (
if ExecutionConfiguration.ExecutionOptions.getRemovePointlessGroups e
then ProblemConfiguration.ProblemParameters.removePointlessGroups -- Which returns a Writer.
else return {-to Writer-monad-}
)
) . Control.Monad.Writer.runWriter . (
if ExecutionConfiguration.ExecutionOptions.getRemoveUnsubscribedGroups e
then ProblemConfiguration.ProblemParameters.removeUnsubscribedGroups -- Which returns a Writer.
else return {-to Writer-monad-}
)
) . Control.Monad.Writer.runWriter . (
if ExecutionConfiguration.ExecutionOptions.getRemoveRedundantCourses e
then ProblemConfiguration.ProblemParameters.removeRedundantCourses -- Which returns a Writer.
else return {-to Writer-monad-}
)
) . Control.Monad.Writer.runWriter . (
if ExecutionConfiguration.ExecutionOptions.getPermitTemporaryStudentBodyMerger e
then ProblemConfiguration.ProblemParameters.disableAnyValidationInappropriateForTemporaryStudentBodyMerger -- Which returns a Writer.
else return {-to Writer-monad-}
) $ Input.Options.getProblemParameters inputOptions' where
e = Input.Options.getExecutionOptions inputOptions'
-- Amend the executionOptions according to the problemParameters, gathering the list of changes & concatenating it with other warnings.
(executionOptions, warnings) = let
showListWithQuotesAndSpaces :: Show a => [a] -> String
showListWithQuotesAndSpaces = Data.List.intercalate ", " . map show
in Control.Arrow.second (
\((maybeLessonCriteriaWeightsWarning, maybeTimetableCriteriaWeightsWarning), maybeEvolutionStrategyFecundityWarnings) -> map (
showString "WARNING:\t" . (`showString` ".")
) $ Data.Maybe.catMaybes [
maybeLessonCriteriaWeightsWarning,
maybeTimetableCriteriaWeightsWarning,
maybeEvolutionStrategyFecundityWarnings
] ++ Configuration.issueWarnings inputOptions' ++ [
msg | (True, msg) <- [
(
not $ null disabledProblemValidationSwitches,
"the following problem-validation switches are inappropriate when temporary student-body mergers are permissible, & have been disabled; " ++ showListWithQuotesAndSpaces disabledProblemValidationSwitches
), (
not $ null redundantKnowledgeByTeacherId,
"those subjects for which there's zero demand have been removed; " ++ show (
Control.Arrow.second Data.Set.toList `map` redundantKnowledgeByTeacherId
)
), (
not $ null unsubscribedGroupIds,
"those groups to which neither student-bodies nor teachers have subscribed, have been removed from the group-catalogue; " ++ showListWithQuotesAndSpaces unsubscribedGroupIds
), (
not $ null pointlessGroupIds,
"those groups for which zero meetings have been scheduled, have been removed from the group-catalogue; " ++ showListWithQuotesAndSpaces pointlessGroupIds
), (
not $ null mergedStudentBodies,
"those student-bodies whose profiles are identical, have been merged; " ++ showListWithQuotesAndSpaces (
map Aggregate.StudentBody.getMnemonic `map` mergedStudentBodies
)
),
case (
ExecutionConfiguration.ExecutionOptions.getMaybeHint $ Input.Options.getExecutionOptions inputOptions',
ExecutionConfiguration.ExecutionOptions.getMaybeHint executionOptions {-lazy evaluation-}
) of
(Just hint, Just hint') -> (
hint /= hint',
showString "the command-line specification of '" . showString ExecutionConfiguration.ExecutionOptions.inputStudentViewTimetableTag . showChar '=' . either shows shows hint' . showString "', overrides the configured " $ either (
showString "raster-scan " . show
) (
showString "input student-view timetable " . show
) hint
) -- Pair.
_ -> (False, undefined)
]
] -- List-comprehension.
) . (
\e -> let
maybeFormatTags :: String -> [String] -> Maybe String
maybeFormatTags _ [] = Nothing
maybeFormatTags s l = Just $ s ++ showListWithQuotesAndSpaces l
composeZeroedWeightsStatement :: String -> [String] -> Maybe String
composeZeroedWeightsStatement s = maybeFormatTags $ "the following " ++ s ++ "-criteria are inappropriate for the specified problem-parameters, & consequently their weights have been zeroed; "
in Control.Arrow.second (
(
composeZeroedWeightsStatement "lesson" *** composeZeroedWeightsStatement "timetable"
) *** maybeFormatTags "the following evolution-strategies are inappropriate for the specified problem-parameters, & consequently their fecundities have been zeroed; "
) $ Input.Options.zeroInappropriateExecutionOptions (ExecutionConfiguration.ExecutionOptions.getZeroInappropriateOptions e) problemParameters e -- CAVEAT: actions aren't printed until after checking the validity of the resulting structure.
) $ Input.Options.getExecutionOptions inputOptions'
lessonCriteriaWeights = ExecutionConfiguration.ExecutionOptions.getLessonCriteriaWeights executionOptions
problemAnalysis :: ProblemAnalysis
problemAnalysis = ProblemConfiguration.ProblemAnalysis.mkProblemAnalysis problemParameters
inputOptions'' :: Options
inputOptions'' = inputOptions' {
Input.Options.getExecutionOptions = executionOptions, -- CAVEAT: not including any optimisation of lesson-criteria weights in executionOptions'.
Input.Options.getProblemParameters = problemParameters
} -- Re-integrate the amended configuration-parameters.
dtdSuffix, dtdDir :: System.FilePath.FilePath
dtdSuffix = "dtd"
dtdDir = dataDir </> dtdSuffix {-name the directory the same as the file-suffixes it contains-}
maybeOutputConfigFilePath = OutputConfiguration.Options.getMaybeOutputConfigFilePath outputOptions
outputFileFormats = OutputConfiguration.Options.getFileFormats outputOptions
verbosity = OutputConfiguration.Options.getVerbosity outputOptions
in case Data.Map.lookup inputConfigFilePathFlag configLocationParameters of -- Determine whether the configuration is filed locally, or in a database.
Just inputConfigFilePath -> do
fileExists <- System.Directory.doesFileExist inputConfigFilePath
if not fileExists
then error . showString "no such file " $ shows inputConfigFilePath "." -- This error would be trapped by HXT.xunpickleDocument, but it doesn't set the exit-status.
else let
maximumTraceLevel :: Int
maximumTraceLevel = 2 -- CAVEAT: HXT trace-levels 3 & 4 are too verbose.
in Control.Monad.void {-discard the return-value of processInputOptions-} . HXT.runX $ HXT.setTraceLevel (
fromEnum preVerbosity `min` maximumTraceLevel
) >>> HXT.xunpickleDocument HXT.xpickle inputSysConfig inputConfigFilePath >>> HXT.traceMsg maximumTraceLevel "XML-configuration parsed" >>> HXT.arrIO processInputOptions
#ifdef USE_HDBC
_ {-connect to the RDBMS-} -> case Data.Map.lookup databaseUserIdFlag configLocationParameters of
Nothing -> error . showString "command-line option " $ shows databaseUserIdFlag' ", must be specified."
Just databaseUserId -> case Data.Map.lookup databaseProjectNameFlag configLocationParameters of
Nothing -> error . showString "command-line option " $ shows databaseProjectNameFlag' ", must be specified."
Just databaseProjectName -> let
verbose :: Bool
verbose = preVerbosity > Data.Default.def
withEcho :: Bool -> IO a -> IO a
withEcho echo action = do
oldPolicy <- System.IO.hGetEcho System.IO.stdin
Control.Exception.bracket_ (System.IO.hSetEcho System.IO.stdin echo) (System.IO.hSetEcho System.IO.stdin oldPolicy) action
readPassword :: String -> IO String
readPassword prompt = do
Control.Monad.unless (
preVerbosity == minBound -- This might appear to make the process hang, but might be useful when the passwords have already been piped into stdin.
) . System.IO.hPutStr System.IO.stderr . showString "Enter the " $ shows prompt ": "
line <- withEcho False getLine
System.IO.hPutChar System.IO.stderr '\n'
return {-to IO-monad-} line
in
#ifdef USE_HDBC_MYSQL /* This seems to increase the speed of ODBC, but isn't essential */
Database.MySQL.withRTSSignalsBlocked -- CAVEAT: MySQL doesn't re-start actions after interruption.
#endif
(
do
#ifdef USE_HDBC_ODBC
dbConnection <- Database.HDBC.ODBC.connectODBC . Database.ODBC.buildConnectionString Nothing {-ServerName-} Nothing {-Port-} Nothing {-UId-} Nothing {-Data-server password-} Nothing {-Database-} . Data.Maybe.fromMaybe defaultDSN $ Data.Map.lookup dsnFlag configLocationParameters
#elif USE_HDBC_MYSQL
dataServerPassword <- Data.Maybe.maybe (readPassword dataServerPasswordFlag) return {-to IO-monad-} $ Data.Map.lookup dataServerPasswordFlag configLocationParameters
dbConnection <- Database.MySQL.connect (
Data.Maybe.fromMaybe Database.MySQL.defaultHost $ Data.Map.lookup dataServerHostFlag configLocationParameters
) (
Data.Maybe.maybe Database.MySQL.defaultPort read $ Data.Map.lookup dataServerPortFlag configLocationParameters
) (
Data.Maybe.fromMaybe defaultDataServerUserId $ Data.Map.lookup dataServerUserIdFlag configLocationParameters
) dataServerPassword (
Data.Maybe.fromMaybe defaultDatabaseName $ Data.Map.lookup databaseNameFlag configLocationParameters
)
#else /* Currently there aren't any alternative DBMS-interfaces */
dbConnection <- error "unknown HDBC-backend."
#endif
Control.Monad.when verbose . System.IO.hPutStrLn System.IO.stderr . showString "INFO:\tconnection authorised; database-client=" . shows (
showString (Database.HDBC.proxiedClientName dbConnection) . showChar '-' $ Database.HDBC.proxiedClientVer dbConnection
) . showString ", version of database-server=" $ shows (Database.HDBC.dbServerVer dbConnection) "."
let
executableColumnName, emailAddressColumnName, saltColumnName, saltedPasswordHashColumnName, userIdColumnName :: Database.Selector.ColumnName
executableColumnName = "executable"
emailAddressColumnName = "emailAddress"
saltColumnName = "salt"
saltedPasswordHashColumnName = "saltedPasswordHash"
userIdColumnName = "userId"
userTableName :: Database.Selector.TableName
userTableName = Database.Selector.tablePrefix ++ "user"
Control.Exception.catch (
do
-- Retrieve security-details from the RDBMS.
userRows <- Database.Selector.select dbConnection [
userIdColumnName,
saltColumnName,
saltedPasswordHashColumnName,
executableColumnName
] [userTableName] [
(
emailAddressColumnName,
Database.HDBC.toSql (databaseUserId :: String)
) -- CAVEAT: this column is defined as an email-address in the database (to ensure uniqueness), but merely as 'databaseUserId' here.
]
-- Authenticate the user.
case userRows of
[] -> error . showString databaseUserIdFlag . showChar '(' . showString emailAddressColumnName . showString ")=" $ shows databaseUserId " wasn't found in the database."
[userRow] -> case userRow of
[userSql, saltSql, saltedPasswordHashSql, executableSql] -> do
authorised <- case either (
error . showString "failed to parse the value for " . shows saltedPasswordHashColumnName . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql saltedPasswordHashSql of -- Retrieve the recorded raw binary hash, for comparison.
Nothing -> return {-to IO-monad-} True -- A salted password-hash hasn't been recorded.
Just recordedSaltedPasswordHash -> do
saltedPasswordHash <- (
Crypto.Hash.hash . (
either (
error . showString "ERROR:\tfailed to parse the value for " . shows saltColumnName . showString " read from the database; " . show
) id (
Database.HDBC.safeFromSql saltSql
) `Data.ByteString.append`
) . Data.ByteString.Char8.pack
) `fmap` Data.Maybe.maybe (
readPassword databasePasswordFlag
) return {-to IO-monad-} (
Data.Map.lookup databasePasswordFlag configLocationParameters
) -- Generate a salted password-hash for comparison with the recorded value.
System.IO.hClose System.IO.stdin -- Any passwords required, have now been read.
Control.Monad.when (preVerbosity == maxBound) . System.IO.hPutStrLn System.IO.stderr . showString "INFO:\thash generated from salted " . shows databasePasswordFlag . showString "; 0x" $ shows saltedPasswordHash "."
return {-to IO-monad-} $ Data.Byteable.toBytes (saltedPasswordHash :: Crypto.Hash.Digest Crypto.Hash.SHA512) == recordedSaltedPasswordHash -- Authenticate by comparing a hash of the concatenated recorded binary salt & the specified ASCII password, against the recorded binary hash.
if not authorised
then error . showString "incorrect " . shows databasePasswordFlag . showString " for " . showString databaseUserIdFlag . showChar '=' $ shows databaseUserId "; database-access denied."
else {-authorised-} let
userId :: Int -- Arbitrarily.
userId = either (
error . showString "ERROR:\tfailed to parse the value for " . shows userIdColumnName . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql userSql
in do
Control.Monad.when verbose $ fmap (
showString "INFO:\tauthenticated as " . showString progName . showChar '-' . showString userIdColumnName . showChar '=' . shows userId . showString ", after " . (`showString` ".") . show . (`Data.Time.Clock.diffUTCTime` startUTCTime)
) Data.Time.Clock.getCurrentTime >>= System.IO.hPutStrLn System.IO.stderr
-- Query the RDBMS to confirm that the user is active.
if either (
error . showString "ERROR:\tfailed to parse the value for " . shows executableColumnName . showString " read from the database; " . show
) not $ Database.HDBC.safeFromSql executableSql
then error . showString "the account for " . showString databaseUserIdFlag . showChar '(' . showString emailAddressColumnName . showString ")=" $ shows databaseUserId " isn't executable."
else {-executable-} let
projectNameColumnName :: Database.Selector.ColumnName
projectNameColumnName = "projectName"
projectsTableName :: Database.Selector.TableName
projectsTableName = showString Database.Selector.tablePrefix "project"
in do
-- Query the database to construct the input-options.
projectIdRows <- map head {-select the single column requested from each row-} `fmap` Database.Selector.select dbConnection [
Database.Selector.projectIdColumnName
] [projectsTableName] [
(userIdColumnName, userSql),
(projectNameColumnName, Database.HDBC.toSql databaseProjectName)
]
case projectIdRows of
[] -> error . showString projectNameColumnName . showChar '=' . shows databaseProjectName . showString " wasn't found, where " . showString databaseUserIdFlag . showChar '(' . showString emailAddressColumnName . showString ")=" $ show databaseUserId
[projectIdSql] -> let
projectId :: Int -- Arbitrarily.
projectId = either (
error . showString "ERROR:\tfailed to parse the value for " . shows Database.Selector.projectIdColumnName . showString " read from the database; " . show
) id $ Database.HDBC.safeFromSql projectIdSql
in do
Control.Monad.when verbose . System.IO.hPutStrLn System.IO.stderr . showString "INFO:\t" . showString Database.Selector.projectIdColumnName . showChar '=' $ shows projectId " selected."
inputOptions <- Database.Selector.fromDatabase dbConnection projectIdSql
Control.Monad.when verbose . System.IO.hPutStrLn System.IO.stderr $ "INFO:\tproject-configuration read from database."
Database.HDBC.disconnect dbConnection
return {-to IO-monad-} inputOptions
_ -> error . showString "unexpected number of rows=" . shows (length projectIdRows) . showString " selected, where " . showString userIdColumnName . showChar '=' . shows userId . showString " & " . showString projectNameColumnName . showChar '=' $ showString databaseProjectName "."
_ -> error . showString "unexpected number of columns=" . shows (length userRow) . showString " selected, where " . showString databaseUserIdFlag . showChar '(' . showString emailAddressColumnName . showString ")=" $ showString databaseUserId "."
_ -> error . showString "unexpected number of rows=" . shows (length userRows) . showString " selected, where " . showString databaseUserIdFlag . showChar '(' . showString emailAddressColumnName . showString ")=" $ showString databaseUserId "."
) $ \e -> do
Database.HDBC.disconnect dbConnection
System.IO.hPutStrLn System.IO.stderr "ERROR:\tfailed to read all the required configuration from the database."
Control.Exception.throwIO (e :: Control.Exception.SomeException)
) >>= processInputOptions
#else /* no HDBC */
_ {-connect to the RDBMS-} -> error . showString "one or more of the database-backend Haskell packages " $ shows [odbcPackageName, mySQLPackageName] " must be installed before database-connectivity can be established."
#endif /* USE_HDBC */
(_, nonOptions, []) -> error . showString "unexpected command-line arguments; " $ shows nonOptions "."
(_, _, errors) -> error $ concat errors