{-# LANGUAGE PatternGuards #-} {-# OPTIONS_GHC -Wall #-} module DatabaseDesign.Ampersand.Misc.Options (Options(..),getOptions,defaultFlags,usageInfo' ,ParserVersion(..) ,verboseLn,verbose,FspecFormat(..),FileFormat(..) ,DocTheme(..),allFspecFormats,helpNVersionTexts) where import System.Environment (getArgs, getProgName,getEnvironment) import DatabaseDesign.Ampersand.Misc.Languages (Lang(..)) import Data.Char (toUpper) import System.Console.GetOpt import System.FilePath import System.Directory import Data.Time.Clock import Data.Time.LocalTime import Control.Monad import Data.Maybe import DatabaseDesign.Ampersand.Basics import Prelude hiding (writeFile,readFile,getContents,putStr,putStrLn) import Data.List fatal :: Int -> String -> a fatal = fatalMsg "Misc.Options" data ParserVersion = Current | Legacy deriving Eq instance Show ParserVersion where show Current = "syntax since Ampersand 2.1.1." show Legacy = "syntax664" -- | This data constructor is able to hold all kind of information that is useful to -- express what the user would like Ampersand to do. data Options = Options { showVersion :: Bool , preVersion :: String , postVersion :: String --built in to aid DOS scripting... 8-(( Bummer. , showHelp :: Bool , verboseP :: Bool , development :: Bool , validateSQL :: Bool , genPrototype :: Bool , autoid :: Bool --implies forall Concept A => value::A->Datatype [INJ]. where instances of A are autogenerated , dirPrototype :: String -- the directory to generate the prototype in. , allInterfaces :: Bool , dbName :: String , genAtlas :: Bool , namespace :: String , autoRefresh :: Maybe Int , testRule :: Maybe String , customCssFile :: Maybe FilePath , importfile :: FilePath --a file with content to populate some (Populated a) --class Populated a where populate::a->b->a , fileformat :: FileFormat --file format e.g. of importfile or export2adl , theme :: DocTheme --the theme of some generated output. (style, content differentiation etc.) , genXML :: Bool , genFspec :: Bool -- if True, generate a functional specification , diag :: Bool -- if True, generate a diagnosis only , fspecFormat :: FspecFormat , genGraphics :: Bool -- if True, graphics will be generated for use in Ampersand products like the Atlas or Functional Spec , genEcaDoc :: Bool -- if True, generate ECA rules in the Functional Spec , proofs :: Bool , haskell :: Bool -- if True, generate the F-structure as a Haskell source file , dirOutput :: String -- the directory to generate the output in. , outputfile :: String -- the file to generate the output in. , crowfoot :: Bool -- if True, generate conceptual models and data models in crowfoot notation , blackWhite :: Bool -- only use black/white in graphics , doubleEdges :: Bool -- Graphics are generated with hinge nodes on edges. , showPredExpr :: Bool -- for generated output, show predicate logic? , noDiagnosis :: Bool -- omit the diagnosis chapter from the functional specification document , diagnosisOnly :: Bool -- give a diagnosis only (by omitting the rest of the functional specification document) , genLegalRefs :: Bool -- Generate a table of legal references in Natural Language chapter , genUML :: Bool -- Generate a UML 2.0 data model , genFPAExcel :: Bool -- Generate an Excel workbook containing Function Point Analisys , genStaticFiles :: Bool-- Generate the static files into the prototype , genBericht :: Bool , genMeat :: Bool -- Generate the meta-population and output it to an .adl file , language :: Maybe Lang -- The language in which the user wants the documentation to be printed. , dirExec :: String --the base for relative paths to input files , progrName :: String --The name of the adl executable , fileName :: FilePath --the file with the Ampersand context , baseName :: String , logName :: String , genTime :: LocalTime , export2adl :: Bool , test :: Bool , includeRap :: Bool -- When set, the standard RAP is 'merged' into the generated prototype.(experimental) , pangoFont :: String -- use specified font in PanDoc. May be used to avoid pango-warnings. , sqlHost :: Maybe String -- do database queries to the specified host , sqlLogin :: Maybe String -- pass login name to the database server , sqlPwd :: Maybe String -- pass password on to the database server , parserVersion :: ParserVersion } -- deriving Show defaultFlags :: Options defaultFlags = Options {genTime = fatal 81 "No monadic options available." , dirOutput = fatal 82 "No monadic options available." , outputfile = fatal 83 "No monadic options available." , autoid = False , dirPrototype = fatal 84 "No monadic options available." , dbName = fatal 85 "No monadic options available." , logName = fatal 86 "No monadic options available." , dirExec = fatal 87 "No monadic options available." , preVersion = fatal 88 "No monadic options available." , postVersion = fatal 89 "No monadic options available." , theme = DefaultTheme , showVersion = False , showHelp = False , verboseP = False , development = False , validateSQL = False , genPrototype = False , allInterfaces = False , genAtlas = False , namespace = [] , autoRefresh = Nothing , testRule = Nothing , customCssFile = Nothing , importfile = [] , fileformat = fatal 101 "--fileformat is required for --import." , genXML = False , genFspec = False , diag = False , fspecFormat = fatal 105 $ "Unknown fspec format. Currently supported formats are "++allFspecFormats++"." , genGraphics = True , genEcaDoc = False , proofs = False , haskell = False , crowfoot = False , blackWhite = False , doubleEdges = False , showPredExpr = False , noDiagnosis = False , diagnosisOnly = False , genLegalRefs = False , genUML = False , genFPAExcel = False , genStaticFiles= True , genBericht = False , genMeat = False , language = Nothing , progrName = fatal 118 "No monadic options available." , fileName = fatal 119 "no default value for fileName." , baseName = fatal 120 "no default value for baseName." , export2adl = False , test = False , includeRap = False , pangoFont = "Sans" , sqlHost = Nothing , sqlLogin = Nothing , sqlPwd = Nothing , parserVersion = Current } getOptions :: IO Options getOptions = do args <- getArgs progName <- getProgName let usage = "\nType '"++ progName++" --help' for usage info." let (o,n,errs) = getOpt Permute (each options) args when ((not.null) errs) (error $ concat errs ++ usage) defaultOpts <- defaultOptionsM (head (n++(error $ "Please supply the name of an ampersand file" ++ usage))) let flags = foldl (flip id) defaultOpts o if showHelp flags || showVersion flags then return flags else checkNSetOptionsAndFileNameM (flags,n) usage where defaultOptionsM :: String -> IO Options defaultOptionsM fName = do utcTime <- getCurrentTime timeZone <- getCurrentTimeZone let localTime = utcToLocalTime timeZone utcTime progName <- getProgName exePath <- findExecutable progName env <- getEnvironment return defaultFlags { genTime = localTime , dirOutput = fromMaybe "." (lookup envdirOutput env) , dirPrototype = fromMaybe ("." (addExtension (takeBaseName fName) ".proto")) (lookup envdirPrototype env) (addExtension (takeBaseName fName) ".proto") , dbName = fromMaybe "" (lookup envdbName env) , logName = fromMaybe "Ampersand.log" (lookup envlogName env) , dirExec = case exePath of Nothing -> fatal 155 $ "Specify the path location of "++progName++" in your system PATH variable." Just s -> takeDirectory s , preVersion = fromMaybe "" (lookup "CCPreVersion" env) , postVersion = fromMaybe "" (lookup "CCPostVersion" env) , progrName = progName } checkNSetOptionsAndFileNameM :: (Options,[String]) -> String -> IO Options checkNSetOptionsAndFileNameM (flags,fNames) usage= if showVersion flags || showHelp flags then return flags else case fNames of [] -> error $ "no file to parse" ++usage [fName] -> checkInvalidOptionCombinations flags >> verboseLn flags "Checking output directories..." >> checkLogName flags >> checkDirOutput flags --REMARK -> checkExecOpts in comments because it is redundant -- it may throw fatals about PATH not set even when you do not need the dir of the executable. -- if you need the dir of the exec, then you should use (dirExec flags) which will throw the fatal about PATH when needed. -- >> checkExecOpts flags >> checkProtoOpts flags >> return flags { fileName = if hasExtension fName then fName else addExtension fName "adl" , baseName = takeBaseName fName , dbName = case dbName flags of "" -> takeBaseName fName str -> str , genAtlas = not (null(importfile flags)) && fileformat flags==Adl1Format , importfile = if null(importfile flags) || hasExtension(importfile flags) then importfile flags else case fileformat flags of Adl1Format -> addExtension (importfile flags) "adl" Adl1PopFormat -> addExtension (importfile flags) "pop" } x:xs -> error $ "too many files: "++ intercalate ", " (x:xs) ++usage where checkInvalidOptionCombinations :: Options -> IO () checkInvalidOptionCombinations f | development f && validateSQL f = error "--dev and --validate must not be used at the same time." --(Reason: see ticket #378) | otherwise = return() checkLogName :: Options -> IO () checkLogName f = createDirectoryIfMissing True (takeDirectory (logName f)) checkDirOutput :: Options -> IO () checkDirOutput f = createDirectoryIfMissing True (dirOutput f) --checkExecOpts :: Options -> IO () --checkExecOpts f = do execPath <- findExecutable (progrName f) -- when (execPath == Nothing) -- (fatal 206 $ "Specify the path location of "++(progrName f)++" in your system PATH variable.") checkProtoOpts :: Options -> IO () checkProtoOpts f = when (genPrototype f) (createDirectoryIfMissing True (dirPrototype f)) data DisplayMode = Public | Hidden data FspecFormat = FPandoc| Fasciidoc| Fcontext| Fdocbook| Fhtml| FLatex| Fman| Fmarkdown| Fmediawiki| Fopendocument| Forg| Fplain| Frst| Frtf| Ftexinfo| Ftextile deriving (Show, Eq) allFspecFormats :: String allFspecFormats = show (map (tail . show) [FPandoc, Fasciidoc, Fcontext, Fdocbook, Fhtml, FLatex, Fman, Fmarkdown, Fmediawiki, Fopendocument, Forg, Fplain, Frst, Frtf, Ftexinfo, Ftextile]) data FileFormat = Adl1Format | Adl1PopFormat deriving (Show, Eq) --file format that can be parsed to some b to populate some Populated a data DocTheme = DefaultTheme -- Just the functional specification | ProofTheme -- A document with type inference proofs | StudentTheme -- Output for normal students of the business rules course | StudentDesignerTheme -- Output for advanced students of the business rules course | DesignerTheme -- Output for non-students deriving (Show, Eq) usageInfo' :: Options -> String -- When the user asks --help, then the public options are listed. However, if also --verbose is requested, the hidden ones are listed too. usageInfo' flags = usageInfo (infoHeader (progrName flags)) (if verboseP flags then each options else publics options) infoHeader :: String -> String infoHeader progName = "\nUsage info:\n " ++ progName ++ " options file ...\n\nList of options:" publics :: [(a, DisplayMode) ] -> [a] publics flags = [o | (o,Public)<-flags] each :: [(a, DisplayMode) ] -> [a] each flags = [o |(o,_) <- flags] options :: [(OptDescr (Options -> Options), DisplayMode) ] options = map pp [ (Option "v" ["version"] (NoArg versionOpt) "show version and exit.", Public) , (Option "h?" ["help"] (NoArg helpOpt) "get (this) usage information.", Public) , (Option "" ["verbose"] (NoArg verboseOpt) "verbose error message format.", Public) , (Option "" ["dev"] (NoArg developmentOpt) "Report and generate extra development information", Hidden) , (Option "" ["validate"] (NoArg (\flags -> flags{validateSQL = True})) "Compare results of rule evaluation in Haskell and SQL (requires command line php with MySQL support)", Hidden) , (Option "p" ["proto"] (OptArg prototypeOpt "dir") ("generate a functional prototype (overwrites environment variable " ++ envdirPrototype ++ ")."), Public) , (Option "d" ["dbName"] (ReqArg dbNameOpt "name") ("database name (overwrites environment variable " ++ envdbName ++ ", defaults to filename)"), Public) , (Option [] ["theme"] (ReqArg themeOpt "theme") "differentiate between certain outputs e.g. student", Public) , (Option "x" ["interfaces"] (NoArg maxInterfacesOpt) "generate interfaces.", Public) , (Option "e" ["export"] (OptArg exportOpt "file") "export as ASCII Ampersand syntax.", Public) , (Option "o" ["outputDir"] (ReqArg outputDirOpt "dir") ("output directory (dir overwrites environment variable " ++ envdirOutput ++ ")."), Public) , (Option [] ["log"] (ReqArg logOpt "name") ("log file name (name overwrites environment variable " ++ envlogName ++ ")."), Hidden) , (Option [] ["import"] (ReqArg importOpt "file") "import this file as the population of the context.", Public) , (Option [] ["fileformat"] (ReqArg formatOpt "format")("format of import file (format=" ++allFileFormats++")."), Public) , (Option [] ["namespace"] (ReqArg namespaceOpt "ns") "places the population in this namespace within the context.", Public) , (Option "f" ["fspec"] (ReqArg fspecRenderOpt "format") ("generate a functional specification document in specified format (format=" ++allFspecFormats++")."), Public) , (Option [] ["refresh"] (OptArg autoRefreshOpt "interval") "Experimental auto-refresh feature", Hidden) , (Option [] ["testRule"] (ReqArg (\ruleName flags -> flags{ testRule = Just ruleName }) "rule name") "Show contents and violations of specified rule.", Hidden) , (Option [] ["css"] (ReqArg (\pth flags -> flags{ customCssFile = Just pth }) "file") "Custom.css file to customize the style of the prototype.", Public) , (Option [] ["noGraphics"] (NoArg noGraphicsOpt) "save compilation time by not generating any graphics.", Public) , (Option [] ["ECA"] (NoArg genEcaDocOpt) "generate documentation with ECA rules.", Public) , (Option [] ["proofs"] (NoArg proofsOpt) "generate derivations.", Public) , (Option [] ["XML"] (NoArg xmlOpt) "generate internal data structure, written in XML (for debugging).", Public) , (Option [] ["haskell"] (NoArg haskellOpt) "generate internal data structure, written in Haskell (for debugging).", Public) , (Option [] ["crowfoot"] (NoArg crowfootOpt) "generate crowfoot notation in graphics.", Public) , (Option [] ["blackWhite"] (NoArg blackWhiteOpt) "do not use colours in generated graphics", Public) , (Option [] ["doubleEdges"] (NoArg doubleEdgesOpt) "generate graphics in an alternate way. (you may experiment with this option to see the differences for yourself)", Public) , (Option [] ["predLogic"] (NoArg predLogicOpt) "show logical expressions in the form of predicate logic." , Public) , (Option [] ["noDiagnosis"] (NoArg noDiagnosisOpt) "omit the diagnosis chapter from the functional specification document." , Public) , (Option [] ["diagnosis"] (NoArg diagnosisOpt) "diagnose your Ampersand script (generates a .pdf file).", Public) , (Option [] ["legalrefs"] (NoArg (\flags -> flags{genLegalRefs = True})) "generate a table of legal references in Natural Language chapter.", Public) , (Option [] ["uml"] (NoArg (\flags -> flags{genUML = True})) "Generate a UML 2.0 data model.", Hidden) , (Option [] ["FPA"] (NoArg (\flags -> flags{genFPAExcel = True})) "Generate a Excel workbook (.xls).", Hidden) , (Option [] ["bericht"] (NoArg (\flags -> flags{genBericht = True})) "Generate definitions for 'berichten' (specific to INDOORS project).", Hidden) , (Option [] ["language"] (ReqArg languageOpt "lang") "Pick 'NL' for Dutch or 'EN' for English,\nas the language to be used in your output.\nWithout this option, output is written in the language of your context.", Public) , (Option [] ["test"] (NoArg testOpt) "Used for test purposes only.", Hidden) , (Option [] ["rap"] (NoArg (\flags -> flags{includeRap = True})) "Include RAP into the generated artifacts (experimental)", Hidden) , (Option [] ["meta"] (NoArg (\flags -> flags{genMeat = True})) "Generate meta-population in an .adl file (experimental)", Hidden) , (Option [] ["pango"] (OptArg pangoOpt "fontname") "specify font name for Pango in graphics.", Hidden) , (Option [] ["no-static-files"] (NoArg (\flags -> flags{genStaticFiles = False})) "Do not generate static files into the prototype directory", Public) , (Option [] ["sqlHost"] (OptArg sqlHostOpt "name") "specify database host name.", Hidden) , (Option [] ["sqlLogin"] (OptArg sqlLoginOpt "name") "specify database login name.", Hidden) , (Option [] ["sqlPwd"] (OptArg sqlPwdOpt "str") "specify database password.", Hidden) , (Option [] ["forceSyntax"] (ReqArg forceSyntaxOpt "versionNumber") "version number of the syntax to be used, ('1' or '2'). Without this, Ampersand will guess the version used.", Hidden) ] where pp :: (OptDescr (Options -> Options), DisplayMode) -> (OptDescr (Options -> Options), DisplayMode) pp (Option a b' c d,e) = (Option a b' c d',e) where d' = afkappen [] [] (words d) 40 afkappen :: [[String]] -> [String] -> [String] -> Int -> String afkappen regels [] [] _ = intercalate "\n" (map unwords regels) afkappen regels totnu [] b = afkappen (regels++[totnu]) [] [] b afkappen regels totnu (w:ws) b | length (unwords totnu) < b - length w = afkappen regels (totnu++[w]) ws b | otherwise = afkappen (regels++[totnu]) [w] ws b envdirPrototype :: String envdirPrototype = "CCdirPrototype" envdirOutput :: String envdirOutput="CCdirOutput" envdbName :: String envdbName="CCdbName" envlogName :: String envlogName="CClogName" versionOpt :: Options -> Options versionOpt flags = flags{showVersion = True} helpOpt :: Options -> Options helpOpt flags = flags{showHelp = True} verboseOpt :: Options -> Options verboseOpt flags = flags{ verboseP = True} developmentOpt :: Options -> Options developmentOpt flags = flags{ development = True} autoRefreshOpt :: Maybe String -> Options -> Options autoRefreshOpt (Just interval) flags | [(i,"")] <- reads interval = flags{autoRefresh = Just i} autoRefreshOpt _ flags = flags{autoRefresh = Just 5} prototypeOpt :: Maybe String -> Options -> Options prototypeOpt nm flags = flags { dirPrototype = fromMaybe (dirPrototype flags) nm , genPrototype = True} importOpt :: String -> Options -> Options importOpt nm flags = flags { importfile = nm } formatOpt :: String -> Options -> Options formatOpt f flags = case map toUpper f of "ADL" -> flags{fileformat = Adl1Format} "ADL1"-> flags{fileformat = Adl1Format} "POP" -> flags{fileformat = Adl1PopFormat} "POP1"-> flags{fileformat = Adl1PopFormat} _ -> flags maxInterfacesOpt :: Options -> Options maxInterfacesOpt flags = flags{allInterfaces = True} themeOpt :: String -> Options -> Options themeOpt t flags = flags{theme = case map toUpper t of "STUDENT" -> StudentTheme "STUDENTDESIGNER" -> StudentDesignerTheme "DESIGNER" -> DesignerTheme "PROOF" -> ProofTheme _ -> DefaultTheme} dbNameOpt :: String -> Options -> Options dbNameOpt nm flags = flags{dbName = if nm == "" then baseName flags else nm } namespaceOpt :: String -> Options -> Options namespaceOpt x flags = flags{namespace = x} xmlOpt :: Options -> Options xmlOpt flags = flags{genXML = True} fspecRenderOpt :: String -> Options -> Options fspecRenderOpt w flags = flags{ genFspec=True , fspecFormat= case map toUpper w of ('A': _ ) -> Fasciidoc ('C': _ ) -> Fcontext ('D': _ ) -> Fdocbook ('H': _ ) -> Fhtml ('L': _ ) -> FLatex ('M':'A':'N': _ ) -> Fman ('M':'A': _ ) -> Fmarkdown ('M':'E': _ ) -> Fmediawiki ('O':'P': _ ) -> Fopendocument ('O':'R': _ ) -> Forg ('P':'A': _ ) -> FPandoc ('P':'L': _ ) -> Fplain ('R':'S': _ ) -> Frst ('R':'T': _ ) -> Frtf ('T':'E':'X':'I': _ ) -> Ftexinfo ('T':'E':'X':'T': _ ) -> Ftextile _ -> fspecFormat flags } allFileFormats :: String allFileFormats = "ADL (.adl), ADL1 (.adl), POP (.pop), POP1 (.pop)" noGraphicsOpt :: Options -> Options noGraphicsOpt flags = flags{genGraphics = False} genEcaDocOpt :: Options -> Options genEcaDocOpt flags = flags{genEcaDoc = True} proofsOpt :: Options -> Options proofsOpt flags = flags{proofs = True} exportOpt :: Maybe String -> Options -> Options exportOpt mbnm flags = flags{export2adl = True ,outputfile = fromMaybe "Export.adl" mbnm} haskellOpt :: Options -> Options haskellOpt flags = flags{haskell = True} outputDirOpt :: String -> Options -> Options outputDirOpt nm flags = flags{dirOutput = nm} crowfootOpt :: Options -> Options crowfootOpt flags = flags{crowfoot = True} blackWhiteOpt :: Options -> Options blackWhiteOpt flags = flags{blackWhite = True} doubleEdgesOpt :: Options -> Options doubleEdgesOpt flags = flags{doubleEdges = not (doubleEdges flags)} predLogicOpt :: Options -> Options predLogicOpt flags = flags{showPredExpr = True} noDiagnosisOpt :: Options -> Options noDiagnosisOpt flags = flags{noDiagnosis = True} diagnosisOpt :: Options -> Options diagnosisOpt flags = flags{diagnosisOnly = True} languageOpt :: String -> Options -> Options languageOpt l flags = flags{language = case map toUpper l of "NL" -> Just Dutch "UK" -> Just English "US" -> Just English "EN" -> Just English _ -> Nothing} forceSyntaxOpt :: String -> Options -> Options forceSyntaxOpt s flags = flags{parserVersion = case s of "1" -> Legacy "2" -> Current "0" -> Current --indicates latest _ -> error $ "Unknown value for syntax version: "++s++". Known values are 0, 1 or 2. 0 indicates latest." } logOpt :: String -> Options -> Options logOpt nm flags = flags{logName = nm} pangoOpt :: Maybe String -> Options -> Options pangoOpt (Just nm) flags = flags{pangoFont = nm} pangoOpt Nothing flags = flags sqlHostOpt :: Maybe String -> Options -> Options sqlHostOpt mnm flags = flags{sqlHost = mnm} sqlLoginOpt :: Maybe String -> Options -> Options sqlLoginOpt mnm flags = flags{sqlLogin = mnm} sqlPwdOpt :: Maybe String -> Options -> Options sqlPwdOpt mnm flags = flags{sqlPwd = mnm} testOpt :: Options -> Options testOpt flags = flags{test = True} verbose :: Options -> String -> IO () verbose flags x | verboseP flags = putStr x | otherwise = return () verboseLn :: Options -> String -> IO () verboseLn flags x | verboseP flags = -- each line is handled separately, so the buffer will be flushed in time. (see ticket #179) mapM_ putStrLn (lines x) | otherwise = return () helpNVersionTexts :: String -> Options -> [String] helpNVersionTexts vs flags = [preVersion flags++vs++postVersion flags++"\n" | showVersion flags]++ [usageInfo' flags | showHelp flags]