Config.hs

module Curry.Compiler.Config (
  module Curry.Compiler.Config,
  module Curry.Compiler.KicsSubdir) where

import System.FilePath
import System.Process
import System.Time (ClockTime)
import Char
import System.Environment (getEnvironment,getArgs)
import System.Directory hiding (executable)
import System.Time
import GHC.Paths
import Data.List
import Monad

import Curry.Compiler.SafeCalls
import Curry.FlatCurry.Type (readFlat)
import Curry.Compiler.Names
import Curry.Compiler.KicsSubdir
import Curry.Files.CymakePath
import Curry.Files.KiCSPath

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 
                                             ++ splitPath 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 ("-userlibpath":x:xs) = 
  parseOptions (opts{userlibpath=userlibpath opts ++ splitSearchPath x}) xs
parseOptions opts ("-nouserlibpath":xs) = parseOptions (opts{userlibpath=[]}) 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=Just 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 "-userlibpath   | path to curry libraries"
  putStrLn "-nouserlibpath | only standard curry libraries"
  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, 
                     frontend, ghcOpts, stdLibDir
                       :: String,
                     target :: Maybe 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)

addFileDirToPath :: String -> [String] -> [String]
addFileDirToPath fn = case takeDirectory fn of "" -> id; dir -> (dir:)

libpath :: Options -> [String]
libpath opts@Opts{userlibpath=up,filename=fn,stdLibDir=std} = 
  addFileDirToPath fn $ up ++ [std]


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 = Opts {cm=CTC,filename="", mainFunc= "main", mainModule="Main",
      target = Nothing,
      frontend="cymake",
      stdLibDir = "",
      userlibpath=[],
      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
             ++makeGhc (make opts)
             ++" -i"++show (toPathList 
                             (pathWithSubdirs $ 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=Nothing} = ""
    ghcTarget Opts{target=Just t} = " -o "++show t

    makeGhc True = " --make "
    makeGhc False = ""

    kicsSubdirPathToFile = case takeDirectory fn of
                             "" -> ""
                             path -> " -i"++show (addKicsSubdir path)++" "


stricthsCall opts = 
  callnorm ("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 ("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) $
   		      "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"
   catch (readFile (kicsrc home) >>= getConfigs home) 
         (\_ -> getConfigs home "")

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 = [(toPathList . userlibpath),(show . pm)]

getConfigs home cfgs | cfgs == cfgs = do
  punkt <- getCurrentDirectory
  std   <- getKiCSLibDir
  cymake_call <- getCymake
  let readOpts = selOpts (entries cfgs)

      opts = defaultOpts
            {cm          = OrBased,
             userlibpath = let up = readSetting userlibpath splitPath 1
                             in punkt : up,
             stdLibDir   = std,
             pm          = readSetting pm readPMode 2,
             frontend    = cymake_call,
             eval        = readSetting eval read 3,
             force       = False}
      readSetting f r n = maybe (f defaultOpts) 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
    safeIO $ print s
    safeIO $ print $ libpath opts
    fs <- safeIO (findFileInPath s (libpath opts))
    safeIO $ print 12
    fn <- warning s (cmdLibpath opts) fs
    mprog <- safeIO $ readFlat fn
    maybe (fail $ "file not found: "++fn) return mprog
   
warning fn path [] = fail ("file "++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)

getExternalSpecFileName :: Options -> String -> Safe IO (Maybe FilePath)
getExternalSpecFileName opts p = do
    specs <- safeIO $ findFileInPath 
                        (externalSpecName (p `withoutSubdir` currySubdir)) 
                        (libpath opts)
    if null specs 
      then return Nothing 
      else warning "" "" specs >>= return . Just


readExternalSpec :: Options -> String -> Safe IO Options
readExternalSpec opts p = do
    mspecFile <- getExternalSpecFileName opts p
    case mspecFile of
      Nothing -> return opts 
      Just specFile -> do
        spec <- safeIO (readModule specFile)
        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}
    
getExternalSpecModTime :: Options -> String -> Safe IO ClockTime
getExternalSpecModTime opts p = do
  mspecFile <- getExternalSpecFileName opts p
  case mspecFile of
   Nothing       -> return (TOD 0 0)
   Just specFile -> safeIO $ getModuleModTime specFile


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