{-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -Wall #-}
module DatabaseDesign.Ampersand.Misc.Options 
        (Options(..),getOptions,usageInfo'
        ,ParserVersion(..)
        ,verboseLn,verbose,FspecFormat(..),FileFormat(..)
        ,DocTheme(..),allFspecFormats,helpNVersionTexts)
where
import System.Environment    (getArgs, getProgName,getEnvironment,getExecutablePath )
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 Paths_ampersand (getDataDir)
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 
                       , 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
                       , ampersandDataDir :: FilePath -- the directory where Ampersand data files are. 
                       , progrName :: String --The name of the adl executable
                       , fileName :: FilePath --the file with the Ampersand context
                       , baseName :: String
                       , logName :: FilePath
                       , 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 ::  String  -- do database queries to the specified host
                       , sqlLogin :: String  -- pass login name to the database server
                       , sqlPwd :: String  -- pass password on to the database server
                       , parserVersion :: ParserVersion
                       } 
  
                
getOptions :: IO Options
getOptions =
   do args     <- getArgs
      progName <- getProgName
      exePath <- getExecutablePath -- findExecutable progName
      env <- getEnvironment
      haskellInstallationDirectoryOfAmpersand <- getDataDir
      let dataDirOfAmpersandInstallation = takeDirectory exePath </> ".." </> "AmpersandData" 
      let usage = "\nType '"++ progName++" --help' for usage info."
      let (actions, nonOptions, errors) = getOpt Permute (each options) args
      let fName = head (nonOptions++(error $ "Please supply the name of an ampersand file" ++ usage))
      localTime <- getLocalTime 
      when ((not.null) errors) (error $ concat errors ++ usage)
      
      -- Here we thread startOptions through all supplied option actions
      flags <- foldl (>>=) (return (startOptions fName localTime env exePath progName dataDirOfAmpersandInstallation)) actions
    --  defaultOpts <- defaultOptionsM 
    --  let flags = foldl (flip id) opts actions
      if showHelp flags || showVersion flags
      then return flags
      else checkNSetOptionsAndFileNameM (flags,nonOptions) usage
        
  where 
     getLocalTime :: IO LocalTime
     getLocalTime = do utcTime <- getCurrentTime
                       timeZone <- getCurrentTimeZone
                       return (utcToLocalTime timeZone utcTime)
     startOptions  :: String -> LocalTime -> [(String,String)] -> FilePath -> String -> FilePath -> Options 
     startOptions  fName localTime env exePath progName dataDirOfAmpersandInstallation=
       Options {genTime       = localTime
              , dirOutput     = fromMaybe "."       (lookup envdirOutput    env)
              , outputfile    = fatal 83 "No monadic options available."
              , 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       = takeDirectory exePath
              , ampersandDataDir = dataDirOfAmpersandInstallation
              , preVersion    = fromMaybe ""        (lookup "CCPreVersion"  env)
              , postVersion   = fromMaybe ""        (lookup "CCPostVersion" env)
              , 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     = progName
              , 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       = "localhost"
              , sqlLogin      = "ampersand"
              , sqlPwd        = "ampersand"
              , parserVersion = Current
              }



     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]

