KiCS-0.8.5: src/Config.hs
module Config (module Config,module KicsSubdir) where
import System.FilePath
import InstallDir
import SafeCalls
import Char
import System.Environment (getEnvironment,getArgs)
import System.Directory hiding (executable)
import System.Time
import MetaProgramming.FlatCurry(readFlatCurry)
import Names
import KicsSubdir
getOptions :: IO (Options,State)
getOptions = do
(opts,state) <- readConfig
args <- getArgs
cupath <- getEnv "CURRYPATH"
let parsed = parseOptions opts args
parsedOpts <- either usage return parsed
let addFiledir = case takeDirectory (filename opts) of "" -> id; dir -> (dir:)
newOpts = parsedOpts{userlibpath= addFiledir $
userlibpath parsedOpts
++ splitSearchPath cupath}
return (newOpts,state)
parseOptions :: Options -> [String] -> Either String Options
parseOptions opts ("-or":xs) = parseOptions (opts{cm=OrBased}) xs
parseOptions opts ("-ctc":xs) = parseOptions (opts{cm=CTC}) xs
parseOptions opts ("-main":x:xs) = parseOptions (opts{mainFunc=x}) xs
parseOptions opts ("-frontend":x:xs) = parseOptions (opts{frontend=x}) xs
parseOptions opts ("-kicspath":x:xs) = parseOptions (opts{kicspath=x}) xs
parseOptions opts ("-userlibpath":x:xs) =
parseOptions (opts{userlibpath=userlibpath opts ++ splitSearchPath x}) xs
parseOptions opts ("-nouserlibpath":xs) = parseOptions (opts{userlibpath=[]}) xs
parseOptions opts ("-ghc":x:xs) = parseOptions (opts{ghc=x}) xs
parseOptions opts ("-make":xs) = parseOptions (opts{make=True}) xs
parseOptions opts ("-nomake":xs) = parseOptions (opts{make=False}) xs
parseOptions opts ("-executable":xs) = parseOptions (opts{executable=True}) xs
parseOptions opts ("-noexecutable":xs) = parseOptions (opts{executable=False}) xs
parseOptions opts ("-q":xs) = parseOptions (opts{verbosity=0}) xs
parseOptions opts ("-v":i:xs) = parseOptions (opts{verbosity=read i}) xs
parseOptions opts ("-noforce":xs) = parseOptions (opts{force=False}) xs
parseOptions opts ("-force":xs) = parseOptions (opts{force=True}) xs
parseOptions opts ("-all":"df":xs) = parseOptions (opts{pm=All DF}) xs
parseOptions opts ("-all":"bf":xs) = parseOptions (opts{pm=All BF}) xs
parseOptions opts ("-st":xs) = parseOptions (opts{pm=ST}) xs
parseOptions opts ("-i":"df":xs) = parseOptions (opts{pm=Interactive DF}) xs
parseOptions opts ("-i":"bf":xs) = parseOptions (opts{pm=Interactive BF}) xs
parseOptions opts ("-o":x:xs) = parseOptions (opts{target=x}) xs
parseOptions opts ("-d":xs) = parseOptions (opts{debug=True,doNotUseInterface=True}) xs
parseOptions opts ("--debug":xs) = parseOptions opts ("-d":xs)
parseOptions opts ("--debugger":d:xs) = parseOptions opts{debugger=Just d} xs
parseOptions opts [] = Right opts
parseOptions opts [x] = Right (opts{filename=x,mainModule=takeBaseName x})
parseOptions _ (x:_) = Left ("unrecognized option: "++x)
usage problem = do
putStrLn problem
putStrLn "Usage: kics [options] filename"
putStrLn "option | meaning"
putStrLn "-or | or based"
putStrLn "-ctc | switch to call time choice"
putStrLn "-main | name of main function "
putStrLn "-frontend | frontend binary"
putStrLn "-kicspath | path to kics compiler"
putStrLn "-userlibpath | path to curry libraries"
putStrLn "-nouserlibpath | only standard curry libraries"
putStrLn "-ghc | path to ghc"
putStrLn "-make | chase imported modules"
putStrLn "-nomake | do not chase imported modules"
putStrLn "-executable | create executable"
putStrLn "-noexecutable | do not create executable"
putStrLn "-v <n> | set verbosity level to n, e.g., -v 3"
putStrLn "-q | scarce output"
putStrLn "-force | force recompilation"
putStrLn "-noforce | do not force recompilation"
putStrLn "-all df | print all solutions depth first"
putStrLn "-all bf | print all solutions breadth first"
putStrLn "-st | print solutions as search tree"
putStrLn "-i df | interactively show solutions depth first"
putStrLn "-i bf | interactively show solutions breadth first"
putStrLn "-o | name of output file"
putStrLn "-d | turn on debug mode"
putStrLn "--debugger <n> | use debug tool <n>"
error "compilation aborted"
data Options = Opts{ cm :: ChoiceMode,
filename, mainFunc, mainModule, target,
frontend, ghc, ghcOpts,
kicspath :: String,
userlibpath, done :: [String],
verbosity :: Int,
make, executable, eval,
force, debug, doNotUseInterface :: Bool,
debugger :: Maybe String,
consUse :: ConsUse,
extCons,hasData :: Bool,
pm :: PresentationMode,
extData, extFuncs :: [String],
extInsts :: [(String,[ProvidedInstance])],
toInclude :: String} deriving Show
data ConsUse = DataDef | InstanceDef | FunctionDef deriving (Eq,Show)
cymake_call :: String
cymake_call = unpath [installDir,"bin","parsecurry"]
libpath :: Options -> [String]
libpath opts@Opts{userlibpath=up,kicspath=kp,filename=fn}
= --(case takeDirectory fn of "" -> id; dir -> ((dir++[pathSeparator]):))
up ++ [unpath [kp,"src","lib",""]]
cmdLibpath :: Options -> String
cmdLibpath opts = toPathList (libpath opts)
currentModule :: Options -> String
currentModule opts = strip (filename opts)
where
strip s = case break isPathSeparator s of
(s',[]) -> s'
(_,_:s') -> strip s'
hasExtData,hasExtInsts, hasExtFuncs :: Options -> Bool
hasExtData opts =
not (null (extData opts)) || any (elem Declaration . snd) (extInsts opts)
hasExtInsts opts =
not (null (filter (any (/=Declaration) . snd) (extInsts opts)))
hasExtFuncs opts = not (null (extFuncs opts))
defaultOpts curDir = Opts {cm=CTC,filename="", mainFunc= "main", mainModule="Main",
target = "request",
frontend=cymake_call,
kicspath=installDir,
userlibpath=[],
ghc=ghc_call,
ghcOpts=" -fglasgow-exts -fcontext-stack=50 ",
done=[],
make=True,
executable=False,
verbosity=1,
eval=True,
force=False,
debug=False,
debugger = Nothing,
doNotUseInterface=False,
consUse=FunctionDef,
extCons=False,
hasData=False,
pm=Interactive DF,
extData=[],
extInsts=[],
extFuncs=[],
toInclude=""}
kicsrc home = unpath [home,".kicsrc"]
data ChoiceMode = OrBased | CTC deriving (Eq,Read,Show)
data SearchMode = DF | BF
instance Show SearchMode where
show DF = "depth first"
show BF = "breadth first"
data PresentationMode = First SearchMode
| All SearchMode
| Interactive SearchMode
| ST
instance Show PresentationMode where
show (All x) = "all solutions "++show x
show (Interactive x) = "interactive "++show x
show (First x) = "first solution "++show x
show ST = "search tree"
data State = State {home,rts,cmdLineArgs :: String,
files :: [(Bool,String)],
time :: Bool} deriving Show
defaultState home = State {home=home,
rts=" -H400M ",
cmdLineArgs="",
files=[],
time=False}
readPMode s = readPM (words (map toLower s))
where
readPM ("interactive":ws) = Interactive (readSM ws)
readPM ("all":"solutions":ws) = All (readSM ws)
readPM ["search","tree"] = ST
readSM ["depth","first"] = DF
readSM ["breadth","first"] = BF
ghcCall :: Options -> String
ghcCall opts@Opts{filename=fn} =
callnorm (ghc opts
++makeGhc (make opts)
++" -i"++show (toPathList
(pathWithSubdirs
(unpath [installDir,"src"]:
unpath [installDir,"src","oracle"]:
libpath opts)))++" "
++kicsSubdirPathToFile
++linkOpts
++ghcOpts opts
++verboseGhc (verbosity opts >= 2)
++ghcTarget opts
++" "++show fn)
where
linkOpts | debug opts = linkLib++" -L"++installDir++"/src/lib/ "
| otherwise = ""
linkLib | eval opts = " -ldyncoracle "
| otherwise = " -lcoracle "
verboseGhc True = ""
verboseGhc False = " -v0 "
ghcTarget Opts{target=""} = ""
ghcTarget Opts{target=t} = " -o "++show t
makeGhc True = " --make "
makeGhc False = ""
kicsSubdirPathToFile = case takeDirectory fn of
"" -> ""
path -> " -i"++show (addKicsSubdir path)++" "
stricthsCall opts =
callnorm (installDir++"/bin/stricths --hs "
++ ("-s"++mainModule opts++" ")
++ (if make opts then "-m " else "")
++ (if force opts then "-f " else "")
++ (if verbosity opts < 2 then "-q " else "")
++ filename opts)
mkStrictCall opts =
callnorm (installDir++"/bin/mkstrict "
++ (if verbosity opts < 2 then "--quiet " else "")
++ filename opts++" "
{-++ (if make opts then "-m " else "")
++ (if force opts then "-f " else "")
++ filename opts-})
cyCall opts = callnorm $ frontend opts++" -e " ++
unwords (map (("-i"++) . show) (libpath opts))
callnorm s = unwords (words s) ++ " "
cymake opts = do
safeSystem (verbosity opts >= 3)
(cyCall opts ++ show (filename opts)
++ if verbosity opts >= 3 then "" else " 1>/dev/null ")
prophecy opts = safeSystem (verbosity opts >= 4) $
installDir++"/bin/prophecy "
++ (if make opts then " -m " else "")
++ (if force opts then " -f " else "")
++ (if verbosity opts < 2 then " -q " else "")
++ show (dropExtension $ filename opts)
++ if verbosity opts >= 4 then "" else " 1>/dev/null "
readConfig = do
home <- getEnv "HOME"
curDir <- getCurrentDirectory
catch (readFile (kicsrc home) >>= getConfigs home)
(\_->do
let defaultsO = defaultOpts curDir
defaultsS = defaultState home
writeConfig defaultsO defaultsS
putStrLn ("The file "++kicsrc home++" has been written.")
putStrLn ("You might need to edit it.")
error "Please verify .kicsrc")
writeConfig opts state = do
home <- getEnv "HOME"
writeFile (kicsrc home)
(wLibPath++wPM++wEval++wTime ++wRTS)
where
wLibPath = setting 1 (\o-> toPathList $ case userlibpath o of
".":path -> path
path -> path)
wPM = setting 2 (show . pm)
wEval = setting 3 (show . eval)
wTime = inState 4 (show . time)
wRTS = inState 5 rts
setting n f = entry n (f opts)
inState n f = entry n (f state)
entry n s = (configs!!(n-1)) ++ "="++s++"\n\n"
mkTags = [kicspath,
(toPathList . userlibpath),
(show . pm)]
getConfigs home cfgs | cfgs == cfgs = do
punkt <- getCurrentDirectory
let readOpts = selOpts (entries cfgs)
defaultsO = defaultOpts punkt
opts = defaultsO
{cm = OrBased,
kicspath = installDir,
userlibpath = let up = readSetting userlibpath splitSearchPath 1
in (punkt ++ [pathSeparator]) : up,
pm = readSetting pm readPMode 2,
ghc = ghc_call,
frontend = cymake_call,
eval = readSetting eval read 3,
force = False}
readSetting f r n = maybe (f defaultsO) r (readOpts!!(n-1))
defaultsS = defaultState home
state = defaultsS
{time = readSSet time read 4,
rts = readSSet rts id 5}
readSSet f r n = maybe (f defaultsS) r (readOpts!!(n-1))
return (opts,state)
entries s = equations (lines s)
where
equations [] = []
equations (x:xs) = case break (=='=') x of
(l,_:r) -> (l,r):equations xs
_ -> equations xs
selOpts cfgs = map (selTag cfgs) configs
configs =
["Libraries",
"PresentationMode",
"Eval",
"Time",
"RunTimeSettings"]
selTag [] _ = Nothing
selTag ((t,v):xs) s =
if map toLower t==map toLower s
then Just v
else selTag xs s
paths s = case break (==':') s of
("","") -> []
(w,"") -> [w]
("",_:ws) -> paths ws
(w,_:ws) -> w : paths ws
getModTime fn = safeIO (do
ex<-doesModuleExist fn
if ex then getModuleModTime fn else return (TOD 0 0))
safeReadFlat opts s = do
fs <- safeIO (findFileInPath s (libpath opts))
fn <- warning s (cmdLibpath opts) fs
safeIOSeq (readFlatCurry fn)
warning fn path [] = fail ("module "++fn++" not found in path "++path)
warning _ _ (f:fs) = do
mapM_ (safeIO . putStrLn)
(map (\f' -> "further file found (but ignored) "++f'
++" taking "++f++" instead") fs)
return f
----------------------------------------------
-- external definitions
----------------------------------------------
-- what is provided by external files
data ProvidedInstance =
Declaration | Show | Read | BaseCurry | Curry deriving (Eq,Ord,Read,Show)
data Provided = ForType String (Maybe [ProvidedInstance])
| ForFunction String
| SomeFunctions
deriving (Eq,Read,Show)
-- external specifications have to look like this:
-- fortype <typename> [definition|nodef] instances <instname>*
-- extfunc <funcname>
put :: Int -> Options -> String -> Safe IO ()
put i Opts{verbosity=j} s | i>j = return ()
| i<=j = safeIO (putStrLn s)
readExternalSpec :: Options -> String -> Safe IO Options
readExternalSpec opts p = do
specs <- safeIO $ findFileInPath
(externalSpecName (p `withoutSubdir` currySubdir))
(libpath opts)
if null specs
then return opts
else do
spec <- warning "" "" specs >>= safeIO . readModule
put 5 opts "reading external specification"
let [(specs,stringToInclude)] = reads spec
newOpts = foldr insertP opts{toInclude=stringToInclude} specs
safeIO (seq newOpts (return ()))
put 5 opts "external specification read"
return newOpts
where
insertP SomeFunctions opts = opts{extFuncs = "" : extFuncs opts}
insertP (ForFunction f) opts = opts{extFuncs = f : extFuncs opts}
insertP (ForType t Nothing) opts = opts{extData = t : extData opts}
insertP (ForType t (Just is)) opts = opts{extInsts = (t,is) : extInsts opts}
baseName f = case reverse f of
'y':'r':'r':'u':'c':'.':f' -> reverse f'
'y':'r':'r':'u':'c':'l':'.':f' -> reverse f'
_ -> f
getEnv :: String -> IO String
getEnv s = getEnvironment >>= maybe (return "") return . lookup s