1 module Options
    2 
    3 ( Opts
    4 
    5 , emptyOpts
    6 , listToOpts
    7 , addToOpts
    8 , addListToOpts
    9 , plusOpts
   10 
   11 , getopt
   12 , caseopts
   13 , onoff
   14 , chose
   15 
   16 , troff
   17 
   18 , maybeIO
   19 , maybePutStr
   20 , maybePutStrLn
   21 , maybePutChar
   22 
   23 )
   24 
   25 where
   26 
   27 import Trace
   28 
   29 import Stuff (intersperse)
   30 
   31 import FiniteMap -- from syslib ghc
   32 
   33 type Opts = FiniteMap String String
   34 
   35 emptyOpts :: Opts
   36 emptyOpts = emptyFM
   37 
   38 listToOpts :: [(String, String)] -> Opts
   39 listToOpts = listToFM
   40 
   41 addListToOpts :: Opts -> [(String, String)] -> Opts
   42 addListToOpts = addListToFM
   43 
   44 addToOpts :: Opts -> String -> String -> Opts
   45 addToOpts = addToFM
   46 
   47 plusOpts :: Opts -> Opts -> Opts
   48 plusOpts = plusFM
   49 
   50 getopt :: Opts -> String -> String
   51 getopt opts name =
   52     lookupWithDefaultFM opts
   53         (error ("no argument for option: " ++ name))
   54         name
   55 
   56 caseopts :: Opts -> String -> [(String, a)] -> a
   57 caseopts opts name acts =
   58     let val = lookupWithDefaultFM opts (wrong Nothing) name
   59 
   60 
   61         quote s = "`" ++ s ++ "'"
   62         wrong v = error (unlines 
   63             [ "error: when looking up option " ++ quote name
   64             , case v of 
   65                 Nothing -> "error: value not specified"
   66                 Just val -> "error: value " ++ quote val ++ " not understood"
   67             , "error: possible values are: " 
   68                 ++ concat (intersperse ", " (map (quote . fst) acts))
   69             , "error: program stops"
   70             ] )
   71                 
   72     in  case lookup val acts of
   73         Just act -> act
   74         Nothing -> wrong (Just val)
   75 
   76 
   77 onoff :: Opts -> String -> Bool
   78 onoff opts name = caseopts opts name [("on", True),("off",False)]
   79 
   80 chose :: Opts -> String -> a -> a -> a
   81 chose opts name yeah noh = if onoff opts name then yeah else noh
   82 
   83 maybeIO opts io =
   84     case onoff opts "output" of 
   85         True -> io
   86         False -> return ()
   87 
   88 maybePutStr   opts s =  maybeIO opts (putStr   s)
   89 maybePutStrLn opts s =  maybeIO opts (putStrLn s)
   90 maybePutChar  opts c =  maybeIO opts (putChar  c)
   91 
   92 troff :: Opts -> String -> a -> a
   93 troff opts msg = chose opts "trace" (trace msg) id
   94