{-# OPTIONS -cpp #-}
{-
 *  SAD / Alice / Explore -- gateway module to cope with external provers
 *  Copyright (C) 2001-2004  SAD Development Team (see ../README)
 *
 *  This program is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU General Public License as published by
 *  the Free Software Foundation; either version 2 of the License, or
 *  (at your option) any later version.
 *
 *  This program is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 *  GNU General Public License for more details.
 *
 *  You should have received a copy of the GNU General Public License along
 *  with this program; if not, write to the Free Software Foundation, Inc.,
 *  59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
 -}

module Explore where

import Control.Monad (unless)
import Data.IORef
import System.Exit
import System.IO
import System.Time

#if __GLASGOW_HASKELL__ < 600
import Posix
#else
import System.Posix
#endif

import Text

-- Prover interface

data RVars  = RVars { prvp :: String,  prva :: [String],  prvn :: String,
                      tlim :: String,  totl :: IORef TimeDiff }

explore (RVars pt ag pn tl tt) cnt f =
  do  (rh, wh) <- getProver pt ag; putFL wh cnt
      start <- getClockTime; hPutChar wh '?'
      putF wh f; hPutStrLn wh tl; hFlush wh

      retrans rh pn; r <- eatLine rh; res <- case r of
        '+':_ -> return True;   '!':_ -> return False
        '-':_ -> return False;  '_':_ -> return False
        _ -> dieLn $ "[Explore] ill-formed response: " ++ r
      unless (null pt) (hClose rh >> hClose wh)

      finish <- getClockTime; total <- readIORef tt
      let ttps = tdPicosec total ; xtotal = total { tdPicosec = 0 }
          ntotal = diffClockTimes (addToClockTime xtotal finish) start
      writeIORef tt $ ntotal { tdPicosec = tdPicosec ntotal + ttps }
      return res


putFL wh (b:bl) = do  putFL wh bl; let m = blMark b
                      let n = if null m then "#" else m
                      hPutStrLn wh n; putF wh (formulate b)
putFL _ _       = return ()

putF wh f       = hPutStrLn wh $ outT [] f ""

retrans rh p    = do  r <- eatLine rh; case r of
                        '/':_ ->  return () ; [] ->  retrans rh p
                        _     ->  putStr ("[" ++ p ++ "] ")
                                    >> putStrLn r >> retrans rh p

eatLine rh      = catch (hGetLine rh)
                    $ \ e ->  dieLn $ "[Explore] no response: "
                                        ++ ioeGetErrorString e


getProver "" _  = return (stdin, stdout)

getProver pt ag = do  (rfd1, wfd1) <- createPipe
                      (rfd2, wfd2) <- createPipe
#if __GLASGOW_HASKELL__ < 602
                      pid <- forkProcess
                      case pid of
                        Nothing -> child  rfd1 wfd1 rfd2 wfd2
                        Just _  -> parent rfd1 wfd1 rfd2 wfd2
#else
                      forkProcess (child rfd1 wfd1 rfd2 wfd2)
                      parent rfd1 wfd1 rfd2 wfd2
#endif
  where
    parent rfd1 wfd1 rfd2 wfd2 =
        do  rh <- fdToHandle rfd2; closeFd wfd2
            wh <- fdToHandle wfd1; closeFd rfd1
            return (rh, wh)

    child rfd1 wfd1 rfd2 wfd2 =
        do  dupTo rfd1 stdInput;  closeFd wfd1
            dupTo wfd2 stdOutput; closeFd rfd2
            catch (executeFile pt True ag Nothing)
              $ \ e -> dieEr $ "[Main] can't run " ++ pt ++
                                  ": " ++ ioeGetErrorString e
            fail "you should never see this message"


-- Service stuff

die   s = do  putStr s; exitWith (ExitFailure 1)
dieLn s = do  putStrLn s; exitWith (ExitFailure 1)
dieEr s = do  hPutStrLn stderr s; exitWith (ExitFailure 1)

outT vs (All v f) = outbin (v:vs) '@' v f
outT vs (Exi v f) = outbin (v:vs) '$' v f
outT vs (Iff f g) = outbin vs '~' f g
outT vs (Imp f g) = outbin vs '>' f g
outT vs (Or  f g) = outbin vs '|' f g
outT vs (And f g) = outbin vs '&' f g
outT vs (Not f)   = showChar '!' . outT vs f
outT vs (Ann a f) = showChar ':' . shows a . showChar ' ' . outT vs f
outT vs u@(Var v)
  | u `elem` vs   = showString v
  | True          = showString v . showString "()"

outT _  (Trm "#T#" [])  = showChar '+'
outT _  (Trm "#F#" [])  = showChar '-'
outT vs (Trm "=" [l,r]) = outbin vs '=' l r
outT vs (Trm t ts)      = showString t . showChar '(' .
        foldr (\ l r -> outT vs l . showChar ' ' . r) (showChar ')') ts

outbin vs c f g = showChar c . outT vs f . showChar ' ' . outT vs g

#if __GLASGOW_HASKELL__ < 600
closeFd   = fdClose
#endif