type OptionDef = OptDescr (Options -> IO Options)
options :: [(OptionDef, DisplayMode) ]
options = map pp
          [ (Option "v"     ["version"]
               (NoArg (\flags -> return flags{showVersion = True}))
               "show version and exit."
            , Public)
          , (Option "h?"    ["help"]
               (NoArg (\flags -> return flags{showHelp = True}))
               "get (this) usage information."
            , Public)
          , (Option ""      ["verbose"]
               (NoArg (\flags -> return flags{verboseP = True}))
               "verbose error message format."
            , Public)
          , (Option ""      ["dev"]
               (NoArg (\flags -> return flags{development = True}))
               "Report and generate extra development information"
            , Hidden)
          , (Option ""      ["validate"]
               (NoArg (\flags -> return flags{validateSQL = True}))
               "Compare results of rule evaluation in Haskell and SQL (requires command line php with MySQL support)"
            , Hidden)
          , (Option "p"     ["proto"]
               (OptArg (\nm flags -> return flags {dirPrototype = fromMaybe (dirPrototype flags) nm
                                                  ,genPrototype = True}
                       ) "DIRECTORY")
               ("generate a functional prototype (overwrites environment variable "++ envdirPrototype ++ ").")
            , Public)
          , (Option "d"     ["dbName"]
               (ReqArg (\nm flags -> return flags{dbName = if nm == "" 
                                                           then baseName flags
                                                           else nm}                          
                       ) "NAME")
               ("database name (overwrites environment variable "++ envdbName ++ ", defaults to filename)")
            , Public)
          , (Option []      ["theme"]
               (ReqArg (\t flags -> return flags{theme = case map toUpper t of 
                                                          "STUDENT"  -> StudentTheme
                                                          "STUDENTDESIGNER" -> StudentDesignerTheme
                                                          "DESIGNER" -> DesignerTheme
                                                          "PROOF"    -> ProofTheme
                                                          _          -> DefaultTheme}
                        ) "THEME")
               "differentiate between certain outputs e.g. student"
            , Public)
          , (Option "x"     ["interfaces"]
               (NoArg (\flags -> return flags{allInterfaces  = True}))
               "generate interfaces."
            , Public)
          , (Option "e"     ["export"]
               (OptArg (\mbnm flags -> return flags{export2adl = True
                                                   ,outputfile = fromMaybe "Export.adl" mbnm}) "file")
               "export as plain Ampersand script."
            , Public)
          , (Option "o"     ["outputDir"]
               (ReqArg (\nm flags -> return flags{dirOutput = nm}
                       ) "DIR")
               ("output directory (dir overwrites environment variable "++ envdirOutput ++ ").")
            , Public)
          , (Option []      ["log"]
               (ReqArg (\nm flags -> return flags{logName = nm}
                       ) "NAME")
               ("log file name (name overwrites environment variable "++ envlogName  ++ ").")
            , Hidden)
          , (Option []      ["import"]
               (ReqArg (\nm flags -> return flags{importfile = nm}
                       ) "FILE")
               "import this file as the population of the context."
            , Public)
          , (Option []      ["fileformat"]
               (ReqArg (\f flags -> return 
                             flags{fileformat = case map toUpper f of
                                                 "ADL" -> Adl1Format
                                                 "ADL1"-> Adl1Format
                                                 "POP" -> Adl1PopFormat
                                                 "POP1"-> Adl1PopFormat
                                                 _     -> fileformat flags
                                  }
                       ) "FORMAT")
               ("format of import file (format=ADL (.adl), ADL1 (.adl), POP (.pop), POP1 (.pop)).")
            , Public)
          , (Option []      ["namespace"]
               (ReqArg (\nm flags -> return flags{namespace = nm}
                       ) "NAMESPACE")
               "places the population in this namespace within the context."
            , Public)
          , (Option "f"     ["fspec"]
               (ReqArg (\w flags -> return 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}
                       ) "FORMAT")  
               ("generate a functional specification document in specified format (format="++allFspecFormats++").")
            , Public)
          , (Option []        ["refresh"]
               (OptArg (\r flags -> return 
                            flags{autoRefresh = Just (case r of
                                                       Just str | [(i,"")] <- reads str -> i
                                                       _                                -> 5
                                                     )}
                       ) "INTERVAL")
               "Experimental auto-refresh feature"
            , Hidden)
          , (Option []        ["testRule"]
               (ReqArg (\ruleName flags -> return flags{ testRule = Just ruleName }
                       ) "RULE")
               "Show contents and violations of specified rule."
            , Hidden)
          , (Option []        ["css"]
               (ReqArg (\pth flags -> return flags{ customCssFile = Just pth }) "file")
               "Custom.css file to customize the style of the prototype."
            , Public)
          , (Option []        ["noGraphics"]
               (NoArg (\flags -> return flags{genGraphics = False}))
               "save compilation time by not generating any graphics."
            , Public)
          , (Option []        ["ECA"]
               (NoArg (\flags -> return flags{genEcaDoc = True}))
               "generate documentation with ECA rules."
            , Public)
          , (Option []        ["proofs"]
               (NoArg (\flags -> return flags{proofs = True}))
               "generate derivations."
            , Public)
          , (Option []        ["XML"]
               (NoArg (\flags -> return flags{genXML = True}))
               "generate internal data structure, written in XML (for debugging)."
            , Public)
          , (Option []        ["haskell"]
               (NoArg (\flags -> return flags{haskell = True}))
               "generate internal data structure, written in Haskell (for debugging)."
            , Public)
          , (Option []        ["crowfoot"]
               (NoArg (\flags -> return flags{crowfoot = True}))
               "generate crowfoot notation in graphics."
            , Public)
          , (Option []        ["blackWhite"]
               (NoArg (\flags -> return flags{blackWhite = True}))
               "do not use colours in generated graphics"
            , Public)
          , (Option []        ["doubleEdges"]
               (NoArg (\flags -> return flags{doubleEdges = not (doubleEdges flags)}))
               "generate graphics in an alternate way. (you may experiment with this option to see the differences for yourself)"
            , Public)
          , (Option []        ["predLogic"]
               (NoArg (\flags -> return flags{showPredExpr = True}))
               "show logical expressions in the form of predicate logic."
            , Public)
          , (Option []        ["noDiagnosis"]
               (NoArg (\flags -> return flags{noDiagnosis = True}))
               "omit the diagnosis chapter from the functional specification document."
            , Public)
          , (Option []        ["diagnosis"]
               (NoArg (\flags -> return flags{diagnosisOnly = True}))
               "diagnose your Ampersand script (generates a .pdf file)."
            , Public)
          , (Option []        ["legalrefs"]
               (NoArg (\flags -> return flags{genLegalRefs = True}))
               "generate a table of legal references in Natural Language chapter."
            , Public)
          , (Option []        ["uml"]
               (NoArg (\flags -> return flags{genUML = True}))
               "Generate a UML 2.0 data model."
            , Hidden)
          , (Option []        ["FPA"]
               (NoArg (\flags -> return flags{genFPAExcel = True}))
               "Generate a Excel workbook (.xls)."
            , Hidden)
          , (Option []        ["bericht"]
               (NoArg (\flags -> return flags{genBericht = True}))
               "Generate definitions for 'berichten' (specific to INDOORS project)."
            , Hidden)
          , (Option []        ["language"]
               (ReqArg (\l flags-> return flags{language = case map toUpper l of
                                                       "NL"  -> Just Dutch
                                                       "UK"  -> Just English
                                                       "US"  -> Just English
                                                       "EN"  -> Just English
                                                       _     -> Nothing}
                       ) "LANG")
               "Pick 'NL' for Dutch or 'EN' for English, as the language to be used in your output. Without this option, output is written in the language of your context."
            , Public)
          , (Option []        ["test"]
               (NoArg (\flags -> return flags{test = True}))
               "Used for test purposes only."
            , Hidden)
          , (Option []        ["rap"]
               (NoArg (\flags -> return flags{includeRap = True}))
               "Include RAP into the generated artifacts (experimental)"
            , Hidden)
          , (Option []        ["meta"]
               (NoArg (\flags -> return flags{genMeat = True}))
               "Generate meta-population in an .adl file (experimental)"
            , Hidden)
          , (Option []        ["pango"]
               (ReqArg (\nm flags -> return flags{pangoFont = nm}
                       ) "FONTNAME")
               "specify font name for Pango in graphics."
            , Hidden)
          , (Option []   ["no-static-files"]
               (NoArg  (\flags -> return flags{genStaticFiles = False}))
               "Do not generate static files into the prototype directory"
            , Public)
          , (Option []        ["sqlHost"]
               (ReqArg (\nm flags -> return flags{sqlHost = nm}
                       ) "HOSTNAME")
               "specify database host name."
            , Hidden)
          , (Option []        ["sqlLogin"]
               (ReqArg (\nm flags -> return flags{sqlLogin = nm}
                       ) "NAME")
               "specify database login name."
            , Hidden)
          , (Option []        ["sqlPwd"]
               (ReqArg (\nm flags -> return flags{sqlPwd = nm}
                       ) "STR")
               "specify database password."
            , Hidden)
          ]
     where pp :: (OptionDef, DisplayMode) -> (OptionDef, 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"


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          = ["Executable: "++show (dirExec flags)++"\n"++
                                       preVersion flags++vs++postVersion flags++"\n" | showVersion flags]++
                                      [usageInfo' flags                              | showHelp    flags]