----------------------------------------------------------------------
-- |
-- Module      : Option
-- Maintainer  : AR
-- Stability   : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/11/14 16:03:41 $ 
-- > CVS $Author: aarne $
-- > CVS $Revision: 1.34 $
--
-- Options and flags used in GF shell commands and files.
--
-- The types 'Option' and 'Options' should be kept abstract, but:
--
--   - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource"
--
--   - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
-----------------------------------------------------------------------------

module GF.Infra.Option where

import Data.List (partition)
import Data.Char (isDigit)

-- * all kinds of options, to be kept abstract

newtype Option = Opt (String,[String]) deriving (Eq,Show,Read)
newtype Options = Opts [Option] deriving (Eq,Show,Read)

noOptions :: Options
noOptions = Opts []

-- | simple option -o
iOpt :: String -> Option
iOpt o = Opt (o,[])   

-- | option with argument -o=a
aOpt :: String -> String -> Option
aOpt o a = Opt (o,[a])  

iOpts :: [Option] -> Options
iOpts = Opts

-- | value of option argument
oArg :: String -> String
oArg s = s 

oElem :: Option -> Options -> Bool
oElem o (Opts os) = elem o os

eqOpt :: String -> Option -> Bool
eqOpt s (Opt (o, [])) = s == o
eqOpt s _ = False

type OptFun = String -> Option
type OptFunId = String

getOptVal :: Options -> OptFun -> Maybe String
getOptVal (Opts os) fopt = 
  case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
    a:_ -> Just a
    _ -> Nothing

isSetFlag :: Options -> OptFun -> Bool
isSetFlag (Opts os) fopt = 
  case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
    a:_ -> True
    _ -> False

getOptInt :: Options -> OptFun -> Maybe Int
getOptInt opts f = do
  s <- getOptVal opts f
  if (not (null s) && all isDigit s) then return (read s) else Nothing 

optIntOrAll :: Options -> OptFun -> [a] -> [a]
optIntOrAll opts f = case getOptInt opts f of
  Just i -> take i
  _ -> id

optIntOrN :: Options -> OptFun -> Int -> Int
optIntOrN opts f n = case getOptInt opts f of
  Just i -> i
  _ -> n

optIntOrOne :: Options -> OptFun -> Int
optIntOrOne opts f = optIntOrN opts f 1

changeOptVal :: Options -> OptFun -> String -> Options
changeOptVal os f x = 
  addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f

addOption :: Option -> Options -> Options
addOption o (Opts os) = iOpts (o:os)

addOptions :: Options -> Options -> Options
addOptions (Opts os) os0 = foldr addOption os0 os

concatOptions :: [Options] -> Options
concatOptions = foldr addOptions noOptions

removeOption :: Option -> Options -> Options
removeOption o (Opts os) = iOpts (filter (/=o) os)

removeOptions :: Options -> Options -> Options
removeOptions (Opts os) os0 = foldr removeOption os0 os

options :: [Option] -> Options
options = foldr addOption noOptions

unionOptions :: Options -> Options -> Options
unionOptions (Opts os) (Opts os') = Opts (os ++ os')

-- * parsing options, with prefix pre (e.g. \"-\")

getOptions :: String -> [String] -> (Options, [String])
getOptions pre inp = let
  (os,rest) = span (isOption pre) inp -- options before args
  in
  (Opts (map (pOption pre) os), rest)

pOption :: String -> String -> Option
pOption pre s = case span (/= '=') (drop (length pre) s) of
  (f,_:a) -> aOpt f a
  (o,[])  -> iOpt o

isOption :: String -> String -> Bool
isOption pre = (==pre) . take (length pre)

-- * printing options, without prefix

prOpt :: Option -> String
prOpt (Opt (s,[])) = s
prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs

prOpts :: Options -> String
prOpts (Opts os) = unwords $ map prOpt os

-- * a suggestion for option names

-- ** parsing

strictParse, forgiveParse, ignoreParse, literalParse, rawParse, firstParse :: Option
-- | parse as term instead of string
dontParse :: Option

strictParse  = iOpt "strict"
forgiveParse = iOpt "n"
ignoreParse  = iOpt "ign"
literalParse = iOpt "lit"
rawParse     = iOpt "raw"
firstParse   = iOpt "1"
dontParse    = iOpt "read" 

newParser, newerParser, newCParser, newMParser :: Option
newParser   = iOpt "new"
newerParser = iOpt "newer"
newCParser  = iOpt "cfg"
newMParser  = iOpt "mcfg"
newFParser  = iOpt "fcfg"

{-
useParserMCFG, useParserMCFGviaCFG, useParserCFG, useParserCF :: Option

useParserMCFG = iOpt "mcfg"
useParserMCFGviaCFG = iOpt "mcfg-via-cfg"
useParserCFG = iOpt "cfg"
useParserCF = iOpt "cf"
-}

-- ** grammar formats

showAbstr, showXML, showOld, showLatex, showFullForm,
  showEBNF, showCF, showWords, showOpts,
  isCompiled, isHaskell, noCompOpers, retainOpers,
  noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
defaultGrOpts :: [Option]

showAbstr   = iOpt "abs"
showXML     = iOpt "xml"
showOld     = iOpt "old"
showLatex   = iOpt "latex"
showFullForm = iOpt "fullform" 
showEBNF    = iOpt "ebnf"
showCF      = iOpt "cf"
showWords   = iOpt "ws"
showOpts    = iOpt "opts"
-- showOptim   = iOpt "opt"
isCompiled  = iOpt "gfc"
isHaskell   = iOpt "gfhs"
noCompOpers = iOpt "nocomp"
retainOpers = iOpt "retain"
defaultGrOpts = []
noCF        = iOpt "nocf"
checkCirc   = iOpt "nocirc"
noCheckCirc = iOpt "nocheckcirc"
lexerByNeed = iOpt "cflexer"
useUTF8id   = iOpt "utf8id"
elimSubs    = iOpt "subs"

-- ** linearization

allLin, firstLin, distinctLin, dontLin,
  showRecord, showStruct, xmlLin, latexLin,
  tableLin, useUTF8, showLang, withMetas :: Option
defaultLinOpts :: [Option]

allLin      = iOpt "all"
firstLin    = iOpt "one"
distinctLin = iOpt "nub"
dontLin     = iOpt "show"
showRecord  = iOpt "record"
showStruct  = iOpt "structured"
xmlLin      = showXML
latexLin    = showLatex
tableLin    = iOpt "table"
defaultLinOpts = [firstLin]
useUTF8     = iOpt "utf8"
showLang    = iOpt "lang"
showDefs    = iOpt "defs"
withMetas   = iOpt "metas"

-- ** other

beVerbose, showInfo, beSilent, emitCode, getHelp,
  doMake, doBatch, notEmitCode, makeMulti, beShort,
  wholeGrammar, makeFudget, byLines, byWords, analMorpho,
  doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
  stripQualif, nostripQualif, showAll, fromSource :: Option

beVerbose    = iOpt "v"
invertGrep   = iOpt "v" --- same letter in unix
showInfo     = iOpt "i"
beSilent     = iOpt "s"
emitCode     = iOpt "o"
getHelp      = iOpt "help"
doMake       = iOpt "make"
doBatch      = iOpt "batch"
notEmitCode  = iOpt "noemit"
makeMulti    = iOpt "multi"
beShort      = iOpt "short"
wholeGrammar = iOpt "w"
makeFudget   = iOpt "f"
byLines      = iOpt "lines"
byWords      = iOpt "words"
analMorpho   = iOpt "morpho"
doTrace      = iOpt "tr"
noCPU        = iOpt "nocpu"
doCompute    = iOpt "c"
optimizeCanon = iOpt "opt"
optimizeValues = iOpt "val"
stripQualif   = iOpt "strip"
nostripQualif = iOpt "nostrip"
showAll      = iOpt "all"
showFields   = iOpt "fields"
showMulti    = iOpt "multi"
fromSource   = iOpt "src"
makeConcrete = iOpt "examples"
fromExamples = iOpt "ex"
openEditor   = iOpt "edit"
getTrees     = iOpt "trees"

-- ** mainly for stand-alone

useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option

useUnicode    = iOpt "unicode"
optCompute    = iOpt "compute"
optCheck      = iOpt "typecheck"
optParaphrase = iOpt "paraphrase"
forJava       = iOpt "java"

-- ** for edit session

allLangs, absView :: Option

allLangs  = iOpt "All"
absView   = iOpt "Abs"

-- ** options that take arguments

useTokenizer, useUntokenizer, useParser, withFun, 
  useLanguage, useResource, speechLanguage, useFont,
  grammarFormat, grammarPrinter, filterString, termCommand,
  transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay,
  noDepTypes, extractGr, pathList, uniCoding :: String -> Option
-- | used on command line
firstCat :: String -> Option
-- | used in grammar, to avoid clash w res word
gStartCat :: String -> Option

useTokenizer   = aOpt "lexer"
useUntokenizer = aOpt "unlexer"
useParser      = aOpt "parser"
-- useStrategy    = aOpt "strategy" -- parsing strategy
withFun        = aOpt "fun"
firstCat       = aOpt "cat"      
gStartCat      = aOpt "startcat" 
useLanguage    = aOpt "lang"
useResource    = aOpt "res"
speechLanguage = aOpt "language"
useFont        = aOpt "font"
grammarFormat  = aOpt "format"
grammarPrinter = aOpt "printer"
filterString   = aOpt "filter"
termCommand    = aOpt "transform"
transferFun    = aOpt "transfer"
forForms       = aOpt "forms"
menuDisplay    = aOpt "menu"
sizeDisplay    = aOpt "size"
typeDisplay    = aOpt "types"
noDepTypes     = aOpt "nodeptypes"
extractGr      = aOpt "extract"
pathList       = aOpt "path"
uniCoding      = aOpt "coding"
probFile       = aOpt "probs"
noparseFile    = aOpt "noparse"
usePreprocessor = aOpt "preproc"

-- peb 16/3-05:
gfcConversion :: String -> Option
gfcConversion  = aOpt "conversion"

useName, useAbsName, useCncName, useResName, 
  useFile, useOptimizer :: String -> Option

useName        = aOpt "name"
useAbsName     = aOpt "abs"
useCncName     = aOpt "cnc"
useResName     = aOpt "res"
useFile        = aOpt "file"
useOptimizer   = aOpt "optimize"

markLin :: String -> Option
markOptXML, markOptJava, markOptStruct, markOptFocus :: String

markLin        = aOpt "mark"
markOptXML     = oArg "xml"
markOptJava    = oArg "java"
markOptStruct  = oArg "struct"
markOptFocus   = oArg "focus"


-- ** refinement order

nextRefine :: String -> Option
firstRefine, lastRefine :: String

nextRefine  = aOpt "nextrefine"
firstRefine = oArg "first"
lastRefine  = oArg "last"

-- ** Boolean flags

flagYes, flagNo :: String

flagYes = oArg "yes"
flagNo  = oArg "no"

-- ** integer flags

flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees :: String -> Option

flagDepth  = aOpt "depth"
flagAlts   = aOpt "alts"
flagLength = aOpt "length"
flagNumber = aOpt "number"
flagRawtrees = aOpt "rawtrees"

caseYesNo :: Options -> OptFun -> Maybe Bool
caseYesNo opts f = do
  v <- getOptVal opts f
  if v == flagYes   then return True
     else if v == flagNo then return False
     else Nothing