{-# LANGUAGE CPP, DoAndIfThenElse #-}
{- |
Module      :  ./PGIP/Server.hs
Description :  run hets as server
Copyright   :  (c) Christian Maeder, DFKI GmbH 2010
License     :  GPLv2 or higher, see LICENSE.txt
Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  non-portable (via imports)

-}

module PGIP.Server (hetsServer) where

import PGIP.Output.Formatting
import PGIP.Output.Mime
import PGIP.Output.Proof
import PGIP.Output.Translations
import qualified PGIP.Output.Provers as OProvers

import PGIP.GraphQL

import PGIP.ReasoningParameters as ReasoningParameters
import PGIP.Query as Query
import PGIP.RequestCache
import PGIP.Server.WebAssets
import PGIP.Shared
import qualified PGIP.Server.Examples as Examples

import Driver.Options
import Driver.ReadFn
import Driver.Version

import Network.Wai.Handler.Warp
import Network.HTTP.Types

import Codec.Binary.UTF8.String
import Control.Monad.Trans (lift, liftIO)
#ifdef WARP1
import Control.Monad.Trans.Resource
import Data.Conduit.Lazy (lazyConsume)
#endif
import qualified Data.Text as T

import Network.Wai
import Network.Wai.Parse as W

import qualified Data.ByteString.Lazy.Char8 as BS
import qualified Data.ByteString.Char8 as B8
import qualified Control.Monad.Fail as Fail

import Static.AnalysisLibrary
import Static.ApplyChanges
import Static.ComputeTheory
import Static.DevGraph
import Static.DGTranslation
import Static.DgUtils
import Static.DotGraph
import Static.FromXml
import Static.GTheory
import Static.History (changeDGH)
import Static.PrintDevGraph
import qualified Static.ToJson as ToJson
import Static.ToXml as ToXml

import qualified Persistence.DevGraph
import qualified Persistence.Reasoning

import Logic.LGToXml

import Syntax.ToXml
import Syntax.Print_AS_Structured

import Interfaces.Command
import Interfaces.CmdAction
import Interfaces.GenericATPState

import Comorphisms.LogicGraph

import Logic.Prover
import Logic.Grothendieck
import Logic.Comorphism
import Logic.Logic

import Proofs.AbstractState as AbsState
import Proofs.ConsistencyCheck

import Text.XML.Light
import Text.XML.Light.Cursor hiding (lefts, rights)

import Common.AutoProofUtils
import Common.Doc
import Common.DocUtils (pretty, showGlobalDoc, showDoc)
import Common.ExtSign (ExtSign (..))
import Common.GtkGoal
import Common.IO
import Common.Json (Json (..), ppJson)
import Common.JSONOrXML
import Common.LibName
import Common.PrintLaTeX
import Common.Result
import Common.ResultT
import Common.ToXml
import Common.Utils
import Common.XUpdate
import Common.GlobalAnnotations

import Control.Monad
import Control.Exception (catch, throwTo)
import Control.Exception.Base (SomeException)
import Control.Concurrent (myThreadId, ThreadId)

import qualified Data.Aeson as Aeson
import Data.Either
import qualified Data.IntMap as IntMap
import qualified Data.Map as Map
import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
import Data.Char
import Data.IORef
import Data.Function
import Data.List
import Data.Maybe
import Data.Ord
import Data.Graph.Inductive.Graph (lab)
import Data.Time.Clock
import Data.Time.LocalTime

import System.Random
import System.Directory
import System.Exit
import System.FilePath
import System.IO
import System.Posix.Process (getProcessID)
import System.Posix.Signals
import System.Posix.Temp

data UsedAPI = OldWebAPI | RESTfulAPI deriving (Int -> UsedAPI -> ShowS
[UsedAPI] -> ShowS
UsedAPI -> String
(Int -> UsedAPI -> ShowS)
-> (UsedAPI -> String) -> ([UsedAPI] -> ShowS) -> Show UsedAPI
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UsedAPI] -> ShowS
$cshowList :: [UsedAPI] -> ShowS
show :: UsedAPI -> String
$cshow :: UsedAPI -> String
showsPrec :: Int -> UsedAPI -> ShowS
$cshowsPrec :: Int -> UsedAPI -> ShowS
Show, UsedAPI -> UsedAPI -> Bool
(UsedAPI -> UsedAPI -> Bool)
-> (UsedAPI -> UsedAPI -> Bool) -> Eq UsedAPI
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UsedAPI -> UsedAPI -> Bool
$c/= :: UsedAPI -> UsedAPI -> Bool
== :: UsedAPI -> UsedAPI -> Bool
$c== :: UsedAPI -> UsedAPI -> Bool
Eq, Eq UsedAPI
Eq UsedAPI =>
(UsedAPI -> UsedAPI -> Ordering)
-> (UsedAPI -> UsedAPI -> Bool)
-> (UsedAPI -> UsedAPI -> Bool)
-> (UsedAPI -> UsedAPI -> Bool)
-> (UsedAPI -> UsedAPI -> Bool)
-> (UsedAPI -> UsedAPI -> UsedAPI)
-> (UsedAPI -> UsedAPI -> UsedAPI)
-> Ord UsedAPI
UsedAPI -> UsedAPI -> Bool
UsedAPI -> UsedAPI -> Ordering
UsedAPI -> UsedAPI -> UsedAPI
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: UsedAPI -> UsedAPI -> UsedAPI
$cmin :: UsedAPI -> UsedAPI -> UsedAPI
max :: UsedAPI -> UsedAPI -> UsedAPI
$cmax :: UsedAPI -> UsedAPI -> UsedAPI
>= :: UsedAPI -> UsedAPI -> Bool
$c>= :: UsedAPI -> UsedAPI -> Bool
> :: UsedAPI -> UsedAPI -> Bool
$c> :: UsedAPI -> UsedAPI -> Bool
<= :: UsedAPI -> UsedAPI -> Bool
$c<= :: UsedAPI -> UsedAPI -> Bool
< :: UsedAPI -> UsedAPI -> Bool
$c< :: UsedAPI -> UsedAPI -> Bool
compare :: UsedAPI -> UsedAPI -> Ordering
$ccompare :: UsedAPI -> UsedAPI -> Ordering
$cp1Ord :: Eq UsedAPI
Ord)

randomKey :: IO Int
randomKey :: IO Int
randomKey = (Int, Int) -> IO Int
forall a. Random a => (a, a) -> IO a
randomRIO (100000000, 999999999)

sessGraph :: DGQuery -> Session -> Maybe (LibName, DGraph)
sessGraph :: DGQuery -> Session -> Maybe (LibName, DGraph)
sessGraph dgQ :: DGQuery
dgQ s :: Session
s =
  let le :: LibEnv
le = Session -> LibEnv
sessLibEnv Session
s
      ln :: LibName
ln = Session -> LibName
sessLibName Session
s
  in case DGQuery
dgQ of
  DGQuery _ (Just path :: String
path) ->
      ((LibName, DGraph) -> Bool)
-> [(LibName, DGraph)] -> Maybe (LibName, DGraph)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ (n :: LibName
n, _) -> LibName -> String
libToFileName LibName
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
path)
        ([(LibName, DGraph)] -> Maybe (LibName, DGraph))
-> [(LibName, DGraph)] -> Maybe (LibName, DGraph)
forall a b. (a -> b) -> a -> b
$ LibEnv -> [(LibName, DGraph)]
forall k a. Map k a -> [(k, a)]
Map.toList LibEnv
le
  _ -> (DGraph -> (LibName, DGraph))
-> Maybe DGraph -> Maybe (LibName, DGraph)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ dg :: DGraph
dg -> (LibName
ln, DGraph
dg)) (Maybe DGraph -> Maybe (LibName, DGraph))
-> Maybe DGraph -> Maybe (LibName, DGraph)
forall a b. (a -> b) -> a -> b
$ LibName -> LibEnv -> Maybe DGraph
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup LibName
ln LibEnv
le

getVal :: [QueryPair] -> String -> Maybe String
getVal :: [QueryPair] -> String -> Maybe String
getVal qs :: [QueryPair]
qs = Maybe String -> Maybe (Maybe String) -> Maybe String
forall a. a -> Maybe a -> a
fromMaybe Maybe String
forall a. Maybe a
Nothing (Maybe (Maybe String) -> Maybe String)
-> (String -> Maybe (Maybe String)) -> String -> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [QueryPair] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [QueryPair]
qs)

getIP4 :: String -> [String]
getIP4 :: String -> [String]
getIP4 = Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn '.' (String -> [String]) -> ShowS -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (\ c :: Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '.')

matchIP4 :: [String] -> [String] -> Bool
matchIP4 :: [String] -> [String] -> Bool
matchIP4 ip :: [String]
ip mask :: [String]
mask = case [String]
mask of
  [] -> Bool
True
  ft :: String
ft : rt :: [String]
rt -> case [String]
ip of
    [] -> Bool
False -- mask too long or IP too short
    d :: String
d : s :: [String]
s -> (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ft Bool -> Bool -> Bool
|| String
ft String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
d) Bool -> Bool -> Bool
&& [String] -> [String] -> Bool
matchIP4 [String]
rt [String]
s

matchWhite :: [String] -> [[String]] -> Bool
matchWhite :: [String] -> [[String]] -> Bool
matchWhite ip :: [String]
ip l :: [[String]]
l = [[String]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[String]]
l Bool -> Bool -> Bool
|| ([String] -> Bool) -> [[String]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([String] -> [String] -> Bool
matchIP4 [String]
ip) [[String]]
l

#ifdef WARP3
type WebResponse = (Response -> IO ResponseReceived) -> IO ResponseReceived
catchException :: SomeException -> Response
catchException :: SomeException -> Response
catchException e :: SomeException
e =
   String -> Status -> String -> Response
mkResponse String
textC
              Status
internalServerError500
              ("*** Error:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e)
#else
type WebResponse = (Response -> RsrcIO Response) -> RsrcIO Response
#endif

deletePidFileAndExit :: HetcatsOpts -> ThreadId -> ExitCode -> IO ()
deletePidFileAndExit :: HetcatsOpts -> ThreadId -> ExitCode -> IO ()
deletePidFileAndExit opts :: HetcatsOpts
opts threadId :: ThreadId
threadId exitCode :: ExitCode
exitCode = do
  HetcatsOpts -> IO ()
deletePidFile HetcatsOpts
opts
  ThreadId -> ExitCode -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
threadId ExitCode
exitCode

hetsServer :: HetcatsOpts -> IO ()
hetsServer :: HetcatsOpts -> IO ()
hetsServer opts :: HetcatsOpts
opts = do
  ThreadId
tid <- IO ThreadId
myThreadId
  HetcatsOpts -> IO ()
writePidFile HetcatsOpts
opts
  Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> ThreadId -> ExitCode -> IO ()
deletePidFileAndExit HetcatsOpts
opts ThreadId
tid ExitCode
ExitSuccess) Maybe SignalSet
forall a. Maybe a
Nothing
  Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigTERM (IO () -> Handler
Catch (IO () -> Handler) -> IO () -> Handler
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> ThreadId -> ExitCode -> IO ()
deletePidFileAndExit HetcatsOpts
opts ThreadId
tid ExitCode
ExitSuccess) Maybe SignalSet
forall a. Maybe a
Nothing
  HetcatsOpts -> IO ()
hetsServer' HetcatsOpts
opts
  HetcatsOpts -> IO ()
deletePidFile HetcatsOpts
opts

writePidFile :: HetcatsOpts -> IO ()
writePidFile :: HetcatsOpts -> IO ()
writePidFile opts :: HetcatsOpts
opts =
  let pidFilePath :: String
pidFilePath = HetcatsOpts -> String
pidFile HetcatsOpts
opts
      v :: Int
v = HetcatsOpts -> Int
verbose HetcatsOpts
opts
  in (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pidFilePath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
     do Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pidFilePath)
          (Int -> Int -> String -> IO ()
verbMsgIOLn Int
v 2 ("Writing PIDfile " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
pidFilePath))
        ProcessID
pid <- IO ProcessID
getProcessID
        String -> String -> IO ()
writeFile String
pidFilePath (ProcessID -> String
forall a. Show a => a -> String
show ProcessID
pid))

deletePidFile :: HetcatsOpts -> IO ()
deletePidFile :: HetcatsOpts -> IO ()
deletePidFile opts :: HetcatsOpts
opts =
  let pidFilePath :: String
pidFilePath = HetcatsOpts -> String
pidFile HetcatsOpts
opts
  in (Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
pidFilePath) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> String
pidFile HetcatsOpts
opts)

hetsServer' :: HetcatsOpts -> IO ()
hetsServer' :: HetcatsOpts -> IO ()
hetsServer' opts1 :: HetcatsOpts
opts1 = do
  String
tempDir <- IO String
getTemporaryDirectory
  let tempLib :: String
tempLib = String
tempDir String -> ShowS
</> "MyHetsLib"
      logFile :: String
logFile = String
tempDir String -> ShowS
</>
        ("hets-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
port String -> ShowS
forall a. [a] -> [a] -> [a]
++ ".log")
      opts :: HetcatsOpts
opts = HetcatsOpts
opts1 { libdirs :: [String]
libdirs = String
tempLib String -> [String] -> [String]
forall a. a -> [a] -> [a]
: HetcatsOpts -> [String]
libdirs HetcatsOpts
opts1 }
      port1 :: Int
port1 = HetcatsOpts -> Int
listen HetcatsOpts
opts1
      port :: Int
port = if Int
port1 Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then 8000 else Int
port1
      wl :: [[String]]
wl = HetcatsOpts -> [[String]]
whitelist HetcatsOpts
opts1
      bl :: [[String]]
bl = HetcatsOpts -> [[String]]
blacklist HetcatsOpts
opts1
      prList :: [[String]] -> String
prList ll :: [[String]]
ll = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ([String] -> String) -> [[String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ".") [[String]]
ll
  Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
tempLib

  -- create a mutable Cache that saves all Requests/Responses
  IORef RequestCacheMap
cachedRequestsResponses <- IO (IORef RequestCacheMap)
createNewRequestCache
  -- store the current requestBody bytestring
  IORef ByteString
currentRequestBodyBS <- ByteString -> IO (IORef ByteString)
forall a. a -> IO (IORef a)
newIORef (ByteString
BS.empty)

  String -> String -> IO ()
writeFile String
logFile ""
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[String]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[String]]
wl) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
appendFile String
logFile
    (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "white list: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [[String]] -> String
prList [[String]]
wl String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([[String]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[String]]
bl) (IO () -> IO ()) -> (String -> IO ()) -> String -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> IO ()
appendFile String
logFile
    (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "black list: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [[String]] -> String
prList [[String]]
bl String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  IORef (IntMap Session, Map [String] Session)
sessRef <- (IntMap Session, Map [String] Session)
-> IO (IORef (IntMap Session, Map [String] Session))
forall a. a -> IO (IORef a)
newIORef (IntMap Session
forall a. IntMap a
IntMap.empty, Map [String] Session
forall k a. Map k a
Map.empty)
  HetcatsOpts -> Int -> String -> IO ()
putIfVerbose HetcatsOpts
opts 1 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "hets server is listening on port " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
port
  HetcatsOpts -> Int -> String -> IO ()
putIfVerbose HetcatsOpts
opts 2 (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "for more information look into file: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
logFile
#ifdef WARP3
  Settings -> Application -> IO ()
runSettings ((SomeException -> Response) -> Settings -> Settings
setOnExceptionResponse SomeException -> Response
catchException (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
               Int -> Settings -> Settings
setPort Int
port (Settings -> Settings) -> Settings -> Settings
forall a b. (a -> b) -> a -> b
$
               Int -> Settings -> Settings
setTimeout 86400 Settings
defaultSettings)
    (Application -> IO ()) -> Application -> IO ()
forall a b. (a -> b) -> a -> b
$ \ re :: Request
re respond' :: Response -> IO ResponseReceived
respond' -> do
#else
  run port $ \ re -> do
   let respond' = liftIO . return
#endif
   let
       respond :: Response -> IO ResponseReceived
respond = \response :: Response
response -> do
          -- Before updating cache check if request was successful
          if Status -> Int
statusCode (Response -> Status
responseStatus Response
response) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 200 then do
            IORef ByteString
-> Request -> Response -> IORef RequestCacheMap -> IO ()
updateCache IORef ByteString
currentRequestBodyBS Request
re Response
response IORef RequestCacheMap
cachedRequestsResponses
            Response -> IO ResponseReceived
respond' Response
response
          else Response -> IO ResponseReceived
respond' Response
response
       rhost :: String
rhost = SockAddr -> ShowS
forall a. Show a => a -> ShowS
shows (Request -> SockAddr
remoteHost Request
re) "\n"
       ip :: [String]
ip = String -> [String]
getIP4 String
rhost
       white :: Bool
white = [String] -> [[String]] -> Bool
matchWhite [String]
ip [[String]]
wl
       black :: Bool
black = ([String] -> Bool) -> [[String]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ([String] -> [String] -> Bool
matchIP4 [String]
ip) [[String]]
bl
       splitQuery :: [QueryPair]
splitQuery = ((ByteString, Maybe ByteString) -> QueryPair)
-> [(ByteString, Maybe ByteString)] -> [QueryPair]
forall a b. (a -> b) -> [a] -> [b]
map (\ (bs :: ByteString
bs, ms :: Maybe ByteString
ms) -> (ByteString -> String
B8.unpack ByteString
bs, (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> String
B8.unpack Maybe ByteString
ms))
         ([(ByteString, Maybe ByteString)] -> [QueryPair])
-> [(ByteString, Maybe ByteString)] -> [QueryPair]
forall a b. (a -> b) -> a -> b
$ Request -> [(ByteString, Maybe ByteString)]
queryString Request
re
       pathBits :: [String]
pathBits = (Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Text -> String
T.unpack ([Text] -> [String]) -> [Text] -> [String]
forall a b. (a -> b) -> a -> b
$ Request -> [Text]
pathInfo Request
re
       meth :: String
meth = ByteString -> String
B8.unpack (Request -> ByteString
requestMethod Request
re)
       query :: String
query = [String] -> [QueryPair] -> String
showPathQuery [String]
pathBits [QueryPair]
splitQuery
   IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
     UTCTime
time <- IO UTCTime
getCurrentTime
     Bool -> String -> IO ()
createDirectoryIfMissing Bool
False String
tempLib
     (m :: IntMap Session
m, _) <- IORef (IntMap Session, Map [String] Session)
-> IO (IntMap Session, Map [String] Session)
forall a. IORef a -> IO a
readIORef IORef (IntMap Session, Map [String] Session)
sessRef
     String -> String -> IO ()
appendFile String
logFile String
rhost
     Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
black (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ if Bool
white then do
         String -> String -> IO ()
appendFile String
logFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ UTCTime -> ShowS
forall a. Show a => a -> ShowS
shows UTCTime
time " sessions: "
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Show a => a -> ShowS
shows (IntMap Session -> Int
forall a. IntMap a -> Int
IntMap.size IntMap Session
m) "\n"
         String -> String -> IO ()
appendFile String
logFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ RequestHeaders -> ShowS
forall a. Show a => a -> ShowS
shows (Request -> RequestHeaders
requestHeaders Request
re) "\n"
         Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
query) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
appendFile String
logFile (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
query String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
       else String -> String -> IO ()
appendFile String
logFile "not white listed\n"
   if Bool -> Bool
not Bool
white Bool -> Bool -> Bool
|| Bool
black then Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> Status -> String -> Response
mkResponse "" Status
status403 ""
    -- if path could be a RESTful request, try to parse it
    else do
     Either String ([QueryPair], [(String, String)], [Flag])
eith <- IO (Either String ([QueryPair], [(String, String)], [Flag]))
-> IO (Either String ([QueryPair], [(String, String)], [Flag]))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String ([QueryPair], [(String, String)], [Flag]))
 -> IO (Either String ([QueryPair], [(String, String)], [Flag])))
-> IO (Either String ([QueryPair], [(String, String)], [Flag]))
-> IO (Either String ([QueryPair], [(String, String)], [Flag]))
forall a b. (a -> b) -> a -> b
$ [QueryPair]
-> IO (Either String ([QueryPair], [(String, String)], [Flag]))
getArgFlags [QueryPair]
splitQuery
     case Either String ([QueryPair], [(String, String)], [Flag])
eith of
       Left err :: String
err -> String -> WebResponse
queryFail String
err Response -> IO ResponseReceived
respond
       Right (qr :: [QueryPair]
qr, vs :: [(String, String)]
vs, fs :: [Flag]
fs) ->
         let eith2 :: Either String ([QueryPair], [(String, Flag)])
eith2 = [QueryPair] -> Either String ([QueryPair], [(String, Flag)])
getSwitches [QueryPair]
qr
         in case Either String ([QueryPair], [(String, Flag)])
eith2 of
         Left err :: String
err -> String -> WebResponse
queryFail String
err Response -> IO ResponseReceived
respond
         Right (qr2 :: [QueryPair]
qr2, fs2 :: [(String, Flag)]
fs2) ->
           let newOpts :: HetcatsOpts
newOpts = (HetcatsOpts -> Flag -> HetcatsOpts)
-> HetcatsOpts -> [Flag] -> HetcatsOpts
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HetcatsOpts -> Flag -> HetcatsOpts
makeOpts HetcatsOpts
opts ([Flag] -> HetcatsOpts) -> [Flag] -> HetcatsOpts
forall a b. (a -> b) -> a -> b
$ [Flag]
fs [Flag] -> [Flag] -> [Flag]
forall a. [a] -> [a] -> [a]
++ ((String, Flag) -> Flag) -> [(String, Flag)] -> [Flag]
forall a b. (a -> b) -> [a] -> [b]
map (String, Flag) -> Flag
forall a b. (a, b) -> b
snd [(String, Flag)]
fs2
           in if String -> [String] -> Bool
isGraphQL String
meth [String]
pathBits then do
                   String
responseString <- HetcatsOpts
-> IORef (IntMap Session, Map [String] Session)
-> Request
-> IO String
processGraphQL HetcatsOpts
newOpts IORef (IntMap Session, Map [String] Session)
sessRef Request
re
                   Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> String -> Response
mkOkResponse "application/json" String
responseString
              else if [String] -> Bool
isRESTful [String]
pathBits then do
              ByteString
requestBodyBS <- Request -> IO ByteString
strictRequestBody Request
re
              Json
requestBodyParams <- Request -> ByteString -> RsrcIO Json
parseRequestParams Request
re ByteString
requestBodyBS
              let unknown :: [String]
unknown = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [String]
allQueryKeys) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (QueryPair -> String) -> [QueryPair] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map QueryPair -> String
forall a b. (a, b) -> a
fst [QueryPair]
qr2

              -- store the requestBody because the original one in the request is consumed
              IORef ByteString -> ByteString -> IO ()
forall a. IORef a -> a -> IO ()
atomicWriteIORef IORef ByteString
currentRequestBodyBS ByteString
requestBodyBS
              RequestMapKey
requestKey <- Request -> ByteString -> IO RequestMapKey
convertRequestToMapKey Request
re ByteString
requestBodyBS
              Maybe Response
cacheLookupResult <- RequestMapKey -> IORef RequestCacheMap -> IO (Maybe Response)
lookupCache RequestMapKey
requestKey IORef RequestCacheMap
cachedRequestsResponses
              -- check if cache should be used
              let cacheEntry :: Maybe Response
cacheEntry = if (QueryPair -> [QueryPair] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ("useCache", String -> Maybe String
forall a. a -> Maybe a
Just "true") [QueryPair]
qr2)
                               then Maybe Response
cacheLookupResult
                               else Maybe Response
forall a. Maybe a
Nothing
              if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
unknown
              then
                -- return cache if request is already cached and should be used
                case Maybe Response
cacheEntry of
                  Nothing -> do
                    HetcatsOpts
-> IORef (IntMap Session, Map [String] Session)
-> [String]
-> [String]
-> [QueryPair]
-> ByteString
-> Json
-> String
-> String
-> WebResponse
parseRESTful HetcatsOpts
newOpts IORef (IntMap Session, Map [String] Session)
sessRef [String]
pathBits
                      (((String, Flag) -> String) -> [(String, Flag)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Flag) -> String
forall a b. (a, b) -> a
fst [(String, Flag)]
fs2 [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, String) -> String) -> [(String, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a :: String
a, b :: String
b) -> String
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ "=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
b) [(String, String)]
vs) [QueryPair]
qr2
                      ByteString
requestBodyBS Json
requestBodyParams String
meth String
tempDir Response -> IO ResponseReceived
respond
                  Just cacheResponse :: Response
cacheResponse ->
                    -- Return directly cached response without updating the cache
                    Response -> IO ResponseReceived
respond' Response
cacheResponse
              else String -> WebResponse
queryFail ("unknown query key(s): " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall a. Show a => a -> String
show [String]
unknown) Response -> IO ResponseReceived
respond
           -- only otherwise stick to the old response methods
           else HetcatsOpts
-> String
-> IORef (IntMap Session, Map [String] Session)
-> Request
-> [String]
-> [QueryPair]
-> String
-> WebResponse
oldWebApi HetcatsOpts
newOpts String
tempLib IORef (IntMap Session, Map [String] Session)
sessRef Request
re [String]
pathBits [QueryPair]
qr2
             String
meth Response -> IO ResponseReceived
respond

parseRequestParams :: Request -> BS.ByteString -> RsrcIO Json
parseRequestParams :: Request -> ByteString -> RsrcIO Json
parseRequestParams request :: Request
request requestBodyBS :: ByteString
requestBodyBS =
  let
    noParams :: Json
    noParams :: Json
noParams = Json
JNull

    lookupHeader :: String -> Maybe String
    lookupHeader :: String -> Maybe String
lookupHeader s :: String
s =
      (ByteString -> String) -> Maybe ByteString -> Maybe String
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> String
B8.unpack (Maybe ByteString -> Maybe String)
-> Maybe ByteString -> Maybe String
forall a b. (a -> b) -> a -> b
$ CI ByteString -> RequestHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk (ByteString -> CI ByteString) -> ByteString -> CI ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B8.pack String
s) (RequestHeaders -> Maybe ByteString)
-> RequestHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
request

    formParams :: RsrcIO (Maybe Json)
    formParams :: RsrcIO (Maybe Json)
formParams =
      let toJsonObject :: [(B8.ByteString, B8.ByteString)] -> String
          toJsonObject :: [(ByteString, ByteString)] -> String
toJsonObject assocList :: [(ByteString, ByteString)]
assocList = "{"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ", " (((ByteString, ByteString) -> String)
-> [(ByteString, ByteString)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (k :: ByteString
k, v :: ByteString
v) ->
                  ByteString -> String
forall a. Show a => a -> String
show ByteString
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
jsonStringOrArray ByteString
v) [(ByteString, ByteString)]
assocList)
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ "}"
          jsonStringOrArray :: ByteString -> String
jsonStringOrArray str :: ByteString
str =
            if ByteString -> Char
B8.head ByteString
str Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '[' then ByteString -> String
B8.unpack ByteString
str else ByteString -> String
forall a. Show a => a -> String
show ByteString
str
      in do
        (formDataB8 :: [(ByteString, ByteString)]
formDataB8, _) <- BackEnd ByteString
-> Request -> IO ([(ByteString, ByteString)], [File ByteString])
forall y.
BackEnd y -> Request -> IO ([(ByteString, ByteString)], [File y])
parseRequestBody BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd Request
request
        Maybe Json -> RsrcIO (Maybe Json)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Json -> RsrcIO (Maybe Json))
-> Maybe Json -> RsrcIO (Maybe Json)
forall a b. (a -> b) -> a -> b
$ String -> Maybe Json
parseJson (String -> Maybe Json) -> String -> Maybe Json
forall a b. (a -> b) -> a -> b
$ [(ByteString, ByteString)] -> String
toJsonObject [(ByteString, ByteString)]
formDataB8

#ifdef WARP1
    lazyRequestBody :: Request -> ResourceT IO BS.ByteString
    lazyRequestBody = fmap BS.fromChunks . lazyConsume . requestBody
#endif
  in
    (Maybe Json -> Json) -> RsrcIO (Maybe Json) -> RsrcIO Json
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Json -> Maybe Json -> Json
forall a. a -> Maybe a -> a
fromMaybe Json
noParams) (RsrcIO (Maybe Json) -> RsrcIO Json)
-> RsrcIO (Maybe Json) -> RsrcIO Json
forall a b. (a -> b) -> a -> b
$ case String -> Maybe String
lookupHeader "Content-Type" of
      Just "application/json" -> ByteString -> RsrcIO (Maybe Json)
jsonBody ByteString
requestBodyBS
      Just "multipart/form-data" -> RsrcIO (Maybe Json)
formParams
      _ -> RsrcIO (Maybe Json)
formParams

-- | the old API that supports downloading files and interactive stuff
oldWebApi :: HetcatsOpts -> FilePath -> Cache -> Request -> [String]
  -> [QueryPair] -> String -> WebResponse
oldWebApi :: HetcatsOpts
-> String
-> IORef (IntMap Session, Map [String] Session)
-> Request
-> [String]
-> [QueryPair]
-> String
-> WebResponse
oldWebApi opts :: HetcatsOpts
opts tempLib :: String
tempLib sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef re :: Request
re pathBits :: [String]
pathBits splitQuery :: [QueryPair]
splitQuery meth :: String
meth respond :: Response -> IO ResponseReceived
respond =
  case String
meth of
      "GET" -> if Maybe (Maybe String) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (Maybe String) -> Bool) -> Maybe (Maybe String) -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [QueryPair] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "menus" [QueryPair]
splitQuery
         then WebResponse
mkMenuResponse Response -> IO ResponseReceived
respond else do
         let path :: String
path = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/" [String]
pathBits
         dirs :: [Element]
dirs@(_ : cs :: [Element]
cs) <- IO [Element] -> IO [Element]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Element] -> IO [Element]) -> IO [Element] -> IO [Element]
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> String -> [QueryPair] -> IO [Element]
getHetsLibContent HetcatsOpts
opts String
path [QueryPair]
splitQuery
         if Bool -> Bool
not ([Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
cs) Bool -> Bool -> Bool
|| String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path then String -> [Element] -> WebResponse
htmlResponse String
path [Element]
dirs Response -> IO ResponseReceived
respond
           -- AUTOMATIC PROOFS (parsing)
           else if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ [QueryPair] -> String -> Maybe String
getVal [QueryPair]
splitQuery "autoproof" then
             let qr :: Int -> Query
qr k :: Int
k = DGQuery -> QueryKind -> Query
Query (Int -> Maybe String -> DGQuery
DGQuery Int
k Maybe String
forall a. Maybe a
Nothing) (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$
                   [QueryPair] -> QueryKind
anaAutoProofQuery [QueryPair]
splitQuery in do
               Result ds :: [Diagnosis]
ds ms :: Maybe (String, String)
ms <- IO (Result (String, String)) -> IO (Result (String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result (String, String)) -> IO (Result (String, String)))
-> IO (Result (String, String)) -> IO (Result (String, String))
forall a b. (a -> b) -> a -> b
$ ResultT IO (String, String) -> IO (Result (String, String))
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT
                 (ResultT IO (String, String) -> IO (Result (String, String)))
-> ResultT IO (String, String) -> IO (Result (String, String))
forall a b. (a -> b) -> a -> b
$ case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. [a] -> a
head [String]
pathBits of
                 Nothing -> String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "cannot read session id for automatic proofs"
                 Just k' :: Int
k' -> HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> Query
-> Maybe String
-> UsedAPI
-> ProofFormatterOptions
-> ResultT IO (String, String)
getHetsResult HetcatsOpts
opts [] IORef (IntMap Session, Map [String] Session)
sessRef (Int -> Query
qr Int
k')
                              Maybe String
forall a. Maybe a
Nothing UsedAPI
OldWebAPI ProofFormatterOptions
proofFormatterOptions
               Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case Maybe (String, String)
ms of
                 Nothing -> String -> Status -> String -> Response
mkResponse String
textC Status
status422 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ Int -> [Diagnosis] -> String
showRelDiags 1 [Diagnosis]
ds
                 Just (t :: String
t, s :: String
s) -> String -> String -> Response
mkOkResponse String
t String
s
           -- AUTOMATIC PROOFS E.N.D.
           else HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> [String]
-> [QueryPair]
-> WebResponse
getHetsResponse HetcatsOpts
opts [] IORef (IntMap Session, Map [String] Session)
sessRef [String]
pathBits [QueryPair]
splitQuery Response -> IO ResponseReceived
respond
      "POST" -> do
        (params :: [(ByteString, ByteString)]
params, files :: [File ByteString]
files) <- BackEnd ByteString
-> Request -> IO ([(ByteString, ByteString)], [File ByteString])
forall y.
BackEnd y -> Request -> IO ([(ByteString, ByteString)], [File y])
parseRequestBody BackEnd ByteString
forall (m :: * -> *) ignored1 ignored2.
Monad m =>
ignored1 -> ignored2 -> m ByteString -> m ByteString
lbsBackEnd Request
re
        let opts' :: HetcatsOpts
opts' = case ByteString -> [(ByteString, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (String -> ByteString
B8.pack "input-type") [(ByteString, ByteString)]
params of
                      Nothing -> HetcatsOpts
opts
                      Just inputType :: ByteString
inputType -> if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String -> Bool) -> String -> Bool
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B8.unpack ByteString
inputType
                                        then HetcatsOpts
opts
                                        else HetcatsOpts
opts { intype :: InType
intype = String -> InType
forall a. Read a => String -> a
read (String -> InType) -> String -> InType
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B8.unpack ByteString
inputType }
        Maybe String
mTmpFile <- case String -> [(String, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup "content"
                   ([(String, ByteString)] -> Maybe ByteString)
-> [(String, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ ((ByteString, ByteString) -> (String, ByteString))
-> [(ByteString, ByteString)] -> [(String, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a :: ByteString
a, b :: ByteString
b) -> (ByteString -> String
B8.unpack ByteString
a, ByteString
b)) [(ByteString, ByteString)]
params of
              Nothing -> Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing
              Just areatext :: ByteString
areatext -> let content :: String
content = ByteString -> String
B8.unpack ByteString
areatext in
                if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
content then Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe String
forall a. Maybe a
Nothing else IO (Maybe String) -> IO (Maybe String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe String) -> IO (Maybe String))
-> IO (Maybe String) -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ do
                   String
tmpFile <- String -> String -> IO String
getTempFile String
content "temp.het"
                   Maybe String -> IO (Maybe String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String -> IO (Maybe String))
-> Maybe String -> IO (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
tmpFile
        let res :: String -> IO ResponseReceived
res tmpFile :: String
tmpFile =
              HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> [String]
-> [QueryPair]
-> WebResponse
getHetsResponse HetcatsOpts
opts' [] IORef (IntMap Session, Map [String] Session)
sessRef [String
tmpFile] [QueryPair]
splitQuery Response -> IO ResponseReceived
respond
            mRes :: IO ResponseReceived
mRes = IO ResponseReceived
-> (String -> IO ResponseReceived)
-> Maybe String
-> IO ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> WebResponse
queryFail "nothing submitted" Response -> IO ResponseReceived
respond)
              String -> IO ResponseReceived
res Maybe String
mTmpFile
        case [File ByteString]
files of
          [] -> if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ [QueryPair] -> String -> Maybe String
getVal [QueryPair]
splitQuery "prove" then
               HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> [String]
-> [QueryPair]
-> WebResponse
getHetsResponse HetcatsOpts
opts' [] IORef (IntMap Session, Map [String] Session)
sessRef [String]
pathBits
                 ([QueryPair]
splitQuery [QueryPair] -> [QueryPair] -> [QueryPair]
forall a. [a] -> [a] -> [a]
++ ((ByteString, ByteString) -> QueryPair)
-> [(ByteString, ByteString)] -> [QueryPair]
forall a b. (a -> b) -> [a] -> [b]
map (\ (a :: ByteString
a, b :: ByteString
b)
                 -> (ByteString -> String
B8.unpack ByteString
a, String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B8.unpack ByteString
b)) [(ByteString, ByteString)]
params) Response -> IO ResponseReceived
respond
            else IO ResponseReceived
mRes
          [(_, f :: FileInfo ByteString
f)] | Maybe (Maybe String) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Maybe String) -> Bool) -> Maybe (Maybe String) -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [QueryPair] -> Maybe (Maybe String)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
updateS [QueryPair]
splitQuery -> do
           let fn :: String
fn = ShowS
takeFileName ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ ByteString -> String
B8.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ FileInfo ByteString -> ByteString
forall c. FileInfo c -> ByteString
fileName FileInfo ByteString
f
           if (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Char -> Bool
isAlphaNum String
fn then do
             let tmpFile :: String
tmpFile = String
tempLib String -> ShowS
</> String
fn
             IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
BS.writeFile String
tmpFile (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FileInfo ByteString -> ByteString
forall c. FileInfo c -> c
fileContent FileInfo ByteString
f
             IO ResponseReceived
-> (String -> IO ResponseReceived)
-> Maybe String
-> IO ResponseReceived
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> IO ResponseReceived
res String
tmpFile) String -> IO ResponseReceived
res Maybe String
mTmpFile
            else IO ResponseReceived
mRes
          _ -> HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> [String]
-> [QueryPair]
-> WebResponse
getHetsResponse
                 HetcatsOpts
opts' ((File ByteString -> FileInfo ByteString)
-> [File ByteString] -> [FileInfo ByteString]
forall a b. (a -> b) -> [a] -> [b]
map File ByteString -> FileInfo ByteString
forall a b. (a, b) -> b
snd [File ByteString]
files) IORef (IntMap Session, Map [String] Session)
sessRef [String]
pathBits [QueryPair]
splitQuery Response -> IO ResponseReceived
respond
      _ -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> Status -> String -> Response
mkResponse "" Status
status400 ""

-- extract what we need to know from an autoproof request
anaAutoProofQuery :: [QueryPair] -> QueryKind
anaAutoProofQuery :: [QueryPair] -> QueryKind
anaAutoProofQuery splitQuery :: [QueryPair]
splitQuery = let
  lookup2 :: String -> Maybe String
lookup2 = [QueryPair] -> String -> Maybe String
getVal [QueryPair]
splitQuery
  prover :: Maybe String
prover = String -> Maybe String
lookup2 "prover"
  trans :: Maybe String
trans = String -> Maybe String
lookup2 "translation"
  timeout :: Maybe Int
timeout = String -> Maybe String
lookup2 "timeout" Maybe String -> (String -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe
  include :: Bool
include = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "on") (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
lookup2 "includetheorems"
  nodeSel :: [String]
nodeSel = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "includetheorems")
      ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (QueryPair -> String) -> [QueryPair] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map QueryPair -> String
forall a b. (a, b) -> a
fst ([QueryPair] -> [String]) -> [QueryPair] -> [String]
forall a b. (a -> b) -> a -> b
$ (QueryPair -> Bool) -> [QueryPair] -> [QueryPair]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just "on") (Maybe String -> Bool)
-> (QueryPair -> Maybe String) -> QueryPair -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QueryPair -> Maybe String
forall a b. (a, b) -> b
snd) [QueryPair]
splitQuery
  axioms :: [String]
axioms = Maybe String -> [String]
mSplitOnComma (Maybe String -> [String]) -> Maybe String -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
lookup2 "axioms"
  prOrCons :: ProverMode
prOrCons = case String -> Maybe String
lookup2 "autoproof" of
    Just "proof" -> ProverMode
GlProofs
    Just "cons" -> ProverMode
GlConsistency
    err :: Maybe String
err -> String -> ProverMode
forall a. HasCallStack => String -> a
error (String -> ProverMode) -> String -> ProverMode
forall a b. (a -> b) -> a -> b
$ "illegal autoproof method: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. Show a => a -> String
show Maybe String
err
  in ProveCmd -> QueryKind
GlAutoProve (ProveCmd -> QueryKind) -> ProveCmd -> QueryKind
forall a b. (a -> b) -> a -> b
$
        ProverMode
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> [String]
-> Bool
-> [String]
-> ProveCmd
ProveCmd ProverMode
prOrCons Bool
include Maybe String
prover Maybe String
trans Maybe Int
timeout [String]
nodeSel Bool
False [String]
axioms

-- quick approach to whether or not the query can be a RESTful request
isRESTful :: [String] -> Bool
isRESTful :: [String] -> Bool
isRESTful pathBits :: [String]
pathBits = case [String]
pathBits of
  [] -> Bool
False
  [h :: String
h] | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
h ["numeric-version", "version", "robots.txt"] -> Bool
True
  h :: String
h : _ -> String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
h [String]
listRESTfulIdentifiers

listRESTfulIdentifiers :: [String]
listRESTfulIdentifiers :: [String]
listRESTfulIdentifiers =
  [ "libraries", "sessions", "menus", "filetype", "hets-lib", "dir", "folder"]
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
nodeEdgeIdes [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
newRESTIdes
  [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["available-provers", "uploadFile"]

nodeEdgeIdes :: [String]
nodeEdgeIdes :: [String]
nodeEdgeIdes = ["nodes", "edges"]

newRESTIdes :: [String]
newRESTIdes :: [String]
newRESTIdes =
  [ "dg", "translations", "provers", "consistency-checkers", "prove"
  , "consistency-check", "theory" ]

queryFail :: String -> WebResponse
queryFail :: String -> WebResponse
queryFail msg :: String
msg respond :: Response -> IO ResponseReceived
respond = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> Status -> String -> Response
mkResponse String
textC Status
status400 String
msg

allQueryKeys :: [String]
allQueryKeys :: [String]
allQueryKeys = [String
updateS, "library", "consistency-checker", "overwrite",
  "useCache"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
globalCommands [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
knownQueryKeys

data RequestBodyParam = Single String | List [String]

-- query is analysed and processed in accordance with RESTful interface
parseRESTful :: HetcatsOpts -> Cache -> [String] -> [String] -> [QueryPair]
  -> BS.ByteString -> Json -> String -> FilePath -> WebResponse
parseRESTful :: HetcatsOpts
-> IORef (IntMap Session, Map [String] Session)
-> [String]
-> [String]
-> [QueryPair]
-> ByteString
-> Json
-> String
-> String
-> WebResponse
parseRESTful
  opts :: HetcatsOpts
opts sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef pathBits :: [String]
pathBits qOpts :: [String]
qOpts splitQuery :: [QueryPair]
splitQuery requestBodyBS :: ByteString
requestBodyBS requestBodyParams :: Json
requestBodyParams meth :: String
meth
  tempDir :: String
tempDir respond :: Response -> IO ResponseReceived
respond = let
  {- some parameters from the paths query part might be needed more than once
  (when using lookup upon querybits, you need to unpack Maybe twice) -}
  lookupQueryStringParam :: String -> Maybe String
  lookupQueryStringParam :: String -> Maybe String
lookupQueryStringParam = [QueryPair] -> String -> Maybe String
getVal [QueryPair]
splitQuery

  lookupBodyParam :: String -> Json -> Maybe RequestBodyParam
  lookupBodyParam :: String -> Json -> Maybe RequestBodyParam
lookupBodyParam key :: String
key json :: Json
json = case Json
json of
    JObject pairs :: [JPair]
pairs -> case String -> [JPair] -> Maybe Json
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
key [JPair]
pairs of
      Just (JArray a :: [Json]
a) -> RequestBodyParam -> Maybe RequestBodyParam
forall a. a -> Maybe a
Just (RequestBodyParam -> Maybe RequestBodyParam)
-> RequestBodyParam -> Maybe RequestBodyParam
forall a b. (a -> b) -> a -> b
$ [String] -> RequestBodyParam
List ([String] -> RequestBodyParam) -> [String] -> RequestBodyParam
forall a b. (a -> b) -> a -> b
$ (Json -> String) -> [Json] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
forall a. Read a => String -> a
read ShowS -> (Json -> String) -> Json -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Json -> String
ppJson) [Json]
a
      Just v :: Json
v -> RequestBodyParam -> Maybe RequestBodyParam
forall a. a -> Maybe a
Just (RequestBodyParam -> Maybe RequestBodyParam)
-> RequestBodyParam -> Maybe RequestBodyParam
forall a b. (a -> b) -> a -> b
$ String -> RequestBodyParam
Single (String -> RequestBodyParam) -> String -> RequestBodyParam
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. Read a => String -> a
read ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Json -> String
ppJson Json
v
      _ -> Maybe RequestBodyParam
forall a. Maybe a
Nothing
    _ -> Maybe RequestBodyParam
forall a. Maybe a
Nothing

  lookupSingleParam :: String -> Maybe String
  lookupSingleParam :: String -> Maybe String
lookupSingleParam key :: String
key = case String
meth of
    "GET" -> String -> Maybe String
lookupQueryStringParam String
key
    _ -> case String -> Json -> Maybe RequestBodyParam
lookupBodyParam String
key Json
requestBodyParams of
          Just (Single s :: String
s) -> String -> Maybe String
forall a. a -> Maybe a
Just String
s
          _ -> Maybe String
forall a. Maybe a
Nothing

  isParamTrue :: Bool -> String -> Bool
  isParamTrue :: Bool -> String -> Bool
isParamTrue def :: Bool
def key :: String
key = case ShowS -> Maybe String -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower) (Maybe String -> Maybe String) -> Maybe String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
lookupSingleParam String
key of
    Nothing -> Bool
def
    Just "true" -> Bool
True
    _ -> Bool
False

  session :: Maybe Int
session = String -> Maybe String
lookupSingleParam "session" Maybe String -> (String -> Maybe Int) -> Maybe Int
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe
  library :: Maybe String
library = String -> Maybe String
lookupSingleParam "library"
  format_ :: Maybe String
format_ = String -> Maybe String
lookupSingleParam "format"
  nodeM :: Maybe String
nodeM = String -> Maybe String
lookupSingleParam "node"
  includeDetails :: Bool
includeDetails = Bool -> String -> Bool
isParamTrue Bool
True "includeDetails"
  includeProof :: Bool
includeProof = Bool -> String -> Bool
isParamTrue Bool
True "includeProof"
  transM :: Maybe String
transM = String -> Maybe String
lookupSingleParam "translation"
  reasoningParametersE :: Either String ReasoningParameters
reasoningParametersE = ByteString -> Either String ReasoningParameters
parseReasoningParametersEither ByteString
requestBodyBS
  queryFailure :: IO ResponseReceived
queryFailure = String -> WebResponse
queryFail
    ("this query does not comply with RESTful interface: "
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> [QueryPair] -> String
showPathQuery [String]
pathBits [QueryPair]
splitQuery) Response -> IO ResponseReceived
respond
  -- since used more often, generate full query out of nodeIRI and nodeCmd
  nodeQuery :: String -> NodeCommand -> QueryKind
nodeQuery s :: String
s = NodeIdOrName -> NodeCommand -> QueryKind
NodeQuery (NodeIdOrName -> NodeCommand -> QueryKind)
-> NodeIdOrName -> NodeCommand -> QueryKind
forall a b. (a -> b) -> a -> b
$ NodeIdOrName -> (Int -> NodeIdOrName) -> Maybe Int -> NodeIdOrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NodeIdOrName
forall a b. b -> Either a b
Right String
s) Int -> NodeIdOrName
forall a b. a -> Either a b
Left (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
s :: Maybe Int)
  pfOptions :: ProofFormatterOptions
pfOptions = ProofFormatterOptions
proofFormatterOptions
                { pfoIncludeProof :: Bool
pfoIncludeProof = Bool
includeProof
                , pfoIncludeDetails :: Bool
pfoIncludeDetails = Bool
includeDetails
                }
  parseNodeQuery :: Monad m => String -> Int -> m NodeCommand -> m Query.Query
  parseNodeQuery :: String -> Int -> m NodeCommand -> m Query
parseNodeQuery p :: String
p sId :: Int
sId ncmd :: m NodeCommand
ncmd = m NodeCommand
ncmd m NodeCommand -> (NodeCommand -> m Query) -> m Query
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= let
      in Query -> m Query
forall (m :: * -> *) a. Monad m => a -> m a
return (Query -> m Query)
-> (NodeCommand -> Query) -> NodeCommand -> m Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGQuery -> QueryKind -> Query
Query (Int -> Maybe String -> DGQuery
DGQuery Int
sId (String -> Maybe String
forall a. a -> Maybe a
Just String
p)) (QueryKind -> Query)
-> (NodeCommand -> QueryKind) -> NodeCommand -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> NodeCommand -> QueryKind
nodeQuery (ShowS
getFragment String
p)
  -- call getHetsResult with the properly generated query (Final Result)
  getResponseAux :: HetcatsOpts -> Query -> IO ResponseReceived
getResponseAux myOpts :: HetcatsOpts
myOpts qr :: Query
qr = do
    let format' :: Maybe String
format' = String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "xml" Maybe String
format_
    Result ds :: [Diagnosis]
ds ms :: Maybe (String, String)
ms <- IO (Result (String, String)) -> IO (Result (String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result (String, String)) -> IO (Result (String, String)))
-> IO (Result (String, String)) -> IO (Result (String, String))
forall a b. (a -> b) -> a -> b
$ ResultT IO (String, String) -> IO (Result (String, String))
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT (ResultT IO (String, String) -> IO (Result (String, String)))
-> ResultT IO (String, String) -> IO (Result (String, String))
forall a b. (a -> b) -> a -> b
$
      HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> Query
-> Maybe String
-> UsedAPI
-> ProofFormatterOptions
-> ResultT IO (String, String)
getHetsResult HetcatsOpts
myOpts [] IORef (IntMap Session, Map [String] Session)
sessRef Query
qr Maybe String
format' UsedAPI
RESTfulAPI ProofFormatterOptions
pfOptions
    Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case Maybe (String, String)
ms of
      Nothing -> String -> Status -> String -> Response
mkResponse String
textC Status
status422 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ Int -> [Diagnosis] -> String
showRelDiags 1 [Diagnosis]
ds
      Just (t :: String
t, s :: String
s) -> String -> String -> Response
mkOkResponse String
t String
s
  getResponse :: Query -> IO ResponseReceived
getResponse = HetcatsOpts -> Query -> IO ResponseReceived
getResponseAux HetcatsOpts
opts
  -- respond depending on request Method
  in case String
meth of
    rm :: String
rm | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
rm ["GET", "POST"] -> case [String]
pathBits of
      ["robots.txt"] -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> String -> Response
mkOkResponse String
textC
        (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines ["User-agent: *", "Disallow: /"]
      -- show all menu options
      ["menus"] -> WebResponse
mkMenuResponse Response -> IO ResponseReceived
respond
      -- list files from directory
      "dir" : r :: [String]
r -> do
        let path' :: String
path' = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/" [String]
r
        [Element]
dirs <- IO [Element] -> IO [Element]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Element] -> IO [Element]) -> IO [Element] -> IO [Element]
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> String -> [QueryPair] -> IO [Element]
getHetsLibContent HetcatsOpts
opts String
path' [QueryPair]
splitQuery
        String -> [Element] -> WebResponse
htmlResponse String
path' [Element]
dirs Response -> IO ResponseReceived
respond
      ["version"] -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> String -> Response
mkOkResponse String
textC String
hetsVersion
      ["numeric-version"] ->
        Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> String -> Response
mkOkResponse String
textC String
hetsVersionNumeric
      ["available-provers"] ->
         IO Element -> IO Element
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (LogicGraph -> IO Element
usableProvers LogicGraph
logicGraph)
         IO Element
-> (Element -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (Element -> Response) -> Element -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Response
mkOkResponse String
xmlC (String -> Response) -> (Element -> String) -> Element -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> String
ppTopElement
      -- return an unique folder for uploading a file
      ["folder"] -> do
        String
uniqueFolderName <- String -> IO String
mkdtemp (String
tempDir String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
pathSeparator] String -> ShowS
forall a. [a] -> [a] -> [a]
++ "hetsUserFolder_")
        Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> String -> Response
mkOkResponse String
textC String
uniqueFolderName
      -- upload a user file to folder for future proving
      "uploadFile" : folderIri :: String
folderIri : fileNameIri :: String
fileNameIri : _-> do
        let userFileContent :: String
userFileContent = ByteString -> String
BS.unpack ByteString
requestBodyBS
        let userFilePath :: String
userFilePath = String
tempDir String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
pathSeparator] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
folderIri String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char
pathSeparator] String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fileNameIri
        Bool
fileExists <- String -> IO Bool
doesFileExist String
userFilePath
        -- Check if file already exists and no overwrite flag is set
        if Bool
fileExists Bool -> Bool -> Bool
&& Bool -> Bool
not (QueryPair -> [QueryPair] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ("overwrite", String -> Maybe String
forall a. a -> Maybe a
Just "true") [QueryPair]
splitQuery)
          then
            String -> IO ResponseReceived
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("the file you wish to upload already exists, for overwrite" String -> ShowS
forall a. [a] -> [a] -> [a]
++
                      "please set the corresponding flag")
          else do
            -- write file
            Handle
handleUserFile <- String -> IOMode -> IO Handle
openFile String
userFilePath IOMode
ReadWriteMode
            Handle -> String -> IO ()
hPutStr Handle
handleUserFile String
userFileContent
            Handle -> IO ()
hClose Handle
handleUserFile
            Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> String -> Response
mkOkResponse String
textC String
userFilePath
      -- get dgraph from file
      "filetype" : libIri :: String
libIri : _ -> HetcatsOpts -> String -> WebResponse
mkFiletypeResponse HetcatsOpts
opts String
libIri Response -> IO ResponseReceived
respond
      "hets-lib" : r :: [String]
r -> let file :: String
file = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/" [String]
r in
        Query -> IO ResponseReceived
getResponse (Query -> IO ResponseReceived) -> Query -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query (String -> [String] -> DGQuery
NewDGQuery String
file []) (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$ Maybe String -> QueryKind
DisplayQuery Maybe String
format_
      -- get library (complies with get/hets-lib for now)
      ["libraries", libIri :: String
libIri, "development_graph"] ->
        Query -> IO ResponseReceived
getResponse (Query -> IO ResponseReceived) -> Query -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query (String -> [String] -> DGQuery
NewDGQuery String
libIri []) (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$ Maybe String -> QueryKind
DisplayQuery Maybe String
format_
      -- get previously created session
      "sessions" : sessId :: String
sessId : cmd :: [String]
cmd -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
sessId of
          Nothing -> String -> WebResponse
queryFail ("failed to read session number from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sessId)
            Response -> IO ResponseReceived
respond
          Just sId :: Int
sId ->
            (case Maybe String
nodeM of
              Just ndIri :: String
ndIri -> String -> Int -> IO NodeCommand -> IO Query
forall (m :: * -> *).
Monad m =>
String -> Int -> m NodeCommand -> m Query
parseNodeQuery String
ndIri Int
sId (IO NodeCommand -> IO Query) -> IO NodeCommand -> IO Query
forall a b. (a -> b) -> a -> b
$ case [String]
cmd of
                ["provers"] -> NodeCommand -> IO NodeCommand
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeCommand -> IO NodeCommand) -> NodeCommand -> IO NodeCommand
forall a b. (a -> b) -> a -> b
$ ProverMode -> Maybe String -> NodeCommand
NcProvers ProverMode
GlProofs Maybe String
transM
                ["translations"] -> NodeCommand -> IO NodeCommand
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeCommand -> IO NodeCommand) -> NodeCommand -> IO NodeCommand
forall a b. (a -> b) -> a -> b
$ Maybe String -> NodeCommand
NcTranslations Maybe String
forall a. Maybe a
Nothing
                _ -> String -> IO NodeCommand
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> IO NodeCommand) -> String -> IO NodeCommand
forall a b. (a -> b) -> a -> b
$ "unknown node command for a GET-request: "
                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/" [String]
cmd
              Nothing -> (QueryKind -> Query) -> IO QueryKind -> IO Query
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DGQuery -> QueryKind -> Query
Query (Int -> Maybe String -> DGQuery
DGQuery Int
sId Maybe String
forall a. Maybe a
Nothing)) (IO QueryKind -> IO Query) -> IO QueryKind -> IO Query
forall a b. (a -> b) -> a -> b
$ case [String]
cmd of
                [] -> QueryKind -> IO QueryKind
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryKind -> IO QueryKind) -> QueryKind -> IO QueryKind
forall a b. (a -> b) -> a -> b
$ Maybe String -> QueryKind
DisplayQuery Maybe String
format_
                ["provers"] -> QueryKind -> IO QueryKind
forall (m :: * -> *) a. Monad m => a -> m a
return (QueryKind -> IO QueryKind) -> QueryKind -> IO QueryKind
forall a b. (a -> b) -> a -> b
$ ProverMode -> Maybe String -> QueryKind
GlProvers ProverMode
GlProofs Maybe String
transM
                ["translations"] -> QueryKind -> IO QueryKind
forall (m :: * -> *) a. Monad m => a -> m a
return QueryKind
GlTranslations
                _ -> String -> IO QueryKind
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> IO QueryKind) -> String -> IO QueryKind
forall a b. (a -> b) -> a -> b
$ "unknown global command for a GET-request: "
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "/" [String]
cmd) IO Query -> (Query -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Query -> IO ResponseReceived
getResponse
      -- get node or edge view
      nodeOrEdge :: String
nodeOrEdge : p :: String
p : c :: [String]
c | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
nodeOrEdge [String]
nodeEdgeIdes -> let
        iriPath :: String
iriPath = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '#') String
p
        dgQ :: DGQuery
dgQ = DGQuery -> (Int -> DGQuery) -> Maybe Int -> DGQuery
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> [String] -> DGQuery
NewDGQuery (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
iriPath Maybe String
library) [])
                 (Int -> Maybe String -> DGQuery
`DGQuery` Maybe String
library) Maybe Int
session
        f :: String
f = ShowS
getFragment String
p
        in case String -> [String] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex String
nodeOrEdge [String]
nodeEdgeIdes of
          Just 0 -> let
            i :: NodeIdOrName
i = NodeIdOrName -> (Int -> NodeIdOrName) -> Maybe Int -> NodeIdOrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NodeIdOrName
forall a b. b -> Either a b
Right String
f) Int -> NodeIdOrName
forall a b. a -> Either a b
Left (Maybe Int -> NodeIdOrName) -> Maybe Int -> NodeIdOrName
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
f in
            Query -> IO ResponseReceived
getResponse (Query -> IO ResponseReceived) -> Query -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query DGQuery
dgQ (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$ NodeIdOrName -> NodeCommand -> QueryKind
NodeQuery NodeIdOrName
i (NodeCommand -> QueryKind) -> NodeCommand -> QueryKind
forall a b. (a -> b) -> a -> b
$ case [String]
c of
                ["theory"] -> NodeCmd -> NodeCommand
NcCmd NodeCmd
Query.Theory
                _ -> NodeCmd -> NodeCommand
NcCmd NodeCmd
Query.Info
          Just 1 -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
f of
            Just i :: Int
i -> Query -> IO ResponseReceived
getResponse (Query -> IO ResponseReceived) -> Query -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query DGQuery
dgQ (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$ Int -> String -> QueryKind
EdgeQuery Int
i "edge"
            Nothing -> String -> WebResponse
queryFail ("failed to read edgeId from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f) Response -> IO ResponseReceived
respond
          _ -> String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error (String -> IO ResponseReceived) -> String -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ "PGIP.Server.elemIndex " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nodeOrEdge
      newIde :: String
newIde : libIri :: String
libIri : rest :: [String]
rest ->
        let cmdOptList :: [String]
cmdOptList = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "") [String]
rest
            (optFlags :: [String]
optFlags, cmdList :: [String]
cmdList) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((String, Flag) -> String) -> [(String, Flag)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Flag) -> String
forall a b. (a, b) -> a
fst [(String, Flag)]
optionFlags)
              [String]
cmdOptList
            newOpts :: HetcatsOpts
newOpts = (HetcatsOpts -> Flag -> HetcatsOpts)
-> HetcatsOpts -> [Flag] -> HetcatsOpts
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl HetcatsOpts -> Flag -> HetcatsOpts
makeOpts HetcatsOpts
opts ([Flag] -> HetcatsOpts) -> [Flag] -> HetcatsOpts
forall a b. (a -> b) -> a -> b
$ (String -> Maybe Flag) -> [String] -> [Flag]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (String -> [(String, Flag)] -> Maybe Flag
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, Flag)]
optionFlags)
              [String]
optFlags
            validReasoningParams :: Bool
validReasoningParams = Either String ReasoningParameters -> Bool
forall a b. Either a b -> Bool
isRight Either String ReasoningParameters
reasoningParametersE Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
<=
              String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
newIde ["prove", "consistency-check"]
        in
          if String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
newIde [String]
newRESTIdes
                  Bool -> Bool -> Bool
&& (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
globalCommands) [String]
cmdList
                  Bool -> Bool -> Bool
&& Bool
validReasoningParams
            then let
            qkind :: QueryKind
qkind = case String
newIde of
              "translations" -> case Maybe String
nodeM of
                Nothing -> QueryKind
GlTranslations
                Just n :: String
n -> String -> NodeCommand -> QueryKind
nodeQuery String
n (NodeCommand -> QueryKind) -> NodeCommand -> QueryKind
forall a b. (a -> b) -> a -> b
$ Maybe String -> NodeCommand
NcTranslations Maybe String
forall a. Maybe a
Nothing
              _ | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
newIde ["provers", "consistency-checkers"] ->
                let pm :: ProverMode
pm = if String
newIde String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "provers" then ProverMode
GlProofs else ProverMode
GlConsistency
                in case Maybe String
nodeM of
                Nothing -> ProverMode -> Maybe String -> QueryKind
GlProvers ProverMode
pm Maybe String
transM
                Just n :: String
n -> String -> NodeCommand -> QueryKind
nodeQuery String
n (NodeCommand -> QueryKind) -> NodeCommand -> QueryKind
forall a b. (a -> b) -> a -> b
$ ProverMode -> Maybe String -> NodeCommand
NcProvers ProverMode
pm Maybe String
transM
              _ | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
newIde ["prove", "consistency-check"] ->
                case Either String ReasoningParameters
reasoningParametersE of
                  Left message_ :: String
message_ -> String -> QueryKind
forall a. HasCallStack => String -> a
error ("Invalid parameters: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message_) -- cannot happen
                  Right reasoningParameters :: ReasoningParameters
reasoningParameters ->
                    let proverMode :: ProverMode
proverMode = if String
newIde String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "prove"
                                      then ProverMode
GlProofs
                                      else ProverMode
GlConsistency
                    in ProverMode -> ReasoningParameters -> QueryKind
GlAutoProveREST ProverMode
proverMode ReasoningParameters
reasoningParameters
              "dg" -> case Maybe String
transM of
                Nothing -> Maybe String -> QueryKind
DisplayQuery (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "xml" Maybe String
format_)
                Just tr :: String
tr -> String -> QueryKind
Query.DGTranslation String
tr
              "theory" -> case Maybe String
transM of
                Nothing -> case Maybe String
nodeM of
                            Just x :: String
x -> NodeIdOrName -> NodeCommand -> QueryKind
NodeQuery (NodeIdOrName -> (Int -> NodeIdOrName) -> Maybe Int -> NodeIdOrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NodeIdOrName
forall a b. b -> Either a b
Right String
x) Int -> NodeIdOrName
forall a b. a -> Either a b
Left (Maybe Int -> NodeIdOrName) -> Maybe Int -> NodeIdOrName
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
x)
                                      (NodeCommand -> QueryKind) -> NodeCommand -> QueryKind
forall a b. (a -> b) -> a -> b
$ NodeCmd -> NodeCommand
NcCmd NodeCmd
Query.Theory
                            Nothing -> String -> QueryKind
forall a. HasCallStack => String -> a
error "development graph node missing. Please use <url>?node=<number>"
                Just tr :: String
tr -> case Maybe String
nodeM of
                            Just x :: String
x -> NodeIdOrName -> NodeCommand -> QueryKind
NodeQuery (NodeIdOrName -> (Int -> NodeIdOrName) -> Maybe Int -> NodeIdOrName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> NodeIdOrName
forall a b. b -> Either a b
Right String
x) Int -> NodeIdOrName
forall a b. a -> Either a b
Left (Maybe Int -> NodeIdOrName) -> Maybe Int -> NodeIdOrName
forall a b. (a -> b) -> a -> b
$ String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
x)
                                      (NodeCommand -> QueryKind) -> NodeCommand -> QueryKind
forall a b. (a -> b) -> a -> b
$ NodeCmd -> NodeCommand
NcCmd (NodeCmd -> NodeCommand) -> NodeCmd -> NodeCommand
forall a b. (a -> b) -> a -> b
$ String -> NodeCmd
Query.Translate String
tr
                            Nothing -> String -> QueryKind
forall a. HasCallStack => String -> a
error "development graph node missing. Please specifiy ?node=<number>"
              _ -> String -> QueryKind
forall a. HasCallStack => String -> a
error (String -> QueryKind) -> String -> QueryKind
forall a b. (a -> b) -> a -> b
$ "REST: unknown " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
newIde
            in HetcatsOpts -> Query -> IO ResponseReceived
getResponseAux HetcatsOpts
newOpts (Query -> IO ResponseReceived)
-> (QueryKind -> Query) -> QueryKind -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGQuery -> QueryKind -> Query
Query (String -> [String] -> DGQuery
NewDGQuery String
libIri ([String] -> DGQuery) -> [String] -> DGQuery
forall a b. (a -> b) -> a -> b
$ [String]
cmdList
                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ Set String -> [String]
forall a. Set a -> [a]
Set.toList ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList ([String] -> Set String) -> [String] -> Set String
forall a b. (a -> b) -> a -> b
$ [String]
optFlags [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
qOpts)) (QueryKind -> IO ResponseReceived)
-> QueryKind -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ QueryKind
qkind
            else if Bool
validReasoningParams
                then IO ResponseReceived
queryFailure
                else case Either String ReasoningParameters
reasoningParametersE of
                        Left message_ :: String
message_ ->
                          String -> WebResponse
queryFail ("Invalid parameters: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message_) Response -> IO ResponseReceived
respond
                        Right _ ->
                          String -> IO ResponseReceived
forall a. HasCallStack => String -> a
error "Unexpected error in PGIP.Server.parseRESTful"
      _ -> IO ResponseReceived
queryFailure
    "PUT" -> case [String]
pathBits of
      {- execute global commands
         TODO load other library ??? -}
      ["libraries", libIri :: String
libIri, "proofs", prId :: String
prId, cmd :: String
cmd] ->
         case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
prId of
           Nothing -> String -> WebResponse
queryFail ("failed to read sessionId from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prId)
             Response -> IO ResponseReceived
respond
           Just sessId :: Int
sessId -> let
             dgQ :: DGQuery
dgQ = Int -> Maybe String -> DGQuery
DGQuery Int
sessId (Maybe String -> DGQuery) -> Maybe String -> DGQuery
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
libIri in
             Query -> IO ResponseReceived
getResponse (Query -> IO ResponseReceived) -> Query -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query DGQuery
dgQ (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$ String -> QueryKind
GlobCmdQuery String
cmd
      -- execute a proof or calculus request
      ["sessions", sessId :: String
sessId, cmd :: String
cmd] -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
sessId of
        Nothing -> String -> WebResponse
queryFail ("failed to read sessionId from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sessId)
          Response -> IO ResponseReceived
respond
        Just sId :: Int
sId -> case String
cmd of
          "prove" -> case Either String ReasoningParameters
reasoningParametersE of
              Left message_ :: String
message_ -> String -> IO Query
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("Invalid parameters: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
message_)
              Right reasoningParameters :: ReasoningParameters
reasoningParameters ->
                Query -> IO Query
forall (m :: * -> *) a. Monad m => a -> m a
return (Query -> IO Query) -> Query -> IO Query
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query (Int -> Maybe String -> DGQuery
DGQuery Int
sId Maybe String
forall a. Maybe a
Nothing) (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$
                  ProverMode -> ReasoningParameters -> QueryKind
GlAutoProveREST ProverMode
GlProofs ReasoningParameters
reasoningParameters
              IO Query -> (Query -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Query -> IO ResponseReceived
getResponse
          -- on other cmd look for (optional) specification of node or edge
          _ -> case (Maybe String
nodeM, String -> Maybe String
lookupSingleParam "edge") of
              -- fail if both are specified
              (Just _, Just _) ->
                String -> IO Query
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "please specify only either node or edge"
              -- call command upon a single node
              (Just ndIri :: String
ndIri, Nothing) -> String -> Int -> IO NodeCommand -> IO Query
forall (m :: * -> *).
Monad m =>
String -> Int -> m NodeCommand -> m Query
parseNodeQuery String
ndIri Int
sId
                (IO NodeCommand -> IO Query) -> IO NodeCommand -> IO Query
forall a b. (a -> b) -> a -> b
$ case String -> [(String, NodeCmd)] -> Maybe NodeCmd
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
cmd ([(String, NodeCmd)] -> Maybe NodeCmd)
-> [(String, NodeCmd)] -> Maybe NodeCmd
forall a b. (a -> b) -> a -> b
$ (NodeCmd -> (String, NodeCmd)) -> [NodeCmd] -> [(String, NodeCmd)]
forall a b. (a -> b) -> [a] -> [b]
map (\ a :: NodeCmd
a -> (NodeCmd -> String
showNodeCmd NodeCmd
a, NodeCmd
a)) [NodeCmd]
nodeCmds of
                  Just nc :: NodeCmd
nc -> NodeCommand -> IO NodeCommand
forall (m :: * -> *) a. Monad m => a -> m a
return (NodeCommand -> IO NodeCommand) -> NodeCommand -> IO NodeCommand
forall a b. (a -> b) -> a -> b
$ NodeCmd -> NodeCommand
NcCmd NodeCmd
nc
                  _ -> String -> IO NodeCommand
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> IO NodeCommand) -> String -> IO NodeCommand
forall a b. (a -> b) -> a -> b
$ "unknown node command '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
cmd String -> ShowS
forall a. [a] -> [a] -> [a]
++ "' "
              -- call (the only) command upon a single edge
              (Nothing, Just edIri :: String
edIri) -> case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> String -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ShowS
getFragOfCode String
edIri of
                Just i :: Int
i -> Query -> IO Query
forall (m :: * -> *) a. Monad m => a -> m a
return (Query -> IO Query) -> Query -> IO Query
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query (Int -> Maybe String -> DGQuery
DGQuery Int
sId Maybe String
forall a. Maybe a
Nothing)
                  (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$ Int -> String -> QueryKind
EdgeQuery Int
i "edge"
                Nothing ->
                  String -> IO Query
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> IO Query) -> String -> IO Query
forall a b. (a -> b) -> a -> b
$ "failed to read edgeId from edgeIRI: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
edIri
              -- call of global command
              _ -> Query -> IO Query
forall (m :: * -> *) a. Monad m => a -> m a
return (Query -> IO Query) -> Query -> IO Query
forall a b. (a -> b) -> a -> b
$ DGQuery -> QueryKind -> Query
Query (Int -> Maybe String -> DGQuery
DGQuery Int
sId Maybe String
forall a. Maybe a
Nothing) (QueryKind -> Query) -> QueryKind -> Query
forall a b. (a -> b) -> a -> b
$ String -> QueryKind
GlobCmdQuery String
cmd
           IO Query -> (Query -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Query -> IO ResponseReceived
getResponse
      -- fail if request doesn't comply
      _ -> IO ResponseReceived
queryFailure
    {- create failure response if request method is not known
    (should never happen) -}
    _ -> Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> Status -> String -> Response
mkResponse "" Status
status400 ""

parseReasoningParametersEither :: BS.ByteString -> Either String ReasoningParameters
parseReasoningParametersEither :: ByteString -> Either String ReasoningParameters
parseReasoningParametersEither requestBodyBS :: ByteString
requestBodyBS = ByteString -> Either String ReasoningParameters
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode ByteString
requestBodyBS

mSplitOnComma :: Maybe String -> [String]
mSplitOnComma :: Maybe String -> [String]
mSplitOnComma mstr :: Maybe String
mstr = case Maybe String
mstr of
  Nothing -> []
  Just str :: String
str -> Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn ',' String
str

mkMenuResponse :: WebResponse
mkMenuResponse :: WebResponse
mkMenuResponse respond :: Response -> IO ResponseReceived
respond =
  Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> String -> Response
mkOkResponse String
xmlC (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ Element -> String
ppTopElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "menus" [Element]
mkMenus

mkMenus :: [Element]
mkMenus :: [Element]
mkMenus = String -> String -> String -> Element
menuTriple "" "Get menu triples" "menus"
  Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: String -> String -> String -> Element
menuTriple "/DGraph" String
updateS String
updateS
  Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: ((GlobCmd, LibName -> LibEnv -> Result LibEnv) -> Element)
-> [(GlobCmd, LibName -> LibEnv -> Result LibEnv)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ (c :: GlobCmd
c, _) -> String -> String -> String -> Element
menuTriple "/" (GlobCmd -> String
menuTextGlobCmd GlobCmd
c) (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ GlobCmd -> String
cmdlGlobCmd GlobCmd
c)
    [(GlobCmd, LibName -> LibEnv -> Result LibEnv)]
allGlobLibAct
  [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ nc :: String
nc -> String -> String -> String -> Element
menuTriple "/DGraph/DGNode" ("Show " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nc) String
nc) [String]
nodeCommands
  [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [String -> String -> String -> Element
menuTriple "/DGraph/DGLink" "Show edge info" "edge"]

mkFiletypeResponse :: HetcatsOpts -> String -> WebResponse
mkFiletypeResponse :: HetcatsOpts -> String -> WebResponse
mkFiletypeResponse opts :: HetcatsOpts
opts libIri :: String
libIri respond :: Response -> IO ResponseReceived
respond = do
  Either String (Maybe String, Maybe String, FileInfo, String)
res <- IO (Either String (Maybe String, Maybe String, FileInfo, String))
-> IO
     (Either String (Maybe String, Maybe String, FileInfo, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either String (Maybe String, Maybe String, FileInfo, String))
 -> IO
      (Either String (Maybe String, Maybe String, FileInfo, String)))
-> IO
     (Either String (Maybe String, Maybe String, FileInfo, String))
-> IO
     (Either String (Maybe String, Maybe String, FileInfo, String))
forall a b. (a -> b) -> a -> b
$ HetcatsOpts
-> String
-> IO
     (Either String (Maybe String, Maybe String, FileInfo, String))
getContentAndFileType HetcatsOpts
opts String
libIri
  Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case Either String (Maybe String, Maybe String, FileInfo, String)
res of
    Left err :: String
err -> String -> Status -> String -> Response
mkResponse String
textC Status
status422 String
err
    Right (mr :: Maybe String
mr, _, fInfo :: FileInfo
fInfo, _) -> 
      let fn :: String
fn = FileInfo -> String
filePath FileInfo
fInfo in
      case Maybe String
mr of
        Nothing -> String -> Status -> String -> Response
mkResponse String
textC Status
status422 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": unknown file type"
        Just r :: String
r -> String -> String -> Response
mkOkResponse String
textC (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ String
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
r

menuTriple :: String -> String -> String -> Element
menuTriple :: String -> String -> String -> Element
menuTriple q :: String
q d :: String
d c :: String
c = String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "triple"
                [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "xquery" String
q
                , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "displayname" String
d
                , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "command" String
c ]

htmlResponse :: FilePath -> [Element] -> WebResponse
htmlResponse :: String -> [Element] -> WebResponse
htmlResponse path :: String
path listElements :: [Element]
listElements respond :: Response -> IO ResponseReceived
respond = Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> (String -> Response) -> String -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Response
mkOkResponse String
htmlC
  (String -> IO ResponseReceived) -> String -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> String
htmlPageWithTopContent String
path [Element]
listElements

htmlPageWithTopContent :: FilePath -> [Element] -> String
htmlPageWithTopContent :: String -> [Element] -> String
htmlPageWithTopContent path :: String
path listElements :: [Element]
listElements =
  String -> String -> [Element] -> ShowS
htmlPage (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path then "Start Page" else String
path) []
    ([Element]
pageHeader [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ String -> [Element] -> [Element]
pageOptions String
path [Element]
listElements)
    ""

htmlPage :: String -> String -> [Element] -> String -> String
htmlPage :: String -> String -> [Element] -> ShowS
htmlPage title :: String
title javascripts :: String
javascripts body :: [Element]
body rawHtmlPageFooter :: String
rawHtmlPageFooter = String -> ShowS
htmlHead String
title String
javascripts
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" ((Element -> String) -> [Element] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Element -> String
ppElement [Element]
body)
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
htmlWrapBottomContent String
rawHtmlPageFooter
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
htmlFoot

htmlHead :: String -> String -> String
htmlHead :: String -> ShowS
htmlHead title :: String
title javascript :: String
javascript =
  "<!DOCTYPE html>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "<html lang=\"en\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "  <head>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <meta charset=\"utf-8\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <meta content=\"width=device-width,initial-scale=1,shrink-to-fit=no\" name=\"viewport\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <meta content=\"#000000\" name=\"theme-color\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <meta name=\"robots\" content=\"noindex,nofollow\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <title>Hets, the DOLiator - " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
title String -> ShowS
forall a. [a] -> [a] -> [a]
++ "</title>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <!-- Semantic UI stylesheet -->\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <style type=\"text/css\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
semanticUiCss String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    </style>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <!-- Hets stylesheet -->\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <style type=\"text/css\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hetsCss String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    </style>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "  </head>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "  <body>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <!-- jQuery -->\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <script type=\"text/javascript\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
jQueryJs String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    </script>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <!-- Semantic UI Javascript -->\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <script type=\"text/javascript\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
semanticUiJs String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    </script>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <!-- Static Hets Javascript -->\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <script type=\"text/javascript\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hetsJs String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    </script>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <!-- Dynamic Hets Javascript -->\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <script type=\"text/javascript\">\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
javascript String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    </script>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "    <div class=\"ui left aligned doubling stackable centered relaxed grid container\">\n"

htmlWrapBottomContent :: String -> String
htmlWrapBottomContent :: ShowS
htmlWrapBottomContent content :: String
content =
  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
content then "" else
    "      <div class=\"ui segment pushable left aligned\" style=\"overflow: auto;\">\n"
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
content
    String -> ShowS
forall a. [a] -> [a] -> [a]
++ "       </div>\n"

htmlFoot :: String
htmlFoot :: String
htmlFoot =
  "    </div>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "  </body>\n"
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ "</html>\n"

pageHeader :: [Element]
pageHeader :: [Element]
pageHeader =
  [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h1" "Hets, the DOLiator"
  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
      Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui text container raised segment center aligned") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
      String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "p" "Welcome to DOLiator, the web interface to our implementation of the Distributed Ontology, Modeling and Specification Language (DOL)"
                  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui horizontal list") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
                      [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "target" "_blank") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "item") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
aRef "http://dol-omg.org/" "DOL Homepage"
                      , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "target" "_blank") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "item") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
aRef "http://hets.eu/" "Hets Homepage"
                      , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "item") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
aRef "mailto:hets-devel@informatik.uni-bremen.de" "Contact"
                      ]
                  ]
  ]

pageOptions :: String -> [Element] -> [Element]
pageOptions :: String -> [Element] -> [Element]
pageOptions path :: String
path listElements :: [Element]
listElements =
  [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
      Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui relaxed grid container segment") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
        [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row centered") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
            String -> String -> Element
forall t. Node t => String -> t -> Element
unode "p" "Select a local DOL file as library or enter a DOL specification in the text area or choose one of the minimal examples from the right hand side and press \"Submit\"."
        , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "three column row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
            [ Element
pageOptionsFile
            , Bool -> [Element] -> Element
pageOptionsExamples (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
path) [Element]
listElements
            ]
        ]
  ]

pageOptionsFile :: Element
pageOptionsFile :: Element
pageOptionsFile =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui container ten wide column left aligned") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
    Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" Element
pageOptionsFileForm


pageOptionsExamples :: Bool -> [Element] -> Element
pageOptionsExamples :: Bool -> [Element] -> Element
pageOptionsExamples moreExamplesAreOpen :: Bool
moreExamplesAreOpen listElements :: [Element]
listElements =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui container six wide column left aligned") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
    [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h4" "Minimal Examples"
    , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui list") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
        ((String, String, String) -> Element)
-> [(String, String, String)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ (elementName :: String
elementName, inputType :: String
inputType, exampleText :: String
exampleText) ->
              Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "item") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
                [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "class" "insert-example-into-user-input-text"
                          , String -> String -> Attr
mkAttr "data-text" String
exampleText
                          , String -> String -> Attr
mkAttr "data-input-type" String
inputType
                          ] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "span" String
elementName
              ) [ ("DOL", "dol", String
Examples.dol)
                , ("CASL", "casl", String
Examples.casl)
                , ("OWL", "owl", String
Examples.owl)
                , ("CLIF", "clif", String
Examples.clif)
                , ("Propositional", "dol", String
Examples.propositional)
                , ("RDF", "rdf", String
Examples.rdf)
                , ("TPTP", "tptp", String
Examples.tptp)
                , ("HasCASL", "dol", String
Examples.hascasl)
                , ("Modal", "dol", String
Examples.modal)
                ]
    , Bool -> [Element] -> Element
pageMoreExamples Bool
moreExamplesAreOpen [Element]
listElements
    ]

pageOptionsFileForm :: Element
pageOptionsFileForm :: Element
pageOptionsFileForm = Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "id" "user-file-form") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
  String -> [Element] -> Element
mkForm "/" [ Element
pageOptionsFilePickerInput
             , String -> Element
horizontalDivider "OR"
             , Element
pageOptionsFileTextArea
             , [Attr] -> Element -> Element
add_attrs [String -> String -> Attr
mkAttr "class" "ui relaxed grid", String -> String -> Attr
mkAttr "style" "margin-top: 1em"] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
                 [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "six wide column") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" Element
inputTypeDropDown
                 , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ten wide column right aligned") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" Element
submitButton
                 ]
             ]

inputTypeDropDown :: Element
inputTypeDropDown :: Element
inputTypeDropDown = String
-> String -> Maybe String -> [(String, String, [Attr])] -> Element
singleSelectionDropDown
  "Input Type of File or Text Field"
  "input-type"
  (String -> Maybe String
forall a. a -> Maybe a
Just "user-file-input-type")
  ( ("", "[Try to determine automatically]", [])
    (String, String, [Attr])
-> [(String, String, [Attr])] -> [(String, String, [Attr])]
forall a. a -> [a] -> [a]
: (InType -> (String, String, [Attr]))
-> [InType] -> [(String, String, [Attr])]
forall a b. (a -> b) -> [a] -> [b]
map (\ inType :: InType
inType -> (InType -> String
forall a. Show a => a -> String
show InType
inType, InType -> String
forall a. Show a => a -> String
show InType
inType, [])) [InType]
plainInTypes
  )

singleSelectionDropDown :: String -> String -> Maybe String -> [(String, String, [Attr])] -> Element
singleSelectionDropDown :: String
-> String -> Maybe String -> [(String, String, [Attr])] -> Element
singleSelectionDropDown label :: String
label inputName :: String
inputName htmlIdM :: Maybe String
htmlIdM options :: [(String, String, [Attr])]
options = String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
   [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui sub header") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "div" String
label
   , [Attr] -> Element -> Element
add_attrs ( String -> String -> Attr
mkAttr "name" String
inputName
               Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: [Attr] -> (String -> [Attr]) -> Maybe String -> [Attr]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\ htmlId :: String
htmlId -> [String -> String -> Attr
mkAttr "id" String
htmlId]) Maybe String
htmlIdM
               ) (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "select" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
         ((String, String, [Attr]) -> Element)
-> [(String, String, [Attr])] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ (optionValue :: String
optionValue, optionLabel :: String
optionLabel, attributes :: [Attr]
attributes) ->
               [Attr] -> Element -> Element
add_attrs (String -> String -> Attr
mkAttr "value" String
optionValue Attr -> [Attr] -> [Attr]
forall a. a -> [a] -> [a]
: [Attr]
attributes) (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
                 String -> String -> Element
forall t. Node t => String -> t -> Element
unode "option" String
optionLabel
             ) [(String, String, [Attr])]
options
   ]

checkboxElement :: String -> [Attr] -> Element
checkboxElement :: String -> [Attr] -> Element
checkboxElement label :: String
label attributes :: [Attr]
attributes =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "four wide column") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
    Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui checkbox") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
      [ [Attr] -> Element -> Element
add_attrs
          ([ String -> String -> Attr
mkAttr "type" "checkbox"
          , String -> String -> Attr
mkAttr "tabindex" "0"
          , String -> String -> Attr
mkAttr "class" "hidden"
          ] [Attr] -> [Attr] -> [Attr]
forall a. [a] -> [a] -> [a]
++ [Attr]
attributes) (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "input" ""
      , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "label" String
label
      ]

pageOptionsFileTextArea :: Element
pageOptionsFileTextArea :: Element
pageOptionsFileTextArea = [Attr] -> Element -> Element
add_attrs
  [ String -> String -> Attr
mkAttr "cols" "68"
  , String -> String -> Attr
mkAttr "rows" "22"
  , String -> String -> Attr
mkAttr "name" "content"
  , String -> String -> Attr
mkAttr "id" "user-input-text"
  , String -> String -> Attr
mkAttr "style" "font-family: monospace;"
  ] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "textarea" ""

pageOptionsFilePickerInput :: Element
pageOptionsFilePickerInput :: Element
pageOptionsFilePickerInput = String -> String -> String -> Element
filePickerInputElement "file" "file" "Choose File..."

pageOptionsFormat :: String -> String -> Element
pageOptionsFormat :: String -> String -> Element
pageOptionsFormat delimiter :: String
delimiter path :: String
path =
  let defaultFormat :: String
defaultFormat = "default"
  in  String -> [Element] -> Element
dropDownElement "Output Format" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
        (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ f :: String
f ->
              String -> String -> Element
aRef (if String
f String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
defaultFormat then "/" String -> ShowS
</> String
path else "/" String -> ShowS
</> String
path String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
delimiter String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
f) String
f
            ) (String
defaultFormat String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
displayTypes)

filePickerInputElement :: String -> String -> String -> Element
filePickerInputElement :: String -> String -> String -> Element
filePickerInputElement idArgument :: String
idArgument nameArgument :: String
nameArgument title :: String
title =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "field") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
    Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui fluid file input action") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
      [ [Attr] -> Element -> Element
add_attrs [String -> String -> Attr
mkAttr "type" "text", String -> String -> Attr
mkAttr "readonly" "true"] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "input" ""
      , [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "type" "file"
                  , String -> String -> Attr
mkAttr "id" String
idArgument
                  , String -> String -> Attr
mkAttr "name" String
nameArgument
                  , String -> String -> Attr
mkAttr "autocomplete" "off"
                  ] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "input" ""
      , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui button") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "div" String
title
      ]

dropDownElement :: String -> [Element] -> Element
dropDownElement :: String -> [Element] -> Element
dropDownElement title :: String
title items :: [Element]
items =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui dropdown button") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
    [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "text") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "div" String
title
    , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "dropdown icon") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "i" ""
    , [Element] -> Element
dropDownSubMenu [Element]
items
    ]

linkButtonElement :: String -> String -> Element
linkButtonElement :: String -> String -> Element
linkButtonElement address :: String
address label :: String
label =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui button") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
aRef String
address String
label

htmlRow :: Element -> Element
htmlRow :: Element -> Element
htmlRow = Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> (Element -> Element) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div"

dropDownToLevelsElement :: String -> [(Element, [Element])] -> Element
dropDownToLevelsElement :: String -> [(Element, [Element])] -> Element
dropDownToLevelsElement title :: String
title twoLeveledItems :: [(Element, [Element])]
twoLeveledItems =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui dropdown button") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
    [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "text") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "div" String
title
    , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "dropdown icon") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "i" ""
    , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "menu") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
        ((Element, [Element]) -> Element)
-> [(Element, [Element])] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ (label :: Element
label, items :: [Element]
items) ->
              Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "item") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
                (
                  ( if [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
items
                    then []
                    else [Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "dropdown icon") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "i" ""]
                  )
                  [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "text") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" Element
label]
                  [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ if [Element] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Element]
items then [] else [[Element] -> Element
dropDownSubMenu [Element]
items]
                )
            ) [(Element, [Element])]
twoLeveledItems
    ]

dropDownSubMenu :: [Element] -> Element
dropDownSubMenu :: [Element] -> Element
dropDownSubMenu items :: [Element]
items =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "menu") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
    (Element -> Element) -> [Element] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "item")) [Element]
items

pageMoreExamples :: Bool -> [Element] -> Element
pageMoreExamples :: Bool -> [Element] -> Element
pageMoreExamples isOpen :: Bool
isOpen listElements :: [Element]
listElements =
  let activeClass :: String
activeClass = if Bool
isOpen then "active " else "" in
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui ten wide column container left aligned") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
    Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui styled accordion") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
      [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" (String
activeClass String -> ShowS
forall a. [a] -> [a] -> [a]
++ "title")) (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
          [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "dropdown icon") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "i" ""
          , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "span" "More Examples"
          ]
      , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" (String
activeClass String -> ShowS
forall a. [a] -> [a] -> [a]
++ "content")) (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
          Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "transistion hidden") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
            String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "ul" [Element]
listElements
      ]

horizontalDivider :: String -> Element
horizontalDivider :: String -> Element
horizontalDivider label :: String
label =
  Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui horizontal divider") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "div" String
label

mkResponse :: String -> Status -> String -> Response
mkResponse :: String -> Status -> String -> Response
mkResponse ty :: String
ty st :: Status
st = Status -> RequestHeaders -> ByteString -> Response
responseLBS Status
st
  (if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ty then [] else
#ifdef HTTPTYPES
      [headerContentType $ B8.pack ty]
#else
      [(CI ByteString
hContentType, String -> ByteString
B8.pack String
ty)]
#endif
  ) (ByteString -> Response)
-> (String -> ByteString) -> String -> Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
BS.pack (String -> ByteString) -> ShowS -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
encodeString

mkOkResponse :: String -> String -> Response
mkOkResponse :: String -> String -> Response
mkOkResponse ty :: String
ty = String -> Status -> String -> Response
mkResponse String
ty Status
status200

addSess :: Cache -> Session -> IO Int
addSess :: IORef (IntMap Session, Map [String] Session) -> Session -> IO Int
addSess sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef s :: Session
s = do
  let k :: Int
k = Session -> Int
sessKey Session
s
  IORef (IntMap Session, Map [String] Session)
-> ((IntMap Session, Map [String] Session)
    -> ((IntMap Session, Map [String] Session), Int))
-> IO Int
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IntMap Session, Map [String] Session)
sessRef (((IntMap Session, Map [String] Session)
  -> ((IntMap Session, Map [String] Session), Int))
 -> IO Int)
-> ((IntMap Session, Map [String] Session)
    -> ((IntMap Session, Map [String] Session), Int))
-> IO Int
forall a b. (a -> b) -> a -> b
$ \ (m :: IntMap Session
m, lm :: Map [String] Session
lm) ->
       ((Int -> Session -> IntMap Session -> IntMap Session
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k Session
s IntMap Session
m, [String] -> Session -> Map [String] Session -> Map [String] Session
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert (Session -> [String]
sessPath Session
s) Session
s Map [String] Session
lm), Int
k)

cleanUpCache :: Cache -> IO ()
cleanUpCache :: IORef (IntMap Session, Map [String] Session) -> IO ()
cleanUpCache sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef = do
  let mSize :: Int
mSize = 60
  UTCTime
time <- IO UTCTime
getCurrentTime
  IORef (IntMap Session, Map [String] Session)
-> ((IntMap Session, Map [String] Session)
    -> ((IntMap Session, Map [String] Session), ()))
-> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IntMap Session, Map [String] Session)
sessRef (((IntMap Session, Map [String] Session)
  -> ((IntMap Session, Map [String] Session), ()))
 -> IO ())
-> ((IntMap Session, Map [String] Session)
    -> ((IntMap Session, Map [String] Session), ()))
-> IO ()
forall a b. (a -> b) -> a -> b
$ \ (m :: IntMap Session
m, lm :: Map [String] Session
lm) ->
    if Map [String] Session -> Int
forall k a. Map k a -> Int
Map.size Map [String] Session
lm Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
mSize then ((IntMap Session
m, Map [String] Session
lm), ()) else
    let ss :: [Session]
ss = UTCTime -> Int -> IntMap Session -> [Session]
cleanUpSessions UTCTime
time Int
mSize IntMap Session
m
    in (([(Int, Session)] -> IntMap Session
forall a. [(Int, a)] -> IntMap a
IntMap.fromList ([(Int, Session)] -> IntMap Session)
-> [(Int, Session)] -> IntMap Session
forall a b. (a -> b) -> a -> b
$ (Session -> (Int, Session)) -> [Session] -> [(Int, Session)]
forall a b. (a -> b) -> [a] -> [b]
map (\ s :: Session
s -> (Session -> Int
sessKey Session
s, Session
s)) [Session]
ss
       , [([String], Session)] -> Map [String] Session
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([([String], Session)] -> Map [String] Session)
-> [([String], Session)] -> Map [String] Session
forall a b. (a -> b) -> a -> b
$ (Session -> ([String], Session))
-> [Session] -> [([String], Session)]
forall a b. (a -> b) -> [a] -> [b]
map (\ s :: Session
s -> (Session -> [String]
sessPath Session
s, Session
s)) [Session]
ss), ())
  where
    cleanUpSessions :: UTCTime -> Int -> IntMap.IntMap Session -> [Session]
    cleanUpSessions :: UTCTime -> Int -> IntMap Session -> [Session]
cleanUpSessions time :: UTCTime
time maxSize :: Int
maxSize =
      ([Session], [Session]) -> [Session]
unifySessionLists (([Session], [Session]) -> [Session])
-> (IntMap Session -> ([Session], [Session]))
-> IntMap Session
-> [Session]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Session], [Session]) -> ([Session], [Session])
dropCleanables (([Session], [Session]) -> ([Session], [Session]))
-> (IntMap Session -> ([Session], [Session]))
-> IntMap Session
-> ([Session], [Session])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Session -> ([Session], [Session])
sessionCleanableLists
      where
        sessionSort :: [Session] -> [Session]
        sessionSort :: [Session] -> [Session]
sessionSort = (Session -> Session -> Ordering) -> [Session] -> [Session]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (UTCTime -> Session -> Session -> Ordering
cmpSess UTCTime
time)

        sessionCleanableLists :: IntMap.IntMap Session -> ([Session], [Session])
        sessionCleanableLists :: IntMap Session -> ([Session], [Session])
sessionCleanableLists =
          (Session -> Bool) -> [Session] -> ([Session], [Session])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition Session -> Bool
sessCleanable ([Session] -> ([Session], [Session]))
-> (IntMap Session -> [Session])
-> IntMap Session
-> ([Session], [Session])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Session] -> [Session]
sessionSort ([Session] -> [Session])
-> (IntMap Session -> [Session]) -> IntMap Session -> [Session]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntMap Session -> [Session]
forall a. IntMap a -> [a]
IntMap.elems

        dropCleanables :: ([Session], [Session]) -> ([Session], [Session])
        dropCleanables :: ([Session], [Session]) -> ([Session], [Session])
dropCleanables (cleanables :: [Session]
cleanables, uncleanables :: [Session]
uncleanables) =
          (Int -> [Session] -> [Session]
forall a. Int -> [a] -> [a]
drop (Int
maxSize Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` 2) [Session]
cleanables, [Session]
uncleanables)

        unifySessionLists :: ([Session], [Session]) -> [Session]
        unifySessionLists :: ([Session], [Session]) -> [Session]
unifySessionLists = [Session] -> [Session]
sessionSort ([Session] -> [Session])
-> (([Session], [Session]) -> [Session])
-> ([Session], [Session])
-> [Session]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Session] -> [Session] -> [Session])
-> ([Session], [Session]) -> [Session]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Session] -> [Session] -> [Session]
forall a. [a] -> [a] -> [a]
(++)

cmpSess :: UTCTime -> Session -> Session -> Ordering
cmpSess :: UTCTime -> Session -> Session -> Ordering
cmpSess curTime :: UTCTime
curTime =
  let f :: Session -> (Int, NominalDiffTime)
f s :: Session
s = let
        l :: UTCTime
l = Session -> UTCTime
lastAccess Session
s
        b :: UTCTime
b = Session -> UTCTime
sessStart Session
s
        d2 :: Day
d2 = UTCTime -> Day
utctDay UTCTime
curTime
        s2 :: DiffTime
s2 = UTCTime -> DiffTime
utctDayTime UTCTime
curTime
        d1 :: Day
d1 = UTCTime -> Day
utctDay UTCTime
l
        s1 :: DiffTime
s1 = UTCTime -> DiffTime
utctDayTime UTCTime
l
        u :: Int
u = Session -> Int
usage Session
s
        in if Int
u Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 1 Bool -> Bool -> Bool
&& Day
d1 Day -> Day -> Bool
forall a. Eq a => a -> a -> Bool
== Day
d2 Bool -> Bool -> Bool
&& DiffTime
s2 DiffTime -> DiffTime -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> DiffTime
secondsToDiffTime 3600 DiffTime -> DiffTime -> DiffTime
forall a. Num a => a -> a -> a
+ DiffTime
s1
           then (Int
u Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 100, UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
l UTCTime
curTime)
           else (Int
u, UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
b UTCTime
l)
  in ((Int, NominalDiffTime) -> (Int, NominalDiffTime) -> Ordering)
-> (Session -> (Int, NominalDiffTime))
-> Session
-> Session
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on (Int, NominalDiffTime) -> (Int, NominalDiffTime) -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Session -> (Int, NominalDiffTime)
f

addNewSess :: Cache -> Session -> IO Int
addNewSess :: IORef (IntMap Session, Map [String] Session) -> Session -> IO Int
addNewSess sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef sess :: Session
sess = do
  IORef (IntMap Session, Map [String] Session) -> IO ()
cleanUpCache IORef (IntMap Session, Map [String] Session)
sessRef
  Int
k <- IO Int
randomKey
  let s :: Session
s = Session
sess { sessKey :: Int
sessKey = Int
k }
  IORef (IntMap Session, Map [String] Session) -> Session -> IO Int
addSess IORef (IntMap Session, Map [String] Session)
sessRef Session
s

nextSess :: LibEnv -> Session -> Cache -> Int -> IO Session
nextSess :: LibEnv
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
nextSess newLib :: LibEnv
newLib =
  String
-> (Session -> Session)
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
modifySessionAndCache "nextSess" (\ s :: Session
s -> Session
s { sessLibEnv :: LibEnv
sessLibEnv = LibEnv
newLib })

makeSessCleanable :: Session -> Cache -> Int -> IO Session
makeSessCleanable :: Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
makeSessCleanable =
  String
-> (Session -> Session)
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
modifySessionAndCache "makeSessCleanable" (\ s :: Session
s -> Session
s { sessCleanable :: Bool
sessCleanable = Bool
True })

modifySessionAndCache :: String -> (Session -> Session) -> Session -> Cache
                      -> Int -> IO Session
modifySessionAndCache :: String
-> (Session -> Session)
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
modifySessionAndCache errorMessage :: String
errorMessage f :: Session -> Session
f sess :: Session
sess sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef k :: Int
k =
  if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 then Session -> IO Session
forall (m :: * -> *) a. Monad m => a -> m a
return Session
sess else
    IORef (IntMap Session, Map [String] Session)
-> ((IntMap Session, Map [String] Session)
    -> ((IntMap Session, Map [String] Session), Session))
-> IO Session
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef (IntMap Session, Map [String] Session)
sessRef
      (\ (m :: IntMap Session
m, lm :: Map [String] Session
lm) -> case Int -> IntMap Session -> Maybe Session
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap Session
m of
        Nothing -> String -> ((IntMap Session, Map [String] Session), Session)
forall a. HasCallStack => String -> a
error String
errorMessage
        Just s :: Session
s -> let newSess :: Session
newSess = Session -> Session
f Session
s
                  in ((Int -> Session -> IntMap Session -> IntMap Session
forall a. Int -> a -> IntMap a -> IntMap a
IntMap.insert Int
k Session
newSess IntMap Session
m, Map [String] Session
lm), Session
newSess))


ppDGraph :: DGraph -> Maybe PrettyType -> ResultT IO (String, String)
ppDGraph :: DGraph -> Maybe PrettyType -> ResultT IO (String, String)
ppDGraph dg :: DGraph
dg mt :: Maybe PrettyType
mt = let ga :: GlobalAnnos
ga = DGraph -> GlobalAnnos
globalAnnos DGraph
dg in case DGraph -> Maybe LIB_DEFN
optLibDefn DGraph
dg of
    Nothing -> String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "parsed LIB-DEFN not avaible"
    Just ld :: LIB_DEFN
ld ->
      let d :: Doc
d = LogicGraph -> LIB_DEFN -> Doc
forall a. PrettyLG a => LogicGraph -> a -> Doc
prettyLG LogicGraph
logicGraph LIB_DEFN
ld
          latex :: String
latex = Maybe Int -> Doc -> String
renderLatex Maybe Int
forall a. Maybe a
Nothing (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ GlobalAnnos -> Doc -> Doc
toLatex GlobalAnnos
ga Doc
d
      in case Maybe PrettyType
mt of
      Just pty :: PrettyType
pty -> case PrettyType
pty of
        PrettyXml -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return
          (String
xmlC, Element -> String
ppTopElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ LogicGraph -> GlobalAnnos -> LIB_DEFN -> Element
xmlLibDefn LogicGraph
logicGraph GlobalAnnos
ga LIB_DEFN
ld)
        PrettyAscii _ -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
textC, GlobalAnnos -> Doc -> String
renderText GlobalAnnos
ga Doc
d String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n")
        PrettyHtml -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
htmlC, GlobalAnnos -> Doc -> String
renderHtml GlobalAnnos
ga Doc
d)
        PrettyLatex _ -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ("application/latex", String
latex)
      Nothing -> IO (String, String) -> ResultT IO (String, String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (String, String) -> ResultT IO (String, String))
-> IO (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ do
         String
tmpDir <- IO String
getTemporaryDirectory
         String
tmpFile <- String -> String -> String -> IO String
writeTempFile (String
latexHeader String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
latex String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
latexFooter)
           String
tmpDir "temp.tex"
         (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ s :: String
s -> do
            let sty :: ShowS
sty = (String -> ShowS
</> "hetcasl.sty")
                f :: String
f = ShowS
sty String
s
            Bool
ex <- String -> IO Bool
doesFileExist String
f
            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
ex (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
copyFile String
f (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ShowS
sty String
tmpDir)
              [ "utils", "Hets/utils"
              , "/home/www.informatik.uni-bremen.de/cofi/hets-tmp" ]
         String -> IO (String, String) -> IO (String, String)
forall a. String -> IO a -> IO a
withinDirectory String
tmpDir (IO (String, String) -> IO (String, String))
-> IO (String, String) -> IO (String, String)
forall a b. (a -> b) -> a -> b
$ do
           (ex1 :: ExitCode
ex1, out1 :: String
out1, err1 :: String
err1) <- String -> [String] -> String -> IO (ExitCode, String, String)
executeProcess "pdflatex" [String
tmpFile] ""
           (ex2 :: ExitCode
ex2, out2 :: String
out2, err2 :: String
err2) <- String -> [String] -> String -> IO (ExitCode, String, String)
executeProcess "pdflatex" [String
tmpFile] ""
           let pdfFile :: String
pdfFile = String -> ShowS
replaceExtension String
tmpFile "pdf"
           Bool
pdf <- String -> IO Bool
doesFileExist String
pdfFile
           if ExitCode
ex1 ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
&& ExitCode
ex2 ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== ExitCode
ExitSuccess Bool -> Bool -> Bool
&& Bool
pdf then do
             Handle
pdfHdl <- String -> IOMode -> IO Handle
openBinaryFile String
pdfFile IOMode
ReadMode
             String
str <- Handle -> IO String
hGetContents Handle
pdfHdl
             Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn "pdf file too large"
             Handle -> IO ()
hClose Handle
pdfHdl
             (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
pdfC, String
str)
             else (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
textC, "could not create pdf:\n"
                  String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines [String
out1, String
err1, String
out2, String
err2])

-- | Increase the amount how often a library has been accessed.
-- | Returns the analysis library from cache.
increaseUsage :: Cache -> Session -> ResultT IO (Session, Int)
increaseUsage :: IORef (IntMap Session, Map [String] Session)
-> Session -> ResultT IO (Session, Int)
increaseUsage sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef sess :: Session
sess = do
  UTCTime
time <- IO UTCTime -> ResultT IO UTCTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO UTCTime
getCurrentTime
  let s2 :: Session
s2 = Session
sess { usage :: Int
usage = Session -> Int
usage Session
sess Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1, lastAccess :: UTCTime
lastAccess = UTCTime
time }
  Int
k <- IO Int -> ResultT IO Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Int -> ResultT IO Int) -> IO Int -> ResultT IO Int
forall a b. (a -> b) -> a -> b
$ IORef (IntMap Session, Map [String] Session) -> Session -> IO Int
addSess IORef (IntMap Session, Map [String] Session)
sessRef Session
s2
  (Session, Int) -> ResultT IO (Session, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Session
s2, Int
k)

getDGraph :: HetcatsOpts -> Cache -> DGQuery
  -> ResultT IO (Session, Int)
getDGraph :: HetcatsOpts
-> IORef (IntMap Session, Map [String] Session)
-> DGQuery
-> ResultT IO (Session, Int)
getDGraph opts :: HetcatsOpts
opts sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef dgQ :: DGQuery
dgQ = do
  (m :: IntMap Session
m, lm :: Map [String] Session
lm) <- IO (IntMap Session, Map [String] Session)
-> ResultT IO (IntMap Session, Map [String] Session)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (IntMap Session, Map [String] Session)
 -> ResultT IO (IntMap Session, Map [String] Session))
-> IO (IntMap Session, Map [String] Session)
-> ResultT IO (IntMap Session, Map [String] Session)
forall a b. (a -> b) -> a -> b
$ IORef (IntMap Session, Map [String] Session)
-> IO (IntMap Session, Map [String] Session)
forall a. IORef a -> IO a
readIORef IORef (IntMap Session, Map [String] Session)
sessRef
  case DGQuery
dgQ of
    NewDGQuery file :: String
file cmdList :: [String]
cmdList -> do
      let cl :: [GlobCmd]
cl = (String -> Maybe GlobCmd) -> [String] -> [GlobCmd]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\ s :: String
s -> (GlobCmd -> Bool) -> [GlobCmd] -> Maybe GlobCmd
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
s) (String -> Bool) -> (GlobCmd -> String) -> GlobCmd -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobCmd -> String
cmdlGlobCmd)
                  ([GlobCmd] -> Maybe GlobCmd) -> [GlobCmd] -> Maybe GlobCmd
forall a b. (a -> b) -> a -> b
$ ((GlobCmd, LibName -> LibEnv -> Result LibEnv) -> GlobCmd)
-> [(GlobCmd, LibName -> LibEnv -> Result LibEnv)] -> [GlobCmd]
forall a b. (a -> b) -> [a] -> [b]
map (GlobCmd, LibName -> LibEnv -> Result LibEnv) -> GlobCmd
forall a b. (a, b) -> a
fst [(GlobCmd, LibName -> LibEnv -> Result LibEnv)]
allGlobLibAct) [String]
cmdList
      -- use the file path if file is an url to a web ressource
      -- otherwise if file is a local file use the absolute path instead
      String
absolutPathToFile <- if String -> Bool
checkUri String
file
                             then String -> ResultT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file
                             else do
                               Bool
fileExists <- IO Bool -> ResultT IO Bool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Bool -> ResultT IO Bool) -> IO Bool -> ResultT IO Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
file
                               if Bool
fileExists
                                 then IO String -> ResultT IO String
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO String -> ResultT IO String) -> IO String -> ResultT IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String -> IO String
forall a. a -> IO a -> IO a
catchIOException String
file (IO String -> IO String) -> IO String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> IO String
makeAbsolute String
file
                                 else String -> ResultT IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
file
      Either String (Maybe String, Maybe String, FileInfo, String)
mf <- IO (Either String (Maybe String, Maybe String, FileInfo, String))
-> ResultT
     IO (Either String (Maybe String, Maybe String, FileInfo, String))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either String (Maybe String, Maybe String, FileInfo, String))
 -> ResultT
      IO (Either String (Maybe String, Maybe String, FileInfo, String)))
-> IO
     (Either String (Maybe String, Maybe String, FileInfo, String))
-> ResultT
     IO (Either String (Maybe String, Maybe String, FileInfo, String))
forall a b. (a -> b) -> a -> b
$ HetcatsOpts
-> String
-> IO
     (Either String (Maybe String, Maybe String, FileInfo, String))
getContentAndFileType HetcatsOpts
opts String
absolutPathToFile
      case Either String (Maybe String, Maybe String, FileInfo, String)
mf of
        Left err :: String
err -> String -> ResultT IO (Session, Int)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
        Right (_, mh :: Maybe String
mh, f :: FileInfo
f, cont :: String
cont) -> case Maybe String
mh of
          Nothing -> String -> ResultT IO (Session, Int)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (Session, Int))
-> String -> ResultT IO (Session, Int)
forall a b. (a -> b) -> a -> b
$ "could determine checksum for: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
file
          Just h :: String
h -> let q :: [String]
q = String
absolutPathToFile String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
h String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
cmdList in
            case [String] -> Map [String] Session -> Maybe Session
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup [String]
q Map [String] Session
lm of
            Just sess :: Session
sess -> IORef (IntMap Session, Map [String] Session)
-> Session -> ResultT IO (Session, Int)
increaseUsage IORef (IntMap Session, Map [String] Session)
sessRef Session
sess -- Return result from cache.
            Nothing -> do
              (ln :: LibName
ln, le1 :: LibEnv
le1) <- if HetcatsOpts -> String -> String -> Bool
isDgXmlFile HetcatsOpts
opts (FileInfo -> String
filePath FileInfo
f) String
cont
                then HetcatsOpts -> String -> LibEnv -> ResultT IO (LibName, LibEnv)
readDGXmlR HetcatsOpts
opts (FileInfo -> String
filePath FileInfo
f) LibEnv
forall k a. Map k a
Map.empty
                else LogicGraph
-> HetcatsOpts
-> LNS
-> LibEnv
-> DGraph
-> String
-> ResultT IO (LibName, LibEnv)
anaSourceFile LogicGraph
logicGraph HetcatsOpts
opts
                  { outputToStdout :: Bool
outputToStdout = Bool
False }
                  LNS
forall a. Set a
Set.empty LibEnv
emptyLibEnv DGraph
emptyDG String
absolutPathToFile
              LibEnv
le2 <- (LibEnv -> GlobCmd -> ResultT IO LibEnv)
-> LibEnv -> [GlobCmd] -> ResultT IO LibEnv
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (\ e :: LibEnv
e c :: GlobCmd
c -> Result LibEnv -> ResultT IO LibEnv
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR
                  (Result LibEnv -> ResultT IO LibEnv)
-> Result LibEnv -> ResultT IO LibEnv
forall a b. (a -> b) -> a -> b
$ Maybe (LibName -> LibEnv -> Result LibEnv)
-> LibName -> LibEnv -> Result LibEnv
forall a. HasCallStack => Maybe a -> a
fromJust (GlobCmd
-> [(GlobCmd, LibName -> LibEnv -> Result LibEnv)]
-> Maybe (LibName -> LibEnv -> Result LibEnv)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup GlobCmd
c [(GlobCmd, LibName -> LibEnv -> Result LibEnv)]
allGlobLibAct) LibName
ln LibEnv
e) LibEnv
le1 [GlobCmd]
cl
              UTCTime
time <- IO UTCTime -> ResultT IO UTCTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO UTCTime
getCurrentTime
              let sess :: Session
sess = Session :: LibEnv
-> LibName
-> [String]
-> Int
-> UTCTime
-> UTCTime
-> Int
-> Bool
-> Session
Session
                    { sessLibEnv :: LibEnv
sessLibEnv = LibEnv
le2
                    , sessLibName :: LibName
sessLibName = LibName
ln
                    , sessPath :: [String]
sessPath = [String]
q
                    , sessKey :: Int
sessKey = 0  -- to be updated by addNewSess
                    , sessStart :: UTCTime
sessStart = UTCTime
time
                    , lastAccess :: UTCTime
lastAccess = UTCTime
time
                    , usage :: Int
usage = 1
                    , sessCleanable :: Bool
sessCleanable = Bool
False }
              Int
k <- IO Int -> ResultT IO Int
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Int -> ResultT IO Int) -> IO Int -> ResultT IO Int
forall a b. (a -> b) -> a -> b
$ IORef (IntMap Session, Map [String] Session) -> Session -> IO Int
addNewSess IORef (IntMap Session, Map [String] Session)
sessRef Session
sess
              (Session, Int) -> ResultT IO (Session, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Session
sess, Int
k)
    DGQuery k :: Int
k _ -> case Int -> IntMap Session -> Maybe Session
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
k IntMap Session
m of
      Nothing -> String -> ResultT IO (Session, Int)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "unknown development graph"
      Just sess :: Session
sess -> IORef (IntMap Session, Map [String] Session)
-> Session -> ResultT IO (Session, Int)
increaseUsage IORef (IntMap Session, Map [String] Session)
sessRef Session
sess

getSVG :: String -> String -> DGraph -> ResultT IO String
getSVG :: String -> String -> DGraph -> ResultT IO String
getSVG title :: String
title url :: String
url dg :: DGraph
dg = do
        (exCode :: ExitCode
exCode, out :: String
out, err :: String
err) <- IO (ExitCode, String, String)
-> ResultT IO (ExitCode, String, String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (ExitCode, String, String)
 -> ResultT IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
-> ResultT IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String -> IO (ExitCode, String, String)
executeProcess "dot" ["-Tsvg"]
          (String -> IO (ExitCode, String, String))
-> String -> IO (ExitCode, String, String)
forall a b. (a -> b) -> a -> b
$ String -> Bool -> String -> DGraph -> String
dotGraph String
title Bool
False String
url DGraph
dg
        case ExitCode
exCode of
          ExitSuccess -> Result String -> ResultT IO String
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result String -> ResultT IO String)
-> Result String -> ResultT IO String
forall a b. (a -> b) -> a -> b
$ DGraph -> String -> Result String
extractSVG DGraph
dg String
out
          _ -> String -> ResultT IO String
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err

enrichSVG :: DGraph -> Element -> Element
enrichSVG :: DGraph -> Element -> Element
enrichSVG dg :: DGraph
dg e :: Element
e = DGraph -> Cursor -> Element
processSVG DGraph
dg (Cursor -> Element) -> Cursor -> Element
forall a b. (a -> b) -> a -> b
$ Element -> Cursor
fromElement Element
e

processSVG :: DGraph -> Cursor -> Element
processSVG :: DGraph -> Cursor -> Element
processSVG dg :: DGraph
dg c :: Cursor
c = case Cursor -> Maybe Cursor
nextDF Cursor
c of
  Nothing -> case Cursor -> Content
toTree (Cursor -> Cursor
root Cursor
c) of
    Elem e :: Element
e -> Element
e
    _ -> String -> Element
forall a. HasCallStack => String -> a
error "processSVG"
  Just c2 :: Cursor
c2 -> DGraph -> Cursor -> Element
processSVG DGraph
dg
    (Cursor -> Element) -> Cursor -> Element
forall a b. (a -> b) -> a -> b
$ (Content -> Content) -> Cursor -> Cursor
modifyContent (DGraph -> Content -> Content
addSVGAttribs DGraph
dg) Cursor
c2

nodeAttrib :: DGNodeLab -> String
nodeAttrib :: DGNodeLab -> String
nodeAttrib l :: DGNodeLab
l = let nt :: DGNodeType
nt = DGNodeLab -> DGNodeType
getRealDGNodeType DGNodeLab
l in
  (if DGNodeType -> Bool
isRefType DGNodeType
nt then "Ref" else "")
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if (forall a. SenStatus a (AnyComorphism, BasicProof) -> Bool)
-> DGNodeLab -> Bool
hasSenKind (Bool -> SenStatus a (AnyComorphism, BasicProof) -> Bool
forall a b. a -> b -> a
const Bool
True) DGNodeLab
l then
          (if DGNodeType -> Bool
isProvenNode DGNodeType
nt then "P" else "Unp") String -> ShowS
forall a. [a] -> [a] -> [a]
++ "roven"
          String -> ShowS
forall a. [a] -> [a] -> [a]
++ if DGNodeType -> Bool
isProvenCons DGNodeType
nt then "Cons" else ""
      else "LocallyEmpty")
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ (if DGNodeType -> Bool
isInternalSpec DGNodeType
nt then "Internal" else "")
  String -> ShowS
forall a. [a] -> [a] -> [a]
++ if DGNodeLab -> Bool
labelHasHiding DGNodeLab
l then "HasIngoingHidingLink" else ""

edgeAttrib :: DGLinkLab -> String
edgeAttrib :: DGLinkLab -> String
edgeAttrib l :: DGLinkLab
l = Doc -> String
forall a. Show a => a -> String
show (DGLinkType -> Doc
forall a. Pretty a => a -> Doc
pretty (DGLinkType -> Doc) -> DGLinkType -> Doc
forall a b. (a -> b) -> a -> b
$ DGLinkLab -> DGLinkType
dgl_type DGLinkLab
l) String -> ShowS
forall a. [a] -> [a] -> [a]
++
  if DGLinkLab -> Bool
dglPending DGLinkLab
l then "IncompleteProofChain" else ""

addSVGAttribs :: DGraph -> Content -> Content
addSVGAttribs :: DGraph -> Content -> Content
addSVGAttribs dg :: DGraph
dg c :: Content
c = case Content
c of
  Elem e :: Element
e -> case String -> Element -> Maybe String
forall (m :: * -> *). MonadFail m => String -> Element -> m String
getAttrVal "id" Element
e of
    Just istr :: String
istr | String -> Bool
isNat String
istr -> let i :: Int
i = String -> Int
forall a. Read a => String -> a
read String
istr in
      case String -> Element -> Maybe String
forall (m :: * -> *). MonadFail m => String -> Element -> m String
getAttrVal "class" Element
e of
      Just "node" -> case Gr DGNodeLab DGLinkLab -> Int -> Maybe DGNodeLab
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (DGraph -> Gr DGNodeLab DGLinkLab
dgBody DGraph
dg) Int
i of
        Nothing -> Content
c
        Just l :: DGNodeLab
l -> Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "type" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> String
nodeAttrib DGNodeLab
l) Element
e
      Just "edge" -> case EdgeId -> DGraph -> [LEdge DGLinkLab]
getDGLinksById (Int -> EdgeId
EdgeId Int
i) DGraph
dg of
        [(_, _, l :: DGLinkLab
l)] ->
           Element -> Content
Elem (Element -> Content) -> Element -> Content
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "type" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ DGLinkLab -> String
edgeAttrib DGLinkLab
l) Element
e
        _ -> Content
c
      _ -> Content
c
    _ -> Content
c
  _ -> Content
c

extractSVG :: DGraph -> String -> Result String
extractSVG :: DGraph -> String -> Result String
extractSVG dg :: DGraph
dg str :: String
str = case String -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc String
str of
  Nothing -> String -> Result String
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "did not recognize svg element"
  Just e :: Element
e -> String -> Result String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Result String) -> String -> Result String
forall a b. (a -> b) -> a -> b
$ Element -> String
showTopElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ DGraph -> Element -> Element
enrichSVG DGraph
dg Element
e

cmpFilePath :: FilePath -> FilePath -> Ordering
cmpFilePath :: String -> String -> Ordering
cmpFilePath f1 :: String
f1 f2 :: String
f2 = case (String -> Bool) -> String -> String -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing String -> Bool
hasTrailingPathSeparator String
f2 String
f1 of
  EQ -> String -> String -> Ordering
forall a. Ord a => a -> a -> Ordering
compare String
f1 String
f2
  c :: Ordering
c -> Ordering
c

getHetsResponse :: HetcatsOpts -> [W.FileInfo BS.ByteString]
  -> Cache -> [String] -> [QueryPair] -> WebResponse
getHetsResponse :: HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> [String]
-> [QueryPair]
-> WebResponse
getHetsResponse opts :: HetcatsOpts
opts updates :: [FileInfo ByteString]
updates sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef pathBits :: [String]
pathBits query :: [QueryPair]
query respond :: Response -> IO ResponseReceived
respond = do
  Result ds :: [Diagnosis]
ds ms :: Maybe (String, String)
ms <- IO (Result (String, String)) -> IO (Result (String, String))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Result (String, String)) -> IO (Result (String, String)))
-> IO (Result (String, String)) -> IO (Result (String, String))
forall a b. (a -> b) -> a -> b
$ ResultT IO (String, String) -> IO (Result (String, String))
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT (ResultT IO (String, String) -> IO (Result (String, String)))
-> ResultT IO (String, String) -> IO (Result (String, String))
forall a b. (a -> b) -> a -> b
$ case [String] -> [QueryPair] -> [String] -> Either String Query
anaUri [String]
pathBits [QueryPair]
query
    ([String] -> Either String Query)
-> [String] -> Either String Query
forall a b. (a -> b) -> a -> b
$ String
updateS String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
globalCommands of
    Left err :: String
err -> String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail String
err
    Right q :: Query
q -> HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> Query
-> Maybe String
-> UsedAPI
-> ProofFormatterOptions
-> ResultT IO (String, String)
getHetsResult HetcatsOpts
opts [FileInfo ByteString]
updates IORef (IntMap Session, Map [String] Session)
sessRef Query
q Maybe String
forall a. Maybe a
Nothing UsedAPI
OldWebAPI
                  ProofFormatterOptions
proofFormatterOptions
  Response -> IO ResponseReceived
respond (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ case Maybe (String, String)
ms of
    Just (t :: String
t, s :: String
s) | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Diagnosis] -> Bool
hasErrors [Diagnosis]
ds -> String -> String -> Response
mkOkResponse String
t String
s
    _ -> String -> Status -> String -> Response
mkResponse String
textC Status
status422 (String -> Response) -> String -> Response
forall a b. (a -> b) -> a -> b
$ Int -> [Diagnosis] -> String
showRelDiags 1 [Diagnosis]
ds

getHetsResult :: HetcatsOpts -> [W.FileInfo BS.ByteString]
  -> Cache -> Query.Query -> Maybe String -> UsedAPI -> ProofFormatterOptions
  -> ResultT IO (String, String)
getHetsResult :: HetcatsOpts
-> [FileInfo ByteString]
-> IORef (IntMap Session, Map [String] Session)
-> Query
-> Maybe String
-> UsedAPI
-> ProofFormatterOptions
-> ResultT IO (String, String)
getHetsResult opts :: HetcatsOpts
opts updates :: [FileInfo ByteString]
updates sessRef :: IORef (IntMap Session, Map [String] Session)
sessRef (Query dgQ :: DGQuery
dgQ qk :: QueryKind
qk) format_ :: Maybe String
format_ api :: UsedAPI
api pfOptions :: ProofFormatterOptions
pfOptions = do
      let semicolon :: ShowS
semicolon n :: String
n = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\ c :: Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ':' then ';' else Char
c) String
n
      let getCom :: String -> AnyComorphism
getCom n :: String
n = case String -> LogicGraph -> Maybe AnyComorphism
forall (m :: * -> *).
MonadFail m =>
String -> LogicGraph -> m AnyComorphism
lookupComorphism (ShowS
semicolon String
n) LogicGraph
logicGraph of
                         Just c :: AnyComorphism
c -> AnyComorphism
c
                         Nothing -> String -> AnyComorphism
forall a. HasCallStack => String -> a
error (String -> AnyComorphism) -> String -> AnyComorphism
forall a b. (a -> b) -> a -> b
$ "comorphism not found: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n
      sk :: (Session, Int)
sk@(sess' :: Session
sess', k :: Int
k) <- HetcatsOpts
-> IORef (IntMap Session, Map [String] Session)
-> DGQuery
-> ResultT IO (Session, Int)
getDGraph HetcatsOpts
opts IORef (IntMap Session, Map [String] Session)
sessRef DGQuery
dgQ
      Session
sess <- IO Session -> ResultT IO Session
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Session -> ResultT IO Session)
-> IO Session -> ResultT IO Session
forall a b. (a -> b) -> a -> b
$ Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
makeSessCleanable Session
sess' IORef (IntMap Session, Map [String] Session)
sessRef Int
k
      let libEnv :: LibEnv
libEnv = Session -> LibEnv
sessLibEnv Session
sess
      (ln :: LibName
ln, dg :: DGraph
dg) <- ResultT IO (LibName, DGraph)
-> ((LibName, DGraph) -> ResultT IO (LibName, DGraph))
-> Maybe (LibName, DGraph)
-> ResultT IO (LibName, DGraph)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> ResultT IO (LibName, DGraph)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "unknown development graph") (LibName, DGraph) -> ResultT IO (LibName, DGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return
        (Maybe (LibName, DGraph) -> ResultT IO (LibName, DGraph))
-> Maybe (LibName, DGraph) -> ResultT IO (LibName, DGraph)
forall a b. (a -> b) -> a -> b
$ DGQuery -> Session -> Maybe (LibName, DGraph)
sessGraph DGQuery
dgQ Session
sess
      let title :: String
title = LibName -> String
libToFileName LibName
ln
      let svg :: ResultT IO String
svg = String -> String -> DGraph -> ResultT IO String
getSVG String
title ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
k) DGraph
dg
      case QueryKind
qk of
            DisplayQuery ms :: Maybe String
ms -> case Maybe String
format_ Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe String
ms of
              Just "db" -> do
                (String, String)
result <- IO (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (String, String) -> ResultT IO (String, String))
-> IO (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ IO (String, String)
-> (SomeException -> IO (String, String)) -> IO (String, String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
Control.Exception.catch
                  (do
                    HetcatsOpts -> LibEnv -> IO ()
Persistence.DevGraph.exportLibEnv HetcatsOpts
opts LibEnv
libEnv
                    (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
jsonC, "{\"savedToDatabase\": true}")
                  )
                  (\ exception :: SomeException
exception ->
                    (String, String) -> IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
jsonC, "{\"savedToDatabase\": false, \"error\": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show (SomeException
exception :: SomeException) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "}")
                  )
                Result (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result (String, String) -> ResultT IO (String, String))
-> Result (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Result (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, String)
result
              Just "svg" -> (String -> (String, String))
-> ResultT IO String -> ResultT IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ s :: String
s -> (String
svgC, String
s)) ResultT IO String
svg
              Just "xml" -> Result (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result (String, String) -> ResultT IO (String, String))
-> Result (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Result (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
xmlC, Element -> String
ppTopElement
                (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> LibEnv -> LibName -> DGraph -> Element
ToXml.dGraph HetcatsOpts
opts LibEnv
libEnv LibName
ln DGraph
dg)
              Just "json" -> Result (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result (String, String) -> ResultT IO (String, String))
-> Result (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Result (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
jsonC, Json -> String
ppJson
                (Json -> String) -> Json -> String
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> LibEnv -> LibName -> DGraph -> Json
ToJson.dGraph HetcatsOpts
opts LibEnv
libEnv LibName
ln DGraph
dg)
              Just "dot" -> Result (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result (String, String) -> ResultT IO (String, String))
-> Result (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Result (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return
                (String
dotC, String -> Bool -> String -> DGraph -> String
dotGraph String
title Bool
False String
title DGraph
dg)
              Just "symbols" -> Result (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result (String, String) -> ResultT IO (String, String))
-> Result (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Result (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
xmlC, Element -> String
ppTopElement
                (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> DGraph -> Element
ToXml.dgSymbols HetcatsOpts
opts DGraph
dg)
              Just "session" -> Result (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result (String, String) -> ResultT IO (String, String))
-> Result (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Result (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
htmlC, Element -> String
ppElement
                (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
aRef (Session -> LibName -> Int -> String
mkPath Session
sess LibName
ln Int
k) (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
k)
              Just str :: String
str | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
str [String]
ppList
                -> DGraph -> Maybe PrettyType -> ResultT IO (String, String)
ppDGraph DGraph
dg (Maybe PrettyType -> ResultT IO (String, String))
-> Maybe PrettyType -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ String -> [(String, PrettyType)] -> Maybe PrettyType
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
str ([(String, PrettyType)] -> Maybe PrettyType)
-> [(String, PrettyType)] -> Maybe PrettyType
forall a b. (a -> b) -> a -> b
$ [String] -> [PrettyType] -> [(String, PrettyType)]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
ppList [PrettyType]
prettyList
              _ -> LibName
-> ResultT IO String
-> (Session, Int)
-> ResultT IO (String, String)
sessAns LibName
ln ResultT IO String
svg (Session, Int)
sk
            Query.DGTranslation path :: String
path -> do
              -- compose the comorphisms passed in translation
               let coms :: [AnyComorphism]
coms = (String -> AnyComorphism) -> [String] -> [AnyComorphism]
forall a b. (a -> b) -> [a] -> [b]
map String -> AnyComorphism
getCom ([String] -> [AnyComorphism]) -> [String] -> [AnyComorphism]
forall a b. (a -> b) -> a -> b
$ Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn ',' String
path
               AnyComorphism
com <- (AnyComorphism -> AnyComorphism -> ResultT IO AnyComorphism)
-> AnyComorphism -> [AnyComorphism] -> ResultT IO AnyComorphism
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM AnyComorphism -> AnyComorphism -> ResultT IO AnyComorphism
forall (m :: * -> *).
MonadFail m =>
AnyComorphism -> AnyComorphism -> m AnyComorphism
compComorphism ([AnyComorphism] -> AnyComorphism
forall a. [a] -> a
head [AnyComorphism]
coms) ([AnyComorphism] -> ResultT IO AnyComorphism)
-> [AnyComorphism] -> ResultT IO AnyComorphism
forall a b. (a -> b) -> a -> b
$ [AnyComorphism] -> [AnyComorphism]
forall a. [a] -> [a]
tail [AnyComorphism]
coms
               DGraph
dg' <- Result DGraph -> ResultT IO DGraph
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result DGraph -> ResultT IO DGraph)
-> Result DGraph -> ResultT IO DGraph
forall a b. (a -> b) -> a -> b
$ LibEnv -> LibName -> DGraph -> AnyComorphism -> Result DGraph
dg_translation LibEnv
libEnv LibName
ln DGraph
dg AnyComorphism
com
               Result (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result (String, String) -> ResultT IO (String, String))
-> Result (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String, String) -> Result (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
xmlC, Element -> String
ppTopElement
                (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> LibEnv -> LibName -> DGraph -> Element
ToXml.dGraph HetcatsOpts
opts LibEnv
libEnv LibName
ln DGraph
dg')
            GlProvers mp :: ProverMode
mp mt :: Maybe String
mt -> do
              [(AnyComorphism, [ProverOrConsChecker])]
availableProvers <- IO [(AnyComorphism, [ProverOrConsChecker])]
-> ResultT IO [(AnyComorphism, [ProverOrConsChecker])]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(AnyComorphism, [ProverOrConsChecker])]
 -> ResultT IO [(AnyComorphism, [ProverOrConsChecker])])
-> IO [(AnyComorphism, [ProverOrConsChecker])]
-> ResultT IO [(AnyComorphism, [ProverOrConsChecker])]
forall a b. (a -> b) -> a -> b
$ ProverMode
-> Maybe String
-> DGraph
-> IO [(AnyComorphism, [ProverOrConsChecker])]
getFullProverList ProverMode
mp Maybe String
mt DGraph
dg
              (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> ResultT IO (String, String))
-> (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ case UsedAPI
api of
                OldWebAPI -> (String
xmlC, ProverMode -> [(AnyComorphism, [String])] -> String
formatProvers ProverMode
mp ([(AnyComorphism, [String])] -> String)
-> [(AnyComorphism, [String])] -> String
forall a b. (a -> b) -> a -> b
$
                  [(AnyComorphism, [ProverOrConsChecker])]
-> [(AnyComorphism, [String])]
proversToStringAux [(AnyComorphism, [ProverOrConsChecker])]
availableProvers)
                RESTfulAPI -> Maybe String -> ProversFormatter
OProvers.formatProvers Maybe String
format_ ProverMode
mp [(AnyComorphism, [ProverOrConsChecker])]
availableProvers
            GlTranslations -> do
              [(G_prover, AnyComorphism)]
availableComorphisms <- IO [(G_prover, AnyComorphism)]
-> ResultT IO [(G_prover, AnyComorphism)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(G_prover, AnyComorphism)]
 -> ResultT IO [(G_prover, AnyComorphism)])
-> IO [(G_prover, AnyComorphism)]
-> ResultT IO [(G_prover, AnyComorphism)]
forall a b. (a -> b) -> a -> b
$ DGraph -> IO [(G_prover, AnyComorphism)]
getFullComorphList DGraph
dg
              (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> ResultT IO (String, String))
-> (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ case UsedAPI
api of
                OldWebAPI ->
                  (String
xmlC, [(G_prover, AnyComorphism)] -> String
formatComorphs [(G_prover, AnyComorphism)]
availableComorphisms)
                RESTfulAPI ->
                  Maybe String -> TranslationsFormatter
formatTranslations Maybe String
format_ [(G_prover, AnyComorphism)]
availableComorphisms
            GlShowProverWindow prOrCons :: ProverMode
prOrCons -> DGraph -> Int -> ProverMode -> ResultT IO (String, String)
showAutoProofWindow DGraph
dg Int
k ProverMode
prOrCons
            GlAutoProveREST proverMode :: ProverMode
proverMode reasoningParameters :: ReasoningParameters
reasoningParameters -> case UsedAPI
api of
              RESTfulAPI -> do
                (newLib :: LibEnv
newLib, nodesAndProofResults :: [(String, [ProofResult])]
nodesAndProofResults) <-
                  HetcatsOpts
-> LibEnv
-> LibName
-> DGraph
-> ProverMode
-> String
-> ReasoningParameters
-> ResultT IO (LibEnv, [(String, [ProofResult])])
reasonREST HetcatsOpts
opts LibEnv
libEnv LibName
ln DGraph
dg ProverMode
proverMode (DGQuery -> String
queryLib DGQuery
dgQ) ReasoningParameters
reasoningParameters
                if ((String, [ProofResult]) -> Bool)
-> [(String, [ProofResult])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([ProofResult] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ProofResult] -> Bool)
-> ((String, [ProofResult]) -> [ProofResult])
-> (String, [ProofResult])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [ProofResult]) -> [ProofResult]
forall a b. (a, b) -> b
snd) [(String, [ProofResult])]
nodesAndProofResults
                then (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
textC, "nothing to prove")
                else do
                  IO Session -> ResultT IO Session
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Session -> ResultT IO Session)
-> IO Session -> ResultT IO Session
forall a b. (a -> b) -> a -> b
$ LibEnv
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
nextSess LibEnv
newLib Session
sess IORef (IntMap Session, Map [String] Session)
sessRef Int
k
                  Maybe String
-> ProofFormatterOptions
-> [(String, [ProofResult])]
-> (HetcatsOpts, LibEnv, LibName, DGraph)
-> ResultT IO (String, String)
processProofResult Maybe String
format_ ProofFormatterOptions
pfOptions [(String, [ProofResult])]
nodesAndProofResults (HetcatsOpts
opts, LibEnv
libEnv, LibName
ln, DGraph
dg)
              _ -> String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("The GlAutoProveREST path is only "
                         String -> ShowS
forall a. [a] -> [a] -> [a]
++ "available in the REST interface.")
            GlAutoProve (ProveCmd prOrCons :: ProverMode
prOrCons incl :: Bool
incl mp :: Maybe String
mp mt :: Maybe String
mt tl :: Maybe Int
tl nds :: [String]
nds xForm :: Bool
xForm axioms :: [String]
axioms) -> do
              (newLib :: LibEnv
newLib, nodesAndProofResults :: [(String, [ProofResult])]
nodesAndProofResults) <-
                ProverMode
-> LibEnv
-> LibName
-> DGraph
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> [String]
-> [String]
-> ResultT IO (LibEnv, [(String, [ProofResult])])
proveMultiNodes ProverMode
prOrCons LibEnv
libEnv LibName
ln DGraph
dg Bool
incl Maybe String
mp Maybe String
mt Maybe Int
tl [String]
nds [String]
axioms
              if ((String, [ProofResult]) -> Bool)
-> [(String, [ProofResult])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([ProofResult] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([ProofResult] -> Bool)
-> ((String, [ProofResult]) -> [ProofResult])
-> (String, [ProofResult])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, [ProofResult]) -> [ProofResult]
forall a b. (a, b) -> b
snd) [(String, [ProofResult])]
nodesAndProofResults
              then (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
textC, "nothing to prove")
              else do
                IO Session -> ResultT IO Session
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Session -> ResultT IO Session)
-> IO Session -> ResultT IO Session
forall a b. (a -> b) -> a -> b
$ LibEnv
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
nextSess LibEnv
newLib Session
sess IORef (IntMap Session, Map [String] Session)
sessRef Int
k
                case UsedAPI
api of
                  OldWebAPI -> let
                    sens :: [Element]
sens = ((String, [ProofResult]) -> [Element] -> [Element])
-> [Element] -> [(String, [ProofResult])] -> [Element]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (dgNodeName :: String
dgNodeName, proofResults :: [ProofResult]
proofResults) res :: [Element]
res ->
                        Bool -> ProverMode -> String -> [ProofResult] -> Element
formatResultsAux Bool
xForm ProverMode
prOrCons String
dgNodeName [ProofResult]
proofResults
                        Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
res
                      ) [] [(String, [ProofResult])]
nodesAndProofResults
                    in (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
htmlC, Bool -> Int -> [Element] -> ProverMode -> String
formatResultsMultiple Bool
xForm Int
k [Element]
sens ProverMode
prOrCons)
                  RESTfulAPI ->
                    Maybe String
-> ProofFormatterOptions
-> [(String, [ProofResult])]
-> (HetcatsOpts, LibEnv, LibName, DGraph)
-> ResultT IO (String, String)
processProofResult Maybe String
format_ ProofFormatterOptions
pfOptions [(String, [ProofResult])]
nodesAndProofResults (HetcatsOpts
opts, LibEnv
libEnv, LibName
ln, DGraph
dg)
            GlobCmdQuery s :: String
s ->
              case ((GlobCmd, LibName -> LibEnv -> Result LibEnv) -> Bool)
-> [(GlobCmd, LibName -> LibEnv -> Result LibEnv)]
-> Maybe (GlobCmd, LibName -> LibEnv -> Result LibEnv)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool)
-> ((GlobCmd, LibName -> LibEnv -> Result LibEnv) -> String)
-> (GlobCmd, LibName -> LibEnv -> Result LibEnv)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlobCmd -> String
cmdlGlobCmd (GlobCmd -> String)
-> ((GlobCmd, LibName -> LibEnv -> Result LibEnv) -> GlobCmd)
-> (GlobCmd, LibName -> LibEnv -> Result LibEnv)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobCmd, LibName -> LibEnv -> Result LibEnv) -> GlobCmd
forall a b. (a, b) -> a
fst) [(GlobCmd, LibName -> LibEnv -> Result LibEnv)]
allGlobLibAct of
              Nothing -> if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
updateS then
                case (FileInfo ByteString -> Bool)
-> [FileInfo ByteString] -> [FileInfo ByteString]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== ".xupdate") (String -> Bool)
-> (FileInfo ByteString -> String) -> FileInfo ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeExtension ShowS
-> (FileInfo ByteString -> String) -> FileInfo ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B8.unpack
                            (ByteString -> String)
-> (FileInfo ByteString -> ByteString)
-> FileInfo ByteString
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileInfo ByteString -> ByteString
forall c. FileInfo c -> ByteString
fileName) [FileInfo ByteString]
updates of
                ch :: FileInfo ByteString
ch : _ -> do
                  let str :: String
str = ByteString -> String
BS.unpack (ByteString -> String) -> ByteString -> String
forall a b. (a -> b) -> a -> b
$ FileInfo ByteString -> ByteString
forall c. FileInfo c -> c
fileContent FileInfo ByteString
ch
                  (newLn :: LibName
newLn, newLib :: LibEnv
newLib) <- HetcatsOpts
-> String
-> LibEnv
-> LibName
-> DGraph
-> ResultT IO (LibName, LibEnv)
dgXUpdate HetcatsOpts
opts String
str LibEnv
libEnv LibName
ln DGraph
dg
                  Session
newSess <- IO Session -> ResultT IO Session
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Session -> ResultT IO Session)
-> IO Session -> ResultT IO Session
forall a b. (a -> b) -> a -> b
$ LibEnv
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
nextSess LibEnv
newLib Session
sess IORef (IntMap Session, Map [String] Session)
sessRef Int
k
                  LibName
-> ResultT IO String
-> (Session, Int)
-> ResultT IO (String, String)
sessAns LibName
newLn ResultT IO String
svg (Session
newSess, Int
k)
                [] -> LibName
-> ResultT IO String
-> (Session, Int)
-> ResultT IO (String, String)
sessAns LibName
ln ResultT IO String
svg (Session, Int)
sk
                else String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "getHetsResult.GlobCmdQuery"
              Just (_, act :: LibName -> LibEnv -> Result LibEnv
act) -> do
                LibEnv
newLib <- Result LibEnv -> ResultT IO LibEnv
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result LibEnv -> ResultT IO LibEnv)
-> Result LibEnv -> ResultT IO LibEnv
forall a b. (a -> b) -> a -> b
$ LibName -> LibEnv -> Result LibEnv
act LibName
ln LibEnv
libEnv
                Session
newSess <- IO Session -> ResultT IO Session
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Session -> ResultT IO Session)
-> IO Session -> ResultT IO Session
forall a b. (a -> b) -> a -> b
$ LibEnv
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
nextSess LibEnv
newLib Session
sess IORef (IntMap Session, Map [String] Session)
sessRef Int
k
                -- calculate updated SVG-view from modified development graph
                let newSvg :: ResultT IO String
newSvg = String -> String -> DGraph -> ResultT IO String
getSVG String
title ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
k)
                      (DGraph -> ResultT IO String) -> DGraph -> ResultT IO String
forall a b. (a -> b) -> a -> b
$ LibName -> LibEnv -> DGraph
lookupDGraph LibName
ln LibEnv
newLib
                LibName
-> ResultT IO String
-> (Session, Int)
-> ResultT IO (String, String)
sessAns LibName
ln ResultT IO String
newSvg (Session
newSess, Int
k)
            NodeQuery ein :: NodeIdOrName
ein nc :: NodeCommand
nc -> do
              nl :: LNode DGNodeLab
nl@(i :: Int
i, dgnode :: DGNodeLab
dgnode) <- case NodeIdOrName
ein of
                Right n :: String
n -> case String -> DGraph -> [LNode DGNodeLab]
lookupNodeByName String
n DGraph
dg of
                  p :: LNode DGNodeLab
p : _ -> LNode DGNodeLab -> ResultT IO (LNode DGNodeLab)
forall (m :: * -> *) a. Monad m => a -> m a
return LNode DGNodeLab
p
                  [] -> String -> ResultT IO (LNode DGNodeLab)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (LNode DGNodeLab))
-> String -> ResultT IO (LNode DGNodeLab)
forall a b. (a -> b) -> a -> b
$ "no node name: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n
                Left i :: Int
i -> case Gr DGNodeLab DGLinkLab -> Int -> Maybe DGNodeLab
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (DGraph -> Gr DGNodeLab DGLinkLab
dgBody DGraph
dg) Int
i of
                  Nothing -> String -> ResultT IO (LNode DGNodeLab)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (LNode DGNodeLab))
-> String -> ResultT IO (LNode DGNodeLab)
forall a b. (a -> b) -> a -> b
$ "no node id: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
                  Just dgnode :: DGNodeLab
dgnode -> LNode DGNodeLab -> ResultT IO (LNode DGNodeLab)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
i, DGNodeLab
dgnode)
              let fstLine :: String
fstLine = (if DGNodeLab -> Bool
isDGRef DGNodeLab
dgnode then ("reference " String -> ShowS
forall a. [a] -> [a] -> [a]
++) else
                    if DGNodeLab -> Bool
isInternalNode DGNodeLab
dgnode then ("internal " String -> ShowS
forall a. [a] -> [a] -> [a]
++) else ShowS
forall a. a -> a
id)
                    "Node " String -> ShowS
forall a. [a] -> [a] -> [a]
++ DGNodeLab -> String
getDGNodeName DGNodeLab
dgnode String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (#" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")\n"
                  ins :: [String]
ins = DGraph -> Int -> [String]
getImportNames DGraph
dg Int
i
                  showN :: a -> String
showN d :: a
d = GlobalAnnos -> a -> ShowS
forall a. Pretty a => GlobalAnnos -> a -> ShowS
showGlobalDoc (DGraph -> GlobalAnnos
globalAnnos DGraph
dg) a
d "\n"
              case NodeCommand
nc of
                NcCmd cmd :: NodeCmd
cmd | NodeCmd -> [NodeCmd] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem NodeCmd
cmd [NodeCmd
Query.Node, NodeCmd
Info, NodeCmd
Symbols]
                  -> case NodeCmd
cmd of
                   Symbols -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
xmlC, Element -> String
ppTopElement
                           (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> [String] -> GlobalAnnos -> DGNodeLab -> Element
showSymbols HetcatsOpts
opts [String]
ins (DGraph -> GlobalAnnos
globalAnnos DGraph
dg) DGNodeLab
dgnode)
                   _ -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
textC, String
fstLine String -> ShowS
forall a. [a] -> [a] -> [a]
++ DGNodeLab -> String
forall a. Pretty a => a -> String
showN DGNodeLab
dgnode)
                _ -> case Result G_theory -> Maybe G_theory
forall a. Result a -> Maybe a
maybeResult (Result G_theory -> Maybe G_theory)
-> Result G_theory -> Maybe G_theory
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> Result G_theory
getGlobalTheory DGNodeLab
dgnode of
                  Nothing -> String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (String, String))
-> String -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$
                    "cannot compute global theory of:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
fstLine
                  Just gTh :: G_theory
gTh -> let subL :: G_sublogics
subL = G_theory -> G_sublogics
sublogicOfTh G_theory
gTh in case NodeCommand
nc of
                    ProveNode (ProveCmd pm :: ProverMode
pm incl :: Bool
incl mp :: Maybe String
mp mt :: Maybe String
mt tl :: Maybe Int
tl thms :: [String]
thms xForm :: Bool
xForm axioms :: [String]
axioms) ->
                      case ProverMode
pm of
                      GlProofs -> do
                        (newLib :: LibEnv
newLib, proofResults :: [ProofResult]
proofResults) <- LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_theory
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> [String]
-> [String]
-> ResultT IO (LibEnv, [ProofResult])
proveNode LibEnv
libEnv LibName
ln DGraph
dg LNode DGNodeLab
nl
                          G_theory
gTh G_sublogics
subL Bool
incl Maybe String
mp Maybe String
mt Maybe Int
tl [String]
thms [String]
axioms
                        if [ProofResult] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ProofResult]
proofResults
                        then (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
textC, "nothing to prove")
                        else do
                          IO Session -> ResultT IO Session
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Session -> ResultT IO Session)
-> IO Session -> ResultT IO Session
forall a b. (a -> b) -> a -> b
$ LibEnv
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
nextSess LibEnv
newLib Session
sess IORef (IntMap Session, Map [String] Session)
sessRef Int
k
                          case UsedAPI
api of
                            OldWebAPI -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
htmlC,
                              Bool -> Int -> Int -> Element -> String
formatResults Bool
xForm Int
k Int
i (Element -> String) -> (Element -> Element) -> Element -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "results") (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$
                                String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Bool -> [ProofResult] -> [Element]
formatGoals Bool
True [ProofResult]
proofResults)
                            RESTfulAPI -> Maybe String
-> ProofFormatterOptions
-> [(String, [ProofResult])]
-> (HetcatsOpts, LibEnv, LibName, DGraph)
-> ResultT IO (String, String)
processProofResult Maybe String
format_ ProofFormatterOptions
pfOptions
                              [(DGNodeLab -> String
getDGNodeName DGNodeLab
dgnode, [ProofResult]
proofResults)] (HetcatsOpts
opts, LibEnv
libEnv, LibName
ln, DGraph
dg)
                      GlConsistency -> do
                        (newLib :: LibEnv
newLib, [(_, res :: String
res, txt :: String
txt, _, _, _, _)]) <-
                          LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> ResultT IO (LibEnv, [ProofResult])
consNode LibEnv
libEnv LibName
ln DGraph
dg LNode DGNodeLab
nl G_sublogics
subL Bool
incl Maybe String
mp Maybe String
mt Maybe Int
tl
                        IO Session -> ResultT IO Session
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Session -> ResultT IO Session)
-> IO Session -> ResultT IO Session
forall a b. (a -> b) -> a -> b
$ LibEnv
-> Session
-> IORef (IntMap Session, Map [String] Session)
-> Int
-> IO Session
nextSess LibEnv
newLib Session
sess IORef (IntMap Session, Map [String] Session)
sessRef Int
k
                        (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
xmlC, Element -> String
ppTopElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
formatConsNode String
res String
txt)
                    _ -> case NodeCommand
nc of
                      NcCmd Query.Theory -> case UsedAPI
api of
                          OldWebAPI -> IO (String, String) -> ResultT IO (String, String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (String, String) -> ResultT IO (String, String))
-> IO (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ t :: String
t -> (String
htmlC, String
t))
                                       (IO String -> IO (String, String))
-> IO String -> IO (String, String)
forall a b. (a -> b) -> a -> b
$ DGraph -> Int -> G_theory -> Int -> String -> Bool -> IO String
showGlobalTh DGraph
dg Int
i G_theory
gTh Int
k String
fstLine Bool
False
                          RESTfulAPI -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> ResultT IO (String, String))
-> (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ 
                                          HetcatsOpts
-> GlobalAnnos
-> LibEnv
-> DGraph
-> Int
-> Maybe String
-> (String, String)
showNode HetcatsOpts
opts (DGraph -> GlobalAnnos
globalAnnos DGraph
dg) LibEnv
libEnv DGraph
dg Int
i Maybe String
format_
                      NcCmd (Query.Translate x :: String
x) -> do
                          -- compose the comorphisms passed in translation
                          let coms :: [AnyComorphism]
coms = (String -> AnyComorphism) -> [String] -> [AnyComorphism]
forall a b. (a -> b) -> [a] -> [b]
map String -> AnyComorphism
getCom ([String] -> [AnyComorphism]) -> [String] -> [AnyComorphism]
forall a b. (a -> b) -> a -> b
$ Char -> String -> [String]
forall a. Eq a => a -> [a] -> [[a]]
splitOn ',' String
x
                          AnyComorphism
com <- (AnyComorphism -> AnyComorphism -> ResultT IO AnyComorphism)
-> AnyComorphism -> [AnyComorphism] -> ResultT IO AnyComorphism
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM AnyComorphism -> AnyComorphism -> ResultT IO AnyComorphism
forall (m :: * -> *).
MonadFail m =>
AnyComorphism -> AnyComorphism -> m AnyComorphism
compComorphism ([AnyComorphism] -> AnyComorphism
forall a. [a] -> a
head [AnyComorphism]
coms) ([AnyComorphism] -> ResultT IO AnyComorphism)
-> [AnyComorphism] -> ResultT IO AnyComorphism
forall a b. (a -> b) -> a -> b
$ [AnyComorphism] -> [AnyComorphism]
forall a. [a] -> [a]
tail [AnyComorphism]
coms
                          -- translate the theory of i along com
                          G_theory
gTh1 <- Result G_theory -> ResultT IO G_theory
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result G_theory -> ResultT IO G_theory)
-> Result G_theory -> ResultT IO G_theory
forall a b. (a -> b) -> a -> b
$ Bool -> AnyComorphism -> G_theory -> Result G_theory
mapG_theory Bool
False AnyComorphism
com G_theory
gTh
                          -- insert the translation of i in dg
                          let n1 :: Int
n1 = DGraph -> Int
getNewNodeDG DGraph
dg
                              labN1 :: DGNodeLab
labN1 = NodeName -> DGNodeInfo -> G_theory -> DGNodeLab
newInfoNodeLab
                                       NodeName
emptyNodeName
                                       (DGOrigin -> DGNodeInfo
newNodeInfo DGOrigin
DGBasic) -- to be corrected
                                       G_theory
gTh1
                              dg1 :: DGraph
dg1 = LNode DGNodeLab -> DGraph -> DGraph
insLNodeDG (Int
n1, DGNodeLab
labN1) DGraph
dg
                          GMorphism
gmor <- Result GMorphism -> ResultT IO GMorphism
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result GMorphism -> ResultT IO GMorphism)
-> Result GMorphism -> ResultT IO GMorphism
forall a b. (a -> b) -> a -> b
$ AnyComorphism -> G_sign -> Result GMorphism
gEmbedComorphism AnyComorphism
com (G_sign -> Result GMorphism) -> G_sign -> Result GMorphism
forall a b. (a -> b) -> a -> b
$ G_theory -> G_sign
signOf (G_theory -> G_sign) -> G_theory -> G_sign
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> G_theory
dgn_theory DGNodeLab
dgnode
                          -- add a link from i to n1 labeled with (com, id)
                          let (_, dg2 :: DGraph
dg2) = LEdge DGLinkLab -> DGraph -> (LEdge DGLinkLab, DGraph)
insLEdgeDG
                                          (Int
i, Int
n1, GMorphism -> DGLinkOrigin -> DGLinkLab
globDefLink GMorphism
gmor DGLinkOrigin
SeeSource) -- origin to be corrected
                                          DGraph
dg1
                          case UsedAPI
api of
                            OldWebAPI -> 
                                 IO (String, String) -> ResultT IO (String, String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (String, String) -> ResultT IO (String, String))
-> IO (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ t :: String
t -> (String
htmlC, String
t))
                                          (IO String -> IO (String, String))
-> IO String -> IO (String, String)
forall a b. (a -> b) -> a -> b
$ DGraph -> Int -> G_theory -> Int -> String -> Bool -> IO String
showGlobalTh DGraph
dg Int
n1 G_theory
gTh1 Int
k String
fstLine Bool
True
                            RESTfulAPI ->
                            -- show the theory of n1 in xml format
                              (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> ResultT IO (String, String))
-> (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ HetcatsOpts
-> GlobalAnnos
-> LibEnv
-> DGraph
-> Int
-> Maybe String
-> (String, String)
showNode HetcatsOpts
opts (DGraph -> GlobalAnnos
globalAnnos DGraph
dg2) LibEnv
libEnv DGraph
dg2 Int
n1 Maybe String
format_
                      NcProvers mp :: ProverMode
mp mt :: Maybe String
mt -> do
                        [(AnyComorphism, [ProverOrConsChecker])]
availableProvers <- IO [(AnyComorphism, [ProverOrConsChecker])]
-> ResultT IO [(AnyComorphism, [ProverOrConsChecker])]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(AnyComorphism, [ProverOrConsChecker])]
 -> ResultT IO [(AnyComorphism, [ProverOrConsChecker])])
-> IO [(AnyComorphism, [ProverOrConsChecker])]
-> ResultT IO [(AnyComorphism, [ProverOrConsChecker])]
forall a b. (a -> b) -> a -> b
$ ProverMode
-> Maybe String
-> G_sublogics
-> IO [(AnyComorphism, [ProverOrConsChecker])]
getProverList ProverMode
mp Maybe String
mt G_sublogics
subL
                        (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> ResultT IO (String, String))
-> (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ case UsedAPI
api of
                          OldWebAPI -> (String
xmlC, ProverMode -> [(AnyComorphism, [String])] -> String
formatProvers ProverMode
mp ([(AnyComorphism, [String])] -> String)
-> [(AnyComorphism, [String])] -> String
forall a b. (a -> b) -> a -> b
$
                            [(AnyComorphism, [ProverOrConsChecker])]
-> [(AnyComorphism, [String])]
proversToStringAux [(AnyComorphism, [ProverOrConsChecker])]
availableProvers)
                          RESTfulAPI ->
                            Maybe String -> ProversFormatter
OProvers.formatProvers Maybe String
format_ ProverMode
mp [(AnyComorphism, [ProverOrConsChecker])]
availableProvers
                      NcTranslations mp :: Maybe String
mp -> do
                        [(G_prover, AnyComorphism)]
availableComorphisms <- IO [(G_prover, AnyComorphism)]
-> ResultT IO [(G_prover, AnyComorphism)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(G_prover, AnyComorphism)]
 -> ResultT IO [(G_prover, AnyComorphism)])
-> IO [(G_prover, AnyComorphism)]
-> ResultT IO [(G_prover, AnyComorphism)]
forall a b. (a -> b) -> a -> b
$ Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getComorphs Maybe String
mp G_sublogics
subL
                        (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> ResultT IO (String, String))
-> (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ case UsedAPI
api of
                          OldWebAPI ->
                            (String
xmlC, [(G_prover, AnyComorphism)] -> String
formatComorphs [(G_prover, AnyComorphism)]
availableComorphisms)
                          RESTfulAPI ->
                            Maybe String -> TranslationsFormatter
formatTranslations Maybe String
format_ [(G_prover, AnyComorphism)]
availableComorphisms
                      q :: NodeCommand
q -> String -> ResultT IO (String, String)
forall a. HasCallStack => String -> a
error ("getHetsResult.NodeQuery: unnkown query"String -> ShowS
forall a. [a] -> [a] -> [a]
++NodeCommand -> String
forall a. Show a => a -> String
show NodeCommand
q)
            EdgeQuery i :: Int
i _ ->
              case EdgeId -> DGraph -> [LEdge DGLinkLab]
getDGLinksById (Int -> EdgeId
EdgeId Int
i) DGraph
dg of
              [e :: LEdge DGLinkLab
e@(_, _, l :: DGLinkLab
l)] ->
                (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
textC, LEdge DGLinkLab -> String
showLEdge LEdge DGLinkLab
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DGLinkLab -> ShowS
forall a. Pretty a => a -> ShowS
showDoc DGLinkLab
l "")
              [] -> String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (String, String))
-> String -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ "no edge found with id: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i
              _ -> String -> ResultT IO (String, String)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (String, String))
-> String -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ "multiple edges found with id: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i

processProofResult :: Maybe String
                   -> ProofFormatterOptions
                   -> [(String, [ProofResult])]
                   -> (HetcatsOpts, LibEnv, LibName, DGraph)
                   -> ResultT IO (String, String)
processProofResult :: Maybe String
-> ProofFormatterOptions
-> [(String, [ProofResult])]
-> (HetcatsOpts, LibEnv, LibName, DGraph)
-> ResultT IO (String, String)
processProofResult (Just "db") _ _ _ =
  (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
jsonC, "{\"savedToDatabase\": true}")
processProofResult format_ :: Maybe String
format_ options :: ProofFormatterOptions
options nodesAndProofResults :: [(String, [ProofResult])]
nodesAndProofResults (opts :: HetcatsOpts
opts, libEnv :: LibEnv
libEnv, ln :: LibName
ln, dg :: DGraph
dg) =
  do
    JSONOrXML
joinedResult <- Result JSONOrXML -> ResultT IO JSONOrXML
forall (m :: * -> *) a. MonadResult m => Result a -> m a
liftR (Result JSONOrXML -> ResultT IO JSONOrXML)
-> Result JSONOrXML -> ResultT IO JSONOrXML
forall a b. (a -> b) -> a -> b
$ Maybe String
-> ProofFormatterOptions
-> [(String, [ProofResult])]
-> HetcatsOpts
-> LibEnv
-> LibName
-> DGraph
-> Result JSONOrXML
getJSONOrXMLResult Maybe String
format_ ProofFormatterOptions
options [(String, [ProofResult])]
nodesAndProofResults HetcatsOpts
opts LibEnv
libEnv LibName
ln DGraph
dg
    let result :: (String, String)
result = JSONOrXML -> (String, String)
prettyWithTag JSONOrXML
joinedResult
    (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String, String)
result

-- returns the joined data consisting of the development graph and prover results
getJSONOrXMLResult :: Maybe String -> ProofFormatterOptions
                   -> [(String, [ProofResult])] -> HetcatsOpts -> LibEnv
                   -> LibName -> DGraph -> Result JSONOrXML
getJSONOrXMLResult :: Maybe String
-> ProofFormatterOptions
-> [(String, [ProofResult])]
-> HetcatsOpts
-> LibEnv
-> LibName
-> DGraph
-> Result JSONOrXML
getJSONOrXMLResult format_ :: Maybe String
format_ options :: ProofFormatterOptions
options nodesAndProofResults :: [(String, [ProofResult])]
nodesAndProofResults opts :: HetcatsOpts
opts libEnv :: LibEnv
libEnv ln :: LibName
ln dg :: DGraph
dg =
  let
    proverResults :: (String, JSONOrXML)
proverResults = ("prover_output", Maybe String -> ProofFormatter
formatProofs Maybe String
format_ ProofFormatterOptions
options [(String, [ProofResult])]
nodesAndProofResults)
  in
    case Maybe String
format_ of
      Just "xml" -> (String, JSONOrXML) -> (String, JSONOrXML) -> Result JSONOrXML
joinData ("dgraph", (Element -> JSONOrXML
XML (HetcatsOpts -> LibEnv -> LibName -> DGraph -> Element
ToXml.dGraph HetcatsOpts
opts LibEnv
libEnv LibName
ln DGraph
dg)))
                             (String, JSONOrXML)
proverResults
      _ -> (String, JSONOrXML) -> (String, JSONOrXML) -> Result JSONOrXML
joinData ("dgraph", (Json -> JSONOrXML
JSON (HetcatsOpts -> LibEnv -> LibName -> DGraph -> Json
ToJson.dGraph HetcatsOpts
opts LibEnv
libEnv LibName
ln DGraph
dg)))
                    (String, JSONOrXML)
proverResults

formatGoals :: Bool -> [ProofResult] -> [Element]
formatGoals :: Bool -> [ProofResult] -> [Element]
formatGoals includeDetails :: Bool
includeDetails =
  (ProofResult -> Element) -> [ProofResult] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ (n :: String
n, e :: String
e, d :: String
d, _, _, mps :: Maybe (ProofStatus G_proof_tree)
mps, _) -> Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "results-goal") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
    ([ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h3" ("Results for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
n String -> ShowS
forall a. [a] -> [a] -> [a]
++ " (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")") ]
    [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "results-details") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "div" String
d | Bool
includeDetails]
    [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ case Maybe (ProofStatus G_proof_tree)
mps of
        Nothing -> []
        Just ps :: ProofStatus G_proof_tree
ps -> ProofStatus G_proof_tree -> [Element]
formatProofStatus ProofStatus G_proof_tree
ps))

formatProofStatus :: ProofStatus G_proof_tree -> [Element]
formatProofStatus :: ProofStatus G_proof_tree -> [Element]
formatProofStatus ps :: ProofStatus G_proof_tree
ps =
  [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h5" "Used Prover"
  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "usedProver") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "p" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ ProofStatus G_proof_tree -> String
forall proof_tree. ProofStatus proof_tree -> String
usedProver ProofStatus G_proof_tree
ps
  -- `read` makes this type-unsafe
  , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h5" "Tactic Script"
  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "tacticScript") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "p" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ ATPTacticScript -> [Element]
formatTacticScript (ATPTacticScript -> [Element]) -> ATPTacticScript -> [Element]
forall a b. (a -> b) -> a -> b
$ String -> ATPTacticScript
forall a. Read a => String -> a
read (String -> ATPTacticScript) -> String -> ATPTacticScript
forall a b. (a -> b) -> a -> b
$
      (\ (TacticScript ts :: String
ts) -> String
ts) (TacticScript -> String) -> TacticScript -> String
forall a b. (a -> b) -> a -> b
$ ProofStatus G_proof_tree -> TacticScript
forall proof_tree. ProofStatus proof_tree -> TacticScript
tacticScript ProofStatus G_proof_tree
ps
  , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h5" "Proof Tree"
  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "proofTree") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "div" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ G_proof_tree -> String
forall a. Show a => a -> String
show (G_proof_tree -> String) -> G_proof_tree -> String
forall a b. (a -> b) -> a -> b
$ ProofStatus G_proof_tree -> G_proof_tree
forall proof_tree. ProofStatus proof_tree -> proof_tree
proofTree ProofStatus G_proof_tree
ps
  , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h5" "Used Time"
  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "usedTime") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> [Element]
formatUsedTime (TimeOfDay -> [Element]) -> TimeOfDay -> [Element]
forall a b. (a -> b) -> a -> b
$ ProofStatus G_proof_tree -> TimeOfDay
forall proof_tree. ProofStatus proof_tree -> TimeOfDay
usedTime ProofStatus G_proof_tree
ps
  , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h5" "Used Axioms"
  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "usedAxioms") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [String] -> [Element]
formatUsedAxioms ([String] -> [Element]) -> [String] -> [Element]
forall a b. (a -> b) -> a -> b
$ ProofStatus G_proof_tree -> [String]
forall proof_tree. ProofStatus proof_tree -> [String]
usedAxioms ProofStatus G_proof_tree
ps
  , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h5" "Prover Output"
  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "proverOutput") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ [String] -> Element
formatProverOutput ([String] -> Element) -> [String] -> Element
forall a b. (a -> b) -> a -> b
$ ProofStatus G_proof_tree -> [String]
forall proof_tree. ProofStatus proof_tree -> [String]
proofLines ProofStatus G_proof_tree
ps
  ]

formatProverOutput :: [String] -> Element
formatProverOutput :: [String] -> Element
formatProverOutput = String -> String -> Element
forall t. Node t => String -> t -> Element
unode "pre" (String -> Element) -> ([String] -> String) -> [String] -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines

formatTacticScript :: ATPTacticScript -> [Element]
formatTacticScript :: ATPTacticScript -> [Element]
formatTacticScript ts :: ATPTacticScript
ts =
  [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "timeLimit" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ ATPTacticScript -> Int
tsTimeLimit ATPTacticScript
ts
  , String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "extraOpts" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Element
forall t. Node t => String -> t -> Element
unode "option") ([String] -> [Element]) -> [String] -> [Element]
forall a b. (a -> b) -> a -> b
$ ATPTacticScript -> [String]
tsExtraOpts ATPTacticScript
ts
  ]

formatUsedTime :: TimeOfDay -> [Element]
formatUsedTime :: TimeOfDay -> [Element]
formatUsedTime tod :: TimeOfDay
tod =
  [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "seconds" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ ShowS
forall a. [a] -> [a]
init ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ DiffTime -> String
forall a. Show a => a -> String
show (DiffTime -> String) -> DiffTime -> String
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> DiffTime
timeOfDayToTime TimeOfDay
tod
  , String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "components"
    [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "hours" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> Int
todHour TimeOfDay
tod
    , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "minutes" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> Int
todMin TimeOfDay
tod
    , String -> String -> Element
forall t. Node t => String -> t -> Element
unode "seconds" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ Pico -> String
forall a. Show a => a -> String
show (Pico -> String) -> Pico -> String
forall a b. (a -> b) -> a -> b
$ TimeOfDay -> Pico
todSec TimeOfDay
tod
    ]
  ]

formatUsedAxioms :: [String] -> [Element]
formatUsedAxioms :: [String] -> [Element]
formatUsedAxioms = (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Element
forall t. Node t => String -> t -> Element
unode "axiom")

formatConsNode :: String -> String -> Element
formatConsNode :: String -> String -> Element
formatConsNode res :: String
res txt :: String
txt = Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "state" String
res) (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "result" String
txt

formatResultsMultiple :: Bool -> Int -> [Element] -> ProverMode -> String
formatResultsMultiple :: Bool -> Int -> [Element] -> ProverMode -> String
formatResultsMultiple xForm :: Bool
xForm sessId :: Int
sessId rs :: [Element]
rs prOrCons :: ProverMode
prOrCons =
  if Bool
xForm then Element -> String
ppTopElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "Results" [Element]
rs else let
  goBack1 :: Element
goBack1 = case ProverMode
prOrCons of
    GlConsistency -> String -> String -> Element
aRef ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
sessId String -> ShowS
forall a. [a] -> [a] -> [a]
++ "?consistency") "return"
    GlProofs -> String -> String -> Element
aRef ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
sessId String -> ShowS
forall a. [a] -> [a] -> [a]
++ "?autoproof") "return"
  goBack2 :: Element
goBack2 = String -> String -> Element
aRef ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
sessId) "return to DGraph"
  in String -> String -> [Element] -> ShowS
htmlPage "Results" []
       [ Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h1" "Results"
       , Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" [Element
goBack1, Element
goBack2]
       , Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
           (Element -> [Element] -> [Element])
-> [Element] -> [Element] -> [Element]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ el :: Element
el r :: [Element]
r -> String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h4" (QName -> String
qName (QName -> String) -> QName -> String
forall a b. (a -> b) -> a -> b
$ Element -> QName
elName Element
el) Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: Element
el Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
r) [] [Element]
rs
       ] ""

-- | display results of proving session (single node)
formatResults :: Bool -> Int -> Int -> Element -> String
formatResults :: Bool -> Int -> Int -> Element -> String
formatResults xForm :: Bool
xForm sessId :: Int
sessId i :: Int
i rs :: Element
rs =
  if Bool
xForm Bool -> Bool -> Bool
|| Int
sessId Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 0 then Element -> String
ppTopElement Element
rs else let
  goBack1 :: Element
goBack1 = String -> String -> Element
linkButtonElement ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
sessId String -> ShowS
forall a. [a] -> [a] -> [a]
++ "?theory=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) "return to Theory"
  goBack2 :: Element
goBack2 = String -> String -> Element
linkButtonElement ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
sessId) "return to DGraph"
  in String -> String -> [Element] -> ShowS
htmlPage "Results" []
       [ Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h1" "Results"
       , Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" [Element
goBack1, Element
goBack2]
       , Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui relaxed grid raised segment container left aligned") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" Element
rs
       ] ""

showBool :: Bool -> String
showBool :: Bool -> String
showBool = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ShowS -> (Bool -> String) -> Bool -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show

showNode :: HetcatsOpts -> GlobalAnnos -> LibEnv -> DGraph -> Int -> Maybe String -> (String,String)
showNode :: HetcatsOpts
-> GlobalAnnos
-> LibEnv
-> DGraph
-> Int
-> Maybe String
-> (String, String)
showNode opts :: HetcatsOpts
opts ga :: GlobalAnnos
ga lenv :: LibEnv
lenv dg :: DGraph
dg n :: Int
n format_ :: Maybe String
format_ = 
 let lNodeN :: DGNodeLab
lNodeN = case Gr DGNodeLab DGLinkLab -> Int -> Maybe DGNodeLab
forall (gr :: * -> * -> *) a b.
Graph gr =>
gr a b -> Int -> Maybe a
lab (DGraph -> Gr DGNodeLab DGLinkLab
dgBody DGraph
dg) Int
n of
       Just lNode :: DGNodeLab
lNode -> DGNodeLab
lNode
       Nothing -> String -> DGNodeLab
forall a. HasCallStack => String -> a
error (String -> DGNodeLab) -> String -> DGNodeLab
forall a b. (a -> b) -> a -> b
$ "no node for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
 in case Maybe String
format_ of 
           Just "xml" -> (String
xmlC,Element -> String
ppTopElement (Element -> String) -> Element -> String
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> GlobalAnnos -> LibEnv -> LNode DGNodeLab -> Element
ToXml.lnode HetcatsOpts
opts GlobalAnnos
ga LibEnv
lenv (Int
n,DGNodeLab
lNodeN)) 
           Just "json" -> (String
jsonC,Json -> String
ppJson (Json -> String) -> Json -> String
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> GlobalAnnos -> LibEnv -> LNode DGNodeLab -> Json
ToJson.lnode HetcatsOpts
opts GlobalAnnos
ga LibEnv
lenv (Int
n,DGNodeLab
lNodeN))
           Just str :: String
str | String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
str ["dol","het","text"]
                      -> (String
textC,GlobalAnnos -> G_theory -> ShowS
forall a. Pretty a => GlobalAnnos -> a -> ShowS
showGlobalDoc (DGraph -> GlobalAnnos
globalAnnos DGraph
dg) (DGNodeLab -> G_theory
dgn_theory DGNodeLab
lNodeN) "\n")
           _ -> String -> (String, String)
forall a. HasCallStack => String -> a
error ("unknown format: "String -> ShowS
forall a. [a] -> [a] -> [a]
++Maybe String -> String
forall a. Show a => a -> String
show Maybe String
format_)

{- | displays the global theory for a node with the option to prove theorems
and select proving options -}
showGlobalTh :: DGraph -> Int -> G_theory -> Int -> String -> Bool -> IO String
showGlobalTh :: DGraph -> Int -> G_theory -> Int -> String -> Bool -> IO String
showGlobalTh dg :: DGraph
dg i :: Int
i gTh :: G_theory
gTh sessId :: Int
sessId fstLine :: String
fstLine isTrans :: Bool
isTrans = case G_theory -> G_theory
simplifyTh G_theory
gTh of
  sGTh :: G_theory
sGTh@(G_theory lid :: lid
lid _ (ExtSign sig :: sign
sig _) _ thsens :: ThSens sentence (AnyComorphism, BasicProof)
thsens _) -> do
   let
    paths :: [AnyComorphism]
paths = LogicGraph -> G_sublogics -> [AnyComorphism]
findComorphismPaths LogicGraph
logicGraph (G_theory -> G_sublogics
sublogicOfTh G_theory
gTh) 
    comorSelection :: [(String, String, [a])]
comorSelection = (AnyComorphism -> (String, String, [a]))
-> [AnyComorphism] -> [(String, String, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\ cm :: AnyComorphism
cm -> let c :: String
c = AnyComorphism -> String
showComorph AnyComorphism
cm in
                              (String
c, String
c, [])
                         ) [AnyComorphism]
paths
    ga :: GlobalAnnos
ga = DGraph -> GlobalAnnos
globalAnnos DGraph
dg
    -- links to translations and provers xml view
    headr :: Element
headr = Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h3" String
fstLine
    thShow :: String
thShow = GlobalAnnos -> Doc -> String
renderHtml GlobalAnnos
ga (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Named sentence -> Doc) -> [Named sentence] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (lid -> Named sentence -> Doc
forall lid sentence sign morphism symbol.
Sentences lid sentence sign morphism symbol =>
lid -> Named sentence -> Doc
print_named lid
lid) ([Named sentence] -> [Doc]) -> [Named sentence] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ThSens sentence (AnyComorphism, BasicProof) -> [Named sentence]
forall a b. ThSens a b -> [Named a]
toNamedList ThSens sentence (AnyComorphism, BasicProof)
thsens
    sbShow :: String
sbShow = GlobalAnnos -> Doc -> String
renderHtml GlobalAnnos
ga (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ sign -> Doc
forall a. Pretty a => a -> Doc
pretty sign
sig
    theoryHeader :: Element
theoryHeader = Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h4" (if Bool
isTrans then "Translated theory" else "Theory")
    transForm :: [Element]
transForm = if Bool
isTrans then []
                else [ Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h4" "Translate Theory"
                     , [(String, String, [Attr])] -> Element
translationForm [(String, String, [Attr])]
forall a. [(String, String, [a])]
comorSelection]
    gs :: [(String, Maybe BasicProof)]
gs = G_theory -> [(String, Maybe BasicProof)]
getThGoals G_theory
sGTh
    in if [(String, Maybe BasicProof)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, Maybe BasicProof)]
gs Bool -> Bool -> Bool
|| Bool
isTrans
      -- show simple view if no goals are found
       then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> [Element] -> ShowS
htmlPage String
fstLine ""
                       ([ Element
headr ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
transForm [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
                        [ Element
theoryHeader
                        ]) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ "<pre>\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sbShow String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n<br />" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
thShow String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n</pre>\n"
      -- else create proving functionality
       else do
        -- create list of theorems, selectable for proving
        let thmSl :: [Element]
thmSl =
              ((String, Maybe BasicProof) -> Element)
-> [(String, Maybe BasicProof)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ (nm :: String
nm, bp :: Maybe BasicProof
bp) ->
                    let gSt :: GStatus
gSt = GStatus -> (BasicProof -> GStatus) -> Maybe BasicProof -> GStatus
forall b a. b -> (a -> b) -> Maybe a -> b
maybe GStatus
GOpen BasicProof -> GStatus
basicProofToGStatus Maybe BasicProof
bp
                    in String -> [Attr] -> Element
checkboxElement (String
nm String -> ShowS
forall a. [a] -> [a] -> [a]
++ "   (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ GStatus -> String
showSimple GStatus
gSt String -> ShowS
forall a. [a] -> [a] -> [a]
++ ")")
                       [ String -> String -> Attr
mkAttr "name" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ ShowS
escStr String
nm
                       , String -> String -> Attr
mkAttr "unproven" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ Bool -> String
showBool (Bool -> String) -> Bool -> String
forall a b. (a -> b) -> a -> b
$ GStatus -> [GStatus] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem GStatus
gSt [GStatus
GOpen, GStatus
GTimeout]
                       ]
                ) [(String, Maybe BasicProof)]
gs
        -- select unproven, all or none theorems by button
            (btUnpr :: Element
btUnpr, btAll :: Element
btAll, btNone :: Element
btNone, jvScr1 :: String
jvScr1) = Bool -> (Element, Element, Element, String)
showSelectionButtons Bool
True
        -- create prove button and prover/comorphism selection
        (prSl :: Element
prSl, cmrSl :: Element
cmrSl, jvScr2 :: String
jvScr2) <- ProverMode -> [G_sublogics] -> IO (Element, Element, String)
showProverSelection ProverMode
GlProofs [G_theory -> G_sublogics
sublogicOfTh G_theory
gTh]
        let (prBt :: Element
prBt, timeout :: Element
timeout) = Bool -> (Element, Element)
showProveButton Bool
True
        -- hidden param field with "prove=nodeid"
            hidStr :: Element
hidStr = [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "name" "prove"
              , String -> String -> Attr
mkAttr "type" "hidden", String -> String -> Attr
mkAttr "style" "display:none;"
              , String -> String -> Attr
mkAttr "value" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i ] Element
inputNode
        -- combine elements within a form
            thmMenu :: Element
thmMenu =
              [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "name" "thmSel", String -> String -> Attr
mkAttr "method" "get"]
                (Element -> Element) -> (Element -> Element) -> Element -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui form") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "form"
                (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui relaxed grid container left aligned") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
                ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" [Element
hidStr, Element
prSl, Element
cmrSl]
                  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" [Element
btUnpr, Element
btAll, Element
btNone, Element
timeout]
                  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" [Element]
thmSl
                  , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" Element
prBt
                  ]
        -- save dg and return to svg-view
            goBack :: Element
goBack = String -> String -> Element
linkButtonElement ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
sessId) "Return to DGraph"
        String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ String -> String -> [Element] -> ShowS
htmlPage String
fstLine (String
jvScr1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
jvScr2)
         ([ Element
headr
          , Element
goBack ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ [Element]
transForm [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++
          [ Element -> Element
htmlRow (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h4" "Theorems"
          , Element
thmMenu
          , Element
theoryHeader
          ]) ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ "<pre>\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
sbShow String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n<br />" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
thShow String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n</pre>\n"
  where
    translationForm :: [(String, String, [Attr])] -> Element
translationForm comorSelection :: [(String, String, [Attr])]
comorSelection =
      let selectElement :: Element
selectElement =
            Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "eight wide column") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
              String
-> String -> Maybe String -> [(String, String, [Attr])] -> Element
singleSelectionDropDown "Translation" "translation" Maybe String
forall a. Maybe a
Nothing [(String, String, [Attr])]
comorSelection
        -- hidden param field with "theory=nodeid"
          hideStr :: Element
hideStr = [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "name" "theory"
              , String -> String -> Attr
mkAttr "type" "hidden", String -> String -> Attr
mkAttr "style" "display:none;"
              , String -> String -> Attr
mkAttr "value" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ Int -> String
forall a. Show a => a -> String
show Int
i ] Element
inputNode
          translateButton :: Element
translateButton =
            Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "eight wide column") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
              [Attr] -> Element -> Element
add_attrs [String -> String -> Attr
mkAttr "value" "Translate"] Element
submitButton
      in  [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "name" "translation-form", String -> String -> Attr
mkAttr "method" "get"]
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui form")
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "form"
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "ui relaxed grid container left aligned")
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div"
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row")
            (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" [Element
hideStr, Element
selectElement, Element
translateButton]


-- | show window of the autoproof function
showAutoProofWindow :: DGraph -> Int -> ProverMode
  -> ResultT IO (String, String)
showAutoProofWindow :: DGraph -> Int -> ProverMode -> ResultT IO (String, String)
showAutoProofWindow dg :: DGraph
dg sessId :: Int
sessId prOrCons :: ProverMode
prOrCons = let
  dgnodes :: [LNode DGNodeLab]
dgnodes = DGraph -> [LNode DGNodeLab]
labNodesDG DGraph
dg
  -- some parameters need to be different for consistency and autoproof mode
  (prMethod :: String
prMethod, isProver :: Bool
isProver, title :: String
title, nodeSel :: [Element]
nodeSel) = case ProverMode
prOrCons of
    GlProofs -> ("proof", Bool
True, "automatic proofs"
      , (FNode -> Element) -> [FNode] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ fn :: FNode
fn -> [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "type" "checkbox"
      , String -> String -> Attr
mkAttr "unproven" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ Bool -> String
showBool (Bool -> String) -> Bool -> String
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ FNode -> Bool
allProved FNode
fn
      , String -> String -> Attr
mkAttr "name" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ ShowS
escStr ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ FNode -> String
name FNode
fn ]
      (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "input" (String -> Element) -> String -> Element
forall a b. (a -> b) -> a -> b
$ FNode -> String
showHtml FNode
fn) ([FNode] -> [Element]) -> [FNode] -> [Element]
forall a b. (a -> b) -> a -> b
$ [LNode DGNodeLab] -> [FNode]
initFNodes [LNode DGNodeLab]
dgnodes)
    -- TODO sort out nodes with no sentences!
    GlConsistency -> ("cons", Bool
False, "consistency checker"
      , (LNode DGNodeLab -> Element) -> [LNode DGNodeLab] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ (_, dgn :: DGNodeLab
dgn) ->
      let cstat :: ConsistencyStatus
cstat = DGNodeLab -> ConsistencyStatus
getConsistencyOf DGNodeLab
dgn
          nm :: String
nm = DGNodeLab -> String
getDGNodeName DGNodeLab
dgn in [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "type" "checkbox"
      , String -> String -> Attr
mkAttr "unproven" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ Bool -> String
showBool (Bool -> String) -> Bool -> String
forall a b. (a -> b) -> a -> b
$ ConsistencyStatus -> SType
sType ConsistencyStatus
cstat SType -> SType -> Bool
forall a. Eq a => a -> a -> Bool
== SType
CSUnchecked
      , String -> String -> Attr
mkAttr "name" String
nm]
      (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "input" (ConsistencyStatus -> String
cStatusToPrefix ConsistencyStatus
cstat String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nm)) [LNode DGNodeLab]
dgnodes)
  -- generate param field for the query string, invisible to the user
  hidStr :: Element
hidStr = [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "name" "autoproof"
         , String -> String -> Attr
mkAttr "type" "hidden", String -> String -> Attr
mkAttr "style" "display:none;"
         , String -> String -> Attr
mkAttr "value" String
prMethod ] Element
inputNode
  -- select unproven, all or no nodes by button
  (btUnpr :: Element
btUnpr, btAll :: Element
btAll, btNone :: Element
btNone, jvScr1 :: String
jvScr1) = Bool -> (Element, Element, Element, String)
showSelectionButtons Bool
isProver
  (prBt :: Element
prBt, timeout :: Element
timeout) = Bool -> (Element, Element)
showProveButton Bool
isProver
  include :: Element
include = [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "type" "checkbox", String -> String -> Attr
mkAttr "checked" "true"
          , String -> String -> Attr
mkAttr "name" "includetheorems"] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "input" "include Theorems"
  goBack :: Element
goBack = String -> String -> Element
aRef ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
sessId) "return to DGraph"
  in do
    (jvScr2 :: String
jvScr2, nodeMenu :: Element
nodeMenu) <- case [LNode DGNodeLab]
dgnodes of
      -- return simple feedback if no nodes are present
      [] -> (String, Element) -> ResultT IO (String, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return ("", String -> Element
plain "nothing to prove (graph has no nodes)")
      -- otherwise
      (_, nd :: DGNodeLab
nd) : _ -> case Result G_theory -> Maybe G_theory
forall a. Result a -> Maybe a
maybeResult (Result G_theory -> Maybe G_theory)
-> Result G_theory -> Maybe G_theory
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> Result G_theory
getGlobalTheory DGNodeLab
nd of
        Nothing -> String -> ResultT IO (String, Element)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (String, Element))
-> String -> ResultT IO (String, Element)
forall a b. (a -> b) -> a -> b
$ "cannot compute global theory of:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DGNodeLab -> String
forall a. Show a => a -> String
show DGNodeLab
nd
        Just gTh :: G_theory
gTh -> do
          let br :: Element
br = String -> () -> Element
forall t. Node t => String -> t -> Element
unode "br " ()
          (prSel :: Element
prSel, cmSel :: Element
cmSel, jvSc :: String
jvSc) <- IO (Element, Element, String)
-> ResultT IO (Element, Element, String)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Element, Element, String)
 -> ResultT IO (Element, Element, String))
-> IO (Element, Element, String)
-> ResultT IO (Element, Element, String)
forall a b. (a -> b) -> a -> b
$ ProverMode -> [G_sublogics] -> IO (Element, Element, String)
showProverSelection ProverMode
prOrCons
              [G_theory -> G_sublogics
sublogicOfTh G_theory
gTh]
          (String, Element) -> ResultT IO (String, Element)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
jvSc, [Attr] -> Element -> Element
add_attrs
            [ String -> String -> Attr
mkAttr "name" "nodeSel", String -> String -> Attr
mkAttr "method" "get" ]
            (Element -> Element)
-> ([Element] -> Element) -> [Element] -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "form" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$
            [ Element
hidStr, Element
prSel, Element
cmSel, Element
br, Element
btAll, Element
btNone, Element
btUnpr, Element
timeout
            , Element
include ] [Element] -> [Element] -> [Element]
forall a. [a] -> [a] -> [a]
++ Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
intersperse Element
br (Element
prBt Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: [Element]
nodeSel))
    (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
htmlC, String -> String -> [Element] -> ShowS
htmlPage String
title (String
jvScr1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
jvScr2)
               [ Element
goBack, String -> Element
plain " ", Element
nodeMenu ] "")

showProveButton :: Bool -> (Element, Element)
showProveButton :: Bool -> (Element, Element)
showProveButton isProver :: Bool
isProver = (Element
prBt, Element
timeout) where
        prBt :: Element
prBt = [Attr] -> Element -> Element
add_attrs
          [ String -> String -> Attr
mkAttr "type" "submit"
          , String -> String -> Attr
mkAttr "class" "ui button"
          , String -> String -> Attr
mkAttr "value" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ if Bool
isProver then "Prove" else "Check"
          ] Element
inputNode
        -- create timeout field
        timeout :: Element
timeout = Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "three wide field") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
          [ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "label" "Timeout (Sec/Goal)"
          , [Attr] -> Element -> Element
add_attrs
              [ String -> String -> Attr
mkAttr "type" "text"
              , String -> String -> Attr
mkAttr "name" "timeout"
              , String -> String -> Attr
mkAttr "placeholder" "Timeout (Sec/Goal)"
              , String -> String -> Attr
mkAttr "value" "1"
              ] (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "input" ""
          ]

-- | select unproven, all or none theorems by button
showSelectionButtons :: Bool -> (Element, Element, Element, String)
showSelectionButtons :: Bool -> (Element, Element, Element, String)
showSelectionButtons isProver :: Bool
isProver = (Element
selUnPr, Element
selAll, Element
selNone, String
jvScr)
  where prChoice :: String
prChoice = if Bool
isProver then "SPASS" else "darwin"
        selUnPr :: Element
selUnPr = [Attr] -> Element -> Element
add_attrs
          [ String -> String -> Attr
mkAttr "type" "button"
          , String -> String -> Attr
mkAttr "class" "ui button"
          , String -> String -> Attr
mkAttr "value" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ if Bool
isProver then "Unproven" else "Unchecked"
          , String -> String -> Attr
mkAttr "onClick" "chkUnproven()"
          ] Element
inputNode
        selAll :: Element
selAll = [Attr] -> Element -> Element
add_attrs
          [ String -> String -> Attr
mkAttr "type" "button", String -> String -> Attr
mkAttr "value" "All"
          , String -> String -> Attr
mkAttr "class" "ui button"
          , String -> String -> Attr
mkAttr "onClick" "chkAll(true)"
          ] Element
inputNode
        selNone :: Element
selNone = [Attr] -> Element -> Element
add_attrs
          [ String -> String -> Attr
mkAttr "type" "button", String -> String -> Attr
mkAttr "value" "None"
          , String -> String -> Attr
mkAttr "class" "ui button"
          , String -> String -> Attr
mkAttr "onClick" "chkAll(false)"
          ] Element
inputNode
        -- javascript features
        jvScr :: String
jvScr = [String] -> String
unlines
          -- select unproven goals by button
          [ "\nfunction chkUnproven() {"
          , "  var e = document.forms[0].elements;"
          , "  for (i = 0; i < e.length; i++) {"
          , "    if( e[i].type == 'checkbox'"
          , "      && e[i].name != 'includetheorems' )"
          , "      e[i].checked = e[i].getAttribute('unproven') == 'true';"
          , "  }"
          -- select or deselect all theorems by button
          , "}\nfunction chkAll(b) {"
          , "  var e = document.forms[0].elements;"
          , "  for (i = 0; i < e.length; i++) {"
          , "    if( e[i].type == 'checkbox'"
          , "      && e[i].name != 'includetheorems' ) e[i].checked = b;"
          , "  }"
          -- autoselect SPASS if possible
          , "}\nwindow.onload = function() {"
          , "  prSel = document.forms[0].elements.namedItem('prover');"
          , "  prs = prSel.getElementsByTagName('option');"
          , "  for ( i=0; i<prs.length; i++ ) {"
          , "    if( prs[i].value == '" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prChoice String -> ShowS
forall a. [a] -> [a] -> [a]
++ "' ) {"
          , "      prs[i].selected = 'selected';"
          , "      updCmSel('" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
prChoice String -> ShowS
forall a. [a] -> [a] -> [a]
++ "');"
          , "      return;"
          , "    }"
          , "  }"
          -- if SPASS unable, select first one in list
          , "  prs[0].selected = 'selected';"
          , "  updCmSel( prs[0].value );"
          , "}" ]

-- | create prover and comorphism menu and combine them using javascript
showProverSelection :: ProverMode -> [G_sublogics]
  -> IO (Element, Element, String)
showProverSelection :: ProverMode -> [G_sublogics] -> IO (Element, Element, String)
showProverSelection prOrCons :: ProverMode
prOrCons subLs :: [G_sublogics]
subLs = do
  let jvScr :: String
jvScr = [String] -> String
unlines
        -- the chosen prover is passed as param
        [ "\nfunction updCmSel(pr) {"
        , "  var cmrSl = document.forms[0].elements.namedItem('translation');"
        -- then, all selectable comorphisms are gathered and iterated
        , "  var opts = cmrSl.getElementsByTagName('option');"
        -- try to keep current comorph-selection
        , "  var selAccept = false;"
        , "  for( var i = opts.length-1; i >= 0; i-- ) {"
        , "    var cmr = opts.item( i );"
        -- the list of supported provers is extracted
        , "    var prs = cmr.getAttribute('4prover').split(';');"
        , "    var pFit = false;"
        , "    for( var j = 0; ! pFit && j < prs.length; j++ ) {"
        , "      pFit = prs[j] == pr;"
        , "    }"
        -- if prover is supported, remove disabled attribute
        , "    if( pFit ) {"
        , "        cmr.removeAttribute('disabled');"
        , "        selAccept = selAccept || cmr.selected;"
        -- else create and append a disabled attribute
        , "    } else {"
        , "      var ds = document.createAttribute('disabled');"
        , "      ds.value = 'disabled';"
        , "      cmr.setAttributeNode(ds);"
        , "    }"
        , "  }"
        -- check if selected comorphism fits, and select fst. in list otherwise
        , "  if( ! selAccept ) {"
        , "    for( i = 0; i < opts.length; i++ ) {"
        , "      if( ! opts.item(i).disabled ) {"
        , "        opts.item(i).selected = 'selected';"
        , "        return;"
        , "      }"
        , "    }"
        , "  }"
        , "}" ]
  [[(AnyComorphism, [String])]]
pcs <- (G_sublogics -> IO [(AnyComorphism, [String])])
-> [G_sublogics] -> IO [[(AnyComorphism, [String])]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (([(AnyComorphism, [ProverOrConsChecker])]
 -> [(AnyComorphism, [String])])
-> IO [(AnyComorphism, [ProverOrConsChecker])]
-> IO [(AnyComorphism, [String])]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [(AnyComorphism, [ProverOrConsChecker])]
-> [(AnyComorphism, [String])]
proversToStringAux (IO [(AnyComorphism, [ProverOrConsChecker])]
 -> IO [(AnyComorphism, [String])])
-> (G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> G_sublogics
-> IO [(AnyComorphism, [String])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (case ProverMode
prOrCons of
    GlProofs -> Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getProversAux
    GlConsistency -> Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getConsCheckersAux) Maybe String
forall a. Maybe a
Nothing) [G_sublogics]
subLs
  let allPrCm :: [(AnyComorphism, [String])]
allPrCm = [(AnyComorphism, [String])] -> [(AnyComorphism, [String])]
forall a. Eq a => [a] -> [a]
nub ([(AnyComorphism, [String])] -> [(AnyComorphism, [String])])
-> [(AnyComorphism, [String])] -> [(AnyComorphism, [String])]
forall a b. (a -> b) -> a -> b
$ [[(AnyComorphism, [String])]] -> [(AnyComorphism, [String])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(AnyComorphism, [String])]]
pcs
  -- create prover selection (drop-down)
      prs :: Element
prs = Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "eight wide column") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
        String
-> String -> Maybe String -> [(String, String, [Attr])] -> Element
singleSelectionDropDown "Prover" "prover" Maybe String
forall a. Maybe a
Nothing ([(String, String, [Attr])] -> Element)
-> [(String, String, [Attr])] -> Element
forall a b. (a -> b) -> a -> b
$
          (String -> (String, String, [Attr]))
-> [String] -> [(String, String, [Attr])]
forall a b. (a -> b) -> [a] -> [b]
map (\ p :: String
p ->
                (String
p, String
p, [String -> String -> Attr
mkAttr "onClick" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ "updCmSel('" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
p String -> ShowS
forall a. [a] -> [a] -> [a]
++ "')"])
              ) ([String] -> [(String, String, [Attr])])
-> [String] -> [(String, String, [Attr])]
forall a b. (a -> b) -> a -> b
$ [(AnyComorphism, [String])] -> [String]
showProversOnly [(AnyComorphism, [String])]
allPrCm
  -- create comorphism selection (drop-down)
      cmrs :: Element
cmrs = Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "eight wide column") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$
        String
-> String -> Maybe String -> [(String, String, [Attr])] -> Element
singleSelectionDropDown "Translation" "translation" Maybe String
forall a. Maybe a
Nothing ([(String, String, [Attr])] -> Element)
-> [(String, String, [Attr])] -> Element
forall a b. (a -> b) -> a -> b
$
          ((AnyComorphism, [String]) -> (String, String, [Attr]))
-> [(AnyComorphism, [String])] -> [(String, String, [Attr])]
forall a b. (a -> b) -> [a] -> [b]
map (\ (cm :: AnyComorphism
cm, ps :: [String]
ps) -> let c :: String
c = AnyComorphism -> String
showComorph AnyComorphism
cm in
                (String
c, String
c, [String -> String -> Attr
mkAttr "4prover" (String -> Attr) -> String -> Attr
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate ";" [String]
ps])
              ) [(AnyComorphism, [String])]
allPrCm
  (Element, Element, String) -> IO (Element, Element, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Element
prs, Element
cmrs, String
jvScr)

showHtml :: FNode -> String
showHtml :: FNode -> String
showHtml fn :: FNode
fn = FNode -> String
name FNode
fn String -> ShowS
forall a. [a] -> [a] -> [a]
++ " " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Goal] -> String
goalsToPrefix (FNode -> [Goal]
toGtkGoals FNode
fn)

getAllAutomaticProvers :: G_sublogics -> IO [(G_prover, AnyComorphism)]
getAllAutomaticProvers :: G_sublogics -> IO [(G_prover, AnyComorphism)]
getAllAutomaticProvers subL :: G_sublogics
subL =
  ProverKind
-> G_sublogics -> LogicGraph -> IO [(G_prover, AnyComorphism)]
getUsableProvers ProverKind
ProveCMDLautomatic G_sublogics
subL LogicGraph
logicGraph

filterByProver :: Maybe String -> [(G_prover, AnyComorphism)]
  -> [(G_prover, AnyComorphism)]
filterByProver :: Maybe String
-> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
filterByProver mp :: Maybe String
mp = case Maybe String
mp of
      Nothing -> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
forall a. a -> a
id
      Just p :: String
p -> ((G_prover, AnyComorphism) -> Bool)
-> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
p) (String -> Bool)
-> ((G_prover, AnyComorphism) -> String)
-> (G_prover, AnyComorphism)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
mkNiceProverName ShowS
-> ((G_prover, AnyComorphism) -> String)
-> (G_prover, AnyComorphism)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G_prover -> String
getProverName (G_prover -> String)
-> ((G_prover, AnyComorphism) -> G_prover)
-> (G_prover, AnyComorphism)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (G_prover, AnyComorphism) -> G_prover
forall a b. (a, b) -> a
fst)

filterByComorph :: Maybe String -> [(a, AnyComorphism)]
  -> [(a, AnyComorphism)]
filterByComorph :: Maybe String -> [(a, AnyComorphism)] -> [(a, AnyComorphism)]
filterByComorph mt :: Maybe String
mt = case Maybe String
mt of
      Nothing -> [(a, AnyComorphism)] -> [(a, AnyComorphism)]
forall a. a -> a
id
      Just c :: String
c -> ((a, AnyComorphism) -> Bool)
-> [(a, AnyComorphism)] -> [(a, AnyComorphism)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
c) (String -> Bool)
-> ((a, AnyComorphism) -> String) -> (a, AnyComorphism) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnyComorphism -> String
showComorph (AnyComorphism -> String)
-> ((a, AnyComorphism) -> AnyComorphism)
-> (a, AnyComorphism)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, AnyComorphism) -> AnyComorphism
forall a b. (a, b) -> b
snd)

getProverAndComorph :: Maybe String -> Maybe String -> G_sublogics
   -> IO [(G_prover, AnyComorphism)]
getProverAndComorph :: Maybe String
-> Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getProverAndComorph mp :: Maybe String
mp mc :: Maybe String
mc subL :: G_sublogics
subL = do
   [(G_prover, AnyComorphism)]
ps <- Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getFilteredProvers Maybe String
mc G_sublogics
subL
   let spps :: [(G_prover, AnyComorphism)]
spps = case Maybe String
-> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
filterByProver (String -> Maybe String
forall a. a -> Maybe a
Just "SPASS") [(G_prover, AnyComorphism)]
ps of
          [] -> [(G_prover, AnyComorphism)]
ps
          fps :: [(G_prover, AnyComorphism)]
fps -> [(G_prover, AnyComorphism)]
fps
   [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)])
-> [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)]
forall a b. (a -> b) -> a -> b
$ case Maybe String
mp of
        Nothing -> [(G_prover, AnyComorphism)]
spps
        _ -> Maybe String
-> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
filterByProver Maybe String
mp [(G_prover, AnyComorphism)]
ps

getProverList :: ProverMode -> Maybe String -> G_sublogics
              -> IO [(AnyComorphism, [ProverOrConsChecker])]
getProverList :: ProverMode
-> Maybe String
-> G_sublogics
-> IO [(AnyComorphism, [ProverOrConsChecker])]
getProverList mp :: ProverMode
mp mt :: Maybe String
mt subL :: G_sublogics
subL = case ProverMode
mp of
  GlProofs -> Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getProversAux Maybe String
mt G_sublogics
subL
  GlConsistency -> Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getConsCheckersAux Maybe String
mt G_sublogics
subL

getFullProverList :: ProverMode -> Maybe String -> DGraph
                  -> IO [(AnyComorphism, [ProverOrConsChecker])]
getFullProverList :: ProverMode
-> Maybe String
-> DGraph
-> IO [(AnyComorphism, [ProverOrConsChecker])]
getFullProverList mp :: ProverMode
mp mt :: Maybe String
mt = ([(AnyComorphism, [ProverOrConsChecker])]
 -> LNode DGNodeLab -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> [(AnyComorphism, [ProverOrConsChecker])]
-> [LNode DGNodeLab]
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
  (\ ls :: [(AnyComorphism, [ProverOrConsChecker])]
ls (_, nd :: DGNodeLab
nd) -> IO [(AnyComorphism, [ProverOrConsChecker])]
-> (G_theory -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> Maybe G_theory
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(AnyComorphism, [ProverOrConsChecker])]
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall (m :: * -> *) a. Monad m => a -> m a
return [(AnyComorphism, [ProverOrConsChecker])]
ls) (([(AnyComorphism, [ProverOrConsChecker])]
 -> [(AnyComorphism, [ProverOrConsChecker])])
-> IO [(AnyComorphism, [ProverOrConsChecker])]
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(AnyComorphism, [ProverOrConsChecker])]
-> [(AnyComorphism, [ProverOrConsChecker])]
-> [(AnyComorphism, [ProverOrConsChecker])]
forall a. [a] -> [a] -> [a]
++ [(AnyComorphism, [ProverOrConsChecker])]
ls) (IO [(AnyComorphism, [ProverOrConsChecker])]
 -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> (G_theory -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> G_theory
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. case ProverMode
mp of
      GlProofs -> Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getProversAux Maybe String
mt
      GlConsistency -> Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getConsCheckersAux Maybe String
mt
    (G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> (G_theory -> G_sublogics)
-> G_theory
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G_theory -> G_sublogics
sublogicOfTh)
    (Maybe G_theory -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> Maybe G_theory -> IO [(AnyComorphism, [ProverOrConsChecker])]
forall a b. (a -> b) -> a -> b
$ Result G_theory -> Maybe G_theory
forall a. Result a -> Maybe a
maybeResult (Result G_theory -> Maybe G_theory)
-> Result G_theory -> Maybe G_theory
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> Result G_theory
getGlobalTheory DGNodeLab
nd) [] ([LNode DGNodeLab] -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> (DGraph -> [LNode DGNodeLab])
-> DGraph
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGraph -> [LNode DGNodeLab]
labNodesDG

groupOnSnd :: Eq b => (a -> c) -> [(a, b)] -> [(b, [c])]
groupOnSnd :: (a -> c) -> [(a, b)] -> [(b, [c])]
groupOnSnd f :: a -> c
f =
  ([(a, b)] -> (b, [c])) -> [[(a, b)]] -> [(b, [c])]
forall a b. (a -> b) -> [a] -> [b]
map (\ l :: [(a, b)]
l@((_, b :: b
b) : _) -> (b
b, ((a, b) -> c) -> [(a, b)] -> [c]
forall a b. (a -> b) -> [a] -> [b]
map (a -> c
f (a -> c) -> ((a, b) -> a) -> (a, b) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, b) -> a
forall a b. (a, b) -> a
fst) [(a, b)]
l)) ([[(a, b)]] -> [(b, [c])])
-> ([(a, b)] -> [[(a, b)]]) -> [(a, b)] -> [(b, [c])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, b) -> (a, b) -> Bool) -> [(a, b)] -> [[(a, b)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ((b -> b -> Bool) -> ((a, b) -> b) -> (a, b) -> (a, b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
on b -> b -> Bool
forall a. Eq a => a -> a -> Bool
(==) (a, b) -> b
forall a b. (a, b) -> b
snd)

proversToStringAux :: [(AnyComorphism, [ProverOrConsChecker])]
                   -> [(AnyComorphism, [String])]
proversToStringAux :: [(AnyComorphism, [ProverOrConsChecker])]
-> [(AnyComorphism, [String])]
proversToStringAux = ((AnyComorphism, [ProverOrConsChecker])
 -> (AnyComorphism, [String]))
-> [(AnyComorphism, [ProverOrConsChecker])]
-> [(AnyComorphism, [String])]
forall a b. (a -> b) -> [a] -> [b]
map (\ (x :: AnyComorphism
x, ps :: [ProverOrConsChecker]
ps) ->
                           (AnyComorphism
x, (ProverOrConsChecker -> String)
-> [ProverOrConsChecker] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ShowS
mkNiceProverName ShowS
-> (ProverOrConsChecker -> String) -> ProverOrConsChecker -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProverOrConsChecker -> String
internalProverName) [ProverOrConsChecker]
ps))

{- | gather provers and comorphisms and resort them to
(comorhism, supported provers) while not changing orig comorphism order -}
getProversAux :: Maybe String -> G_sublogics
              -> IO [(AnyComorphism, [ProverOrConsChecker])]
getProversAux :: Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getProversAux mt :: Maybe String
mt x :: G_sublogics
x =
  ([(G_prover, AnyComorphism)]
 -> [(AnyComorphism, [ProverOrConsChecker])])
-> IO [(G_prover, AnyComorphism)]
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((G_prover -> ProverOrConsChecker)
-> [(G_prover, AnyComorphism)]
-> [(AnyComorphism, [ProverOrConsChecker])]
forall b a c. Eq b => (a -> c) -> [(a, b)] -> [(b, [c])]
groupOnSnd G_prover -> ProverOrConsChecker
AbsState.Prover) (IO [(G_prover, AnyComorphism)]
 -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> IO [(G_prover, AnyComorphism)]
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall a b. (a -> b) -> a -> b
$ Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getFilteredProvers Maybe String
mt G_sublogics
x

getFilteredProvers :: Maybe String -> G_sublogics
  -> IO [(G_prover, AnyComorphism)]
getFilteredProvers :: Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getFilteredProvers mt :: Maybe String
mt = ([(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)])
-> IO [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String
-> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
forall a.
Maybe String -> [(a, AnyComorphism)] -> [(a, AnyComorphism)]
filterByComorph Maybe String
mt) (IO [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)])
-> (G_sublogics -> IO [(G_prover, AnyComorphism)])
-> G_sublogics
-> IO [(G_prover, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G_sublogics -> IO [(G_prover, AnyComorphism)]
getAllAutomaticProvers

formatProvers :: ProverMode -> [(AnyComorphism, [String])] -> String
formatProvers :: ProverMode -> [(AnyComorphism, [String])] -> String
formatProvers pm :: ProverMode
pm = let
  tag :: String
tag = case ProverMode
pm of
          GlProofs -> "prover"
          GlConsistency -> "consistency-checker"
  in Element -> String
ppTopElement (Element -> String)
-> ([(AnyComorphism, [String])] -> Element)
-> [(AnyComorphism, [String])]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode (String
tag String -> ShowS
forall a. [a] -> [a] -> [a]
++ "s") ([Element] -> Element)
-> ([(AnyComorphism, [String])] -> [Element])
-> [(AnyComorphism, [String])]
-> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Element
forall t. Node t => String -> t -> Element
unode String
tag)
  ([String] -> [Element])
-> ([(AnyComorphism, [String])] -> [String])
-> [(AnyComorphism, [String])]
-> [Element]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(AnyComorphism, [String])] -> [String]
showProversOnly

-- | retrieve a list of consistency checkers
getConsCheckersAux :: Maybe String -> G_sublogics
  -> IO [(AnyComorphism, [ProverOrConsChecker])]
getConsCheckersAux :: Maybe String
-> G_sublogics -> IO [(AnyComorphism, [ProverOrConsChecker])]
getConsCheckersAux mt :: Maybe String
mt =
  ([(G_cons_checker, AnyComorphism)]
 -> [(AnyComorphism, [ProverOrConsChecker])])
-> IO [(G_cons_checker, AnyComorphism)]
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((G_cons_checker -> ProverOrConsChecker)
-> [(G_cons_checker, AnyComorphism)]
-> [(AnyComorphism, [ProverOrConsChecker])]
forall b a c. Eq b => (a -> c) -> [(a, b)] -> [(b, [c])]
groupOnSnd G_cons_checker -> ProverOrConsChecker
AbsState.ConsChecker) (IO [(G_cons_checker, AnyComorphism)]
 -> IO [(AnyComorphism, [ProverOrConsChecker])])
-> (G_sublogics -> IO [(G_cons_checker, AnyComorphism)])
-> G_sublogics
-> IO [(AnyComorphism, [ProverOrConsChecker])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe String -> G_sublogics -> IO [(G_cons_checker, AnyComorphism)]
getFilteredConsCheckers Maybe String
mt

getFilteredConsCheckers :: Maybe String -> G_sublogics
  -> IO [(G_cons_checker, AnyComorphism)]
getFilteredConsCheckers :: Maybe String -> G_sublogics -> IO [(G_cons_checker, AnyComorphism)]
getFilteredConsCheckers mt :: Maybe String
mt = ([(G_cons_checker, AnyComorphism)]
 -> [(G_cons_checker, AnyComorphism)])
-> IO [(G_cons_checker, AnyComorphism)]
-> IO [(G_cons_checker, AnyComorphism)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
  (Maybe String
-> [(G_cons_checker, AnyComorphism)]
-> [(G_cons_checker, AnyComorphism)]
forall a.
Maybe String -> [(a, AnyComorphism)] -> [(a, AnyComorphism)]
filterByComorph Maybe String
mt ([(G_cons_checker, AnyComorphism)]
 -> [(G_cons_checker, AnyComorphism)])
-> ([(G_cons_checker, AnyComorphism)]
    -> [(G_cons_checker, AnyComorphism)])
-> [(G_cons_checker, AnyComorphism)]
-> [(G_cons_checker, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((G_cons_checker, AnyComorphism) -> Bool)
-> [(G_cons_checker, AnyComorphism)]
-> [(G_cons_checker, AnyComorphism)]
forall a. (a -> Bool) -> [a] -> [a]
filter (G_cons_checker -> Bool
getCcBatch (G_cons_checker -> Bool)
-> ((G_cons_checker, AnyComorphism) -> G_cons_checker)
-> (G_cons_checker, AnyComorphism)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (G_cons_checker, AnyComorphism) -> G_cons_checker
forall a b. (a, b) -> a
fst))
  (IO [(G_cons_checker, AnyComorphism)]
 -> IO [(G_cons_checker, AnyComorphism)])
-> (G_sublogics -> IO [(G_cons_checker, AnyComorphism)])
-> G_sublogics
-> IO [(G_cons_checker, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AnyComorphism] -> IO [(G_cons_checker, AnyComorphism)]
getConsCheckers ([AnyComorphism] -> IO [(G_cons_checker, AnyComorphism)])
-> (G_sublogics -> [AnyComorphism])
-> G_sublogics
-> IO [(G_cons_checker, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogicGraph -> G_sublogics -> [AnyComorphism]
findComorphismPaths LogicGraph
logicGraph

getComorphs :: Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getComorphs :: Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getComorphs mp :: Maybe String
mp = ([(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)])
-> IO [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe String
-> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
filterByProver Maybe String
mp)
    (IO [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)])
-> (G_sublogics -> IO [(G_prover, AnyComorphism)])
-> G_sublogics
-> IO [(G_prover, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G_sublogics -> IO [(G_prover, AnyComorphism)]
getAllAutomaticProvers

getFullComorphList :: DGraph -> IO [(G_prover, AnyComorphism)]
getFullComorphList :: DGraph -> IO [(G_prover, AnyComorphism)]
getFullComorphList = ([(G_prover, AnyComorphism)]
 -> LNode DGNodeLab -> IO [(G_prover, AnyComorphism)])
-> [(G_prover, AnyComorphism)]
-> [LNode DGNodeLab]
-> IO [(G_prover, AnyComorphism)]
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
   (\ ls :: [(G_prover, AnyComorphism)]
ls (_, nd :: DGNodeLab
nd) -> IO [(G_prover, AnyComorphism)]
-> (G_theory -> IO [(G_prover, AnyComorphism)])
-> Maybe G_theory
-> IO [(G_prover, AnyComorphism)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(G_prover, AnyComorphism)]
ls)
    (([(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)])
-> IO [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([(G_prover, AnyComorphism)]
-> [(G_prover, AnyComorphism)] -> [(G_prover, AnyComorphism)]
forall a. [a] -> [a] -> [a]
++ [(G_prover, AnyComorphism)]
ls) (IO [(G_prover, AnyComorphism)] -> IO [(G_prover, AnyComorphism)])
-> (G_theory -> IO [(G_prover, AnyComorphism)])
-> G_theory
-> IO [(G_prover, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G_sublogics -> IO [(G_prover, AnyComorphism)]
getAllAutomaticProvers (G_sublogics -> IO [(G_prover, AnyComorphism)])
-> (G_theory -> G_sublogics)
-> G_theory
-> IO [(G_prover, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G_theory -> G_sublogics
sublogicOfTh)
    (Maybe G_theory -> IO [(G_prover, AnyComorphism)])
-> Maybe G_theory -> IO [(G_prover, AnyComorphism)]
forall a b. (a -> b) -> a -> b
$ Result G_theory -> Maybe G_theory
forall a. Result a -> Maybe a
maybeResult (Result G_theory -> Maybe G_theory)
-> Result G_theory -> Maybe G_theory
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> Result G_theory
getGlobalTheory DGNodeLab
nd) [] ([LNode DGNodeLab] -> IO [(G_prover, AnyComorphism)])
-> (DGraph -> [LNode DGNodeLab])
-> DGraph
-> IO [(G_prover, AnyComorphism)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGraph -> [LNode DGNodeLab]
labNodesDG

formatComorphs :: [(G_prover, AnyComorphism)] -> String
formatComorphs :: [(G_prover, AnyComorphism)] -> String
formatComorphs = Element -> String
ppTopElement (Element -> String)
-> ([(G_prover, AnyComorphism)] -> Element)
-> [(G_prover, AnyComorphism)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "translations"
    ([Element] -> Element)
-> ([(G_prover, AnyComorphism)] -> [Element])
-> [(G_prover, AnyComorphism)]
-> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String -> Element
forall t. Node t => String -> t -> Element
unode "comorphism") ([String] -> [Element])
-> ([(G_prover, AnyComorphism)] -> [String])
-> [(G_prover, AnyComorphism)]
-> [Element]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. Ord a => [a] -> [a]
nubOrd ([String] -> [String])
-> ([(G_prover, AnyComorphism)] -> [String])
-> [(G_prover, AnyComorphism)]
-> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((G_prover, AnyComorphism) -> String)
-> [(G_prover, AnyComorphism)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (AnyComorphism -> String
showComorph (AnyComorphism -> String)
-> ((G_prover, AnyComorphism) -> AnyComorphism)
-> (G_prover, AnyComorphism)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (G_prover, AnyComorphism) -> AnyComorphism
forall a b. (a, b) -> b
snd)

consNode :: LibEnv -> LibName -> DGraph -> (Int, DGNodeLab)
  -> G_sublogics -> Bool -> Maybe String -> Maybe String -> Maybe Int
  -> ResultT IO (LibEnv, [ProofResult])
consNode :: LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> ResultT IO (LibEnv, [ProofResult])
consNode le :: LibEnv
le ln :: LibName
ln dg :: DGraph
dg nl :: LNode DGNodeLab
nl@(i :: Int
i, lb :: DGNodeLab
lb) subL :: G_sublogics
subL useTh :: Bool
useTh mp :: Maybe String
mp mt :: Maybe String
mt tl :: Maybe Int
tl = do
  (cc :: G_cons_checker
cc, c :: AnyComorphism
c) <- IO (G_cons_checker, AnyComorphism)
-> ResultT IO (G_cons_checker, AnyComorphism)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (G_cons_checker, AnyComorphism)
 -> ResultT IO (G_cons_checker, AnyComorphism))
-> IO (G_cons_checker, AnyComorphism)
-> ResultT IO (G_cons_checker, AnyComorphism)
forall a b. (a -> b) -> a -> b
$ Maybe String
-> G_sublogics
-> Maybe String
-> IO (G_cons_checker, AnyComorphism)
findConsChecker Maybe String
mt G_sublogics
subL Maybe String
mp
  IO (LibEnv, [ProofResult]) -> ResultT IO (LibEnv, [ProofResult])
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (LibEnv, [ProofResult]) -> ResultT IO (LibEnv, [ProofResult]))
-> IO (LibEnv, [ProofResult]) -> ResultT IO (LibEnv, [ProofResult])
forall a b. (a -> b) -> a -> b
$ do
    ConsistencyStatus
cstat <- Bool
-> G_cons_checker
-> AnyComorphism
-> LibName
-> LibEnv
-> DGraph
-> LNode DGNodeLab
-> Int
-> IO ConsistencyStatus
consistencyCheck Bool
useTh G_cons_checker
cc AnyComorphism
c LibName
ln LibEnv
le DGraph
dg LNode DGNodeLab
nl (Int -> IO ConsistencyStatus) -> Int -> IO ConsistencyStatus
forall a b. (a -> b) -> a -> b
$ Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe 1 Maybe Int
tl
    -- Consistency Results are stored in LibEnv via DGChange object
    let cSt :: SType
cSt = ConsistencyStatus -> SType
sType ConsistencyStatus
cstat
        le'' :: LibEnv
le'' = if SType
cSt SType -> SType -> Bool
forall a. Eq a => a -> a -> Bool
== SType
CSUnchecked then LibEnv
le else
               LibName -> DGraph -> LibEnv -> LibEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert LibName
ln (DGraph -> DGChange -> DGraph
changeDGH DGraph
dg (DGChange -> DGraph) -> DGChange -> DGraph
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> LNode DGNodeLab -> DGChange
SetNodeLab DGNodeLab
lb
                 (Int
i, case SType
cSt of
                       CSInconsistent -> String -> DGNodeLab -> DGNodeLab
markNodeInconsistent "" DGNodeLab
lb
                       CSConsistent -> String -> DGNodeLab -> DGNodeLab
markNodeConsistent "" DGNodeLab
lb
                       _ -> DGNodeLab
lb)) LibEnv
le
    (LibEnv, [ProofResult]) -> IO (LibEnv, [ProofResult])
forall (m :: * -> *) a. Monad m => a -> m a
return (LibEnv
le'', [(" ", Int -> ShowS
forall a. Int -> [a] -> [a]
drop 2 ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ SType -> String
forall a. Show a => a -> String
show SType
cSt, ConsistencyStatus -> String
forall a. Show a => a -> String
show ConsistencyStatus
cstat,
                    G_cons_checker -> ProverOrConsChecker
AbsState.ConsChecker G_cons_checker
cc, AnyComorphism
c, Maybe (ProofStatus G_proof_tree)
forall a. Maybe a
Nothing, String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ ConsistencyStatus -> String
sMessage ConsistencyStatus
cstat)])

findConsChecker :: Maybe String -> G_sublogics -> Maybe String
                -> IO (G_cons_checker, AnyComorphism)
findConsChecker :: Maybe String
-> G_sublogics
-> Maybe String
-> IO (G_cons_checker, AnyComorphism)
findConsChecker translationM :: Maybe String
translationM gSublogic :: G_sublogics
gSublogic consCheckerNameM :: Maybe String
consCheckerNameM = do
  [(G_cons_checker, AnyComorphism)]
consList <- Maybe String -> G_sublogics -> IO [(G_cons_checker, AnyComorphism)]
getFilteredConsCheckers Maybe String
translationM G_sublogics
gSublogic
  let findCC :: String -> [(G_cons_checker, AnyComorphism)]
findCC x :: String
x = ((G_cons_checker, AnyComorphism) -> Bool)
-> [(G_cons_checker, AnyComorphism)]
-> [(G_cons_checker, AnyComorphism)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
x ) (String -> Bool)
-> ((G_cons_checker, AnyComorphism) -> String)
-> (G_cons_checker, AnyComorphism)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. G_cons_checker -> String
getCcName (G_cons_checker -> String)
-> ((G_cons_checker, AnyComorphism) -> G_cons_checker)
-> (G_cons_checker, AnyComorphism)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (G_cons_checker, AnyComorphism) -> G_cons_checker
forall a b. (a, b) -> a
fst) [(G_cons_checker, AnyComorphism)]
consList
      consCheckersL :: [(G_cons_checker, AnyComorphism)]
consCheckersL = [(G_cons_checker, AnyComorphism)]
-> (String -> [(G_cons_checker, AnyComorphism)])
-> Maybe String
-> [(G_cons_checker, AnyComorphism)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> [(G_cons_checker, AnyComorphism)]
findCC "darwin") String -> [(G_cons_checker, AnyComorphism)]
findCC Maybe String
consCheckerNameM
  case [(G_cons_checker, AnyComorphism)]
consCheckersL of
        [] -> String -> IO (G_cons_checker, AnyComorphism)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "no cons checker found"
        (gConsChecker :: G_cons_checker
gConsChecker, comorphism :: AnyComorphism
comorphism) : _ -> (G_cons_checker, AnyComorphism)
-> IO (G_cons_checker, AnyComorphism)
forall (m :: * -> *) a. Monad m => a -> m a
return (G_cons_checker
gConsChecker, AnyComorphism
comorphism)

reasonREST :: HetcatsOpts -> LibEnv -> LibName -> DGraph -> ProverMode
           -> String -> ReasoningParameters
           -> ResultT IO (LibEnv, [(String, [ProofResult])])
reasonREST :: HetcatsOpts
-> LibEnv
-> LibName
-> DGraph
-> ProverMode
-> String
-> ReasoningParameters
-> ResultT IO (LibEnv, [(String, [ProofResult])])
reasonREST opts :: HetcatsOpts
opts libEnv :: LibEnv
libEnv libName :: LibName
libName dGraph_ :: DGraph
dGraph_ proverMode :: ProverMode
proverMode location :: String
location reasoningParameters :: ReasoningParameters
reasoningParameters = do
  ReasoningCacheE
reasoningCacheE <- IO ReasoningCacheE -> ResultT IO ReasoningCacheE
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ReasoningCacheE
buildReasoningCache
  ReasoningCacheE -> ResultT IO ()
failOnLefts ReasoningCacheE
reasoningCacheE
  let reasoningCache1 :: [ReasoningCacheGoal]
reasoningCache1 = ReasoningCacheE -> [ReasoningCacheGoal]
forall a b. [Either a b] -> [b]
rights ReasoningCacheE
reasoningCacheE
  [ReasoningCacheGoal]
reasoningCache2 <- IO [ReasoningCacheGoal] -> ResultT IO [ReasoningCacheGoal]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ReasoningCacheGoal] -> ResultT IO [ReasoningCacheGoal])
-> IO [ReasoningCacheGoal] -> ResultT IO [ReasoningCacheGoal]
forall a b. (a -> b) -> a -> b
$ HetcatsOpts -> [ReasoningCacheGoal] -> IO [ReasoningCacheGoal]
PGIP.Server.setupReasoning HetcatsOpts
opts [ReasoningCacheGoal]
reasoningCache1
  (libEnv' :: LibEnv
libEnv', cacheGoalsAndProofResults :: [(DGNodeLab, [ProofResult])]
cacheGoalsAndProofResults) <-
    HetcatsOpts
-> LibEnv
-> LibName
-> DGraph
-> String
-> [ReasoningCacheGoal]
-> ResultT IO (LibEnv, [(DGNodeLab, [ProofResult])])
PGIP.Server.performReasoning HetcatsOpts
opts LibEnv
libEnv LibName
libName
      DGraph
dGraph_ String
location [ReasoningCacheGoal]
reasoningCache2
  let nodesAndProofResults :: [(String, [ProofResult])]
nodesAndProofResults = ((DGNodeLab, [ProofResult]) -> (String, [ProofResult]))
-> [(DGNodeLab, [ProofResult])] -> [(String, [ProofResult])]
forall a b. (a -> b) -> [a] -> [b]
map
        (\ (nodeLabel :: DGNodeLab
nodeLabel, proofResults :: [ProofResult]
proofResults) ->
          (IRI -> String
forall a. Show a => a -> String
show (NodeName -> IRI
getName (NodeName -> IRI) -> NodeName -> IRI
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> NodeName
dgn_name DGNodeLab
nodeLabel), [ProofResult]
proofResults)
        )
        [(DGNodeLab, [ProofResult])]
cacheGoalsAndProofResults
  (LibEnv, [(String, [ProofResult])])
-> ResultT IO (LibEnv, [(String, [ProofResult])])
forall (m :: * -> *) a. Monad m => a -> m a
return (LibEnv
libEnv', [(String, [ProofResult])]
nodesAndProofResults)
  where
    useDatabase :: Bool
    useDatabase :: Bool
useDatabase = ReasoningParameters -> Maybe String
format ReasoningParameters
reasoningParameters Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just "db"

    failOnLefts :: ReasoningCacheE -> ResultT IO ()
    failOnLefts :: ReasoningCacheE -> ResultT IO ()
failOnLefts reasoningCache :: ReasoningCacheE
reasoningCache =
      let lefts_ :: [String]
lefts_ = ReasoningCacheE -> [String]
forall a b. [Either a b] -> [a]
lefts ReasoningCacheE
reasoningCache
      in  Bool -> ResultT IO () -> ResultT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
lefts_) (ResultT IO () -> ResultT IO ()) -> ResultT IO () -> ResultT IO ()
forall a b. (a -> b) -> a -> b
$ String -> ResultT IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO ()) -> String -> ResultT IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String]
lefts_

    buildReasoningCache :: IO ReasoningCacheE
    buildReasoningCache :: IO ReasoningCacheE
buildReasoningCache =
      let reasoningParametersGroupedByNodeName :: [[GoalConfig]]
reasoningParametersGroupedByNodeName =
            (GoalConfig -> GoalConfig -> Bool)
-> [GoalConfig] -> [[GoalConfig]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (\ a :: GoalConfig
a b :: GoalConfig
b ->
                      GoalConfig -> String
ReasoningParameters.node GoalConfig
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== GoalConfig -> String
ReasoningParameters.node GoalConfig
b
                    ) ([GoalConfig] -> [[GoalConfig]]) -> [GoalConfig] -> [[GoalConfig]]
forall a b. (a -> b) -> a -> b
$ ReasoningParameters -> [GoalConfig]
ReasoningParameters.goals ReasoningParameters
reasoningParameters
      in  (ReasoningCacheE -> [GoalConfig] -> IO ReasoningCacheE)
-> ReasoningCacheE -> [[GoalConfig]] -> IO ReasoningCacheE
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM ReasoningCacheE -> [GoalConfig] -> IO ReasoningCacheE
buildReasoningCacheForNode [] [[GoalConfig]]
reasoningParametersGroupedByNodeName

    buildReasoningCacheForNode :: ReasoningCacheE
                               -> [ReasoningParameters.GoalConfig]
                               -> IO ReasoningCacheE
    buildReasoningCacheForNode :: ReasoningCacheE -> [GoalConfig] -> IO ReasoningCacheE
buildReasoningCacheForNode reasoningCacheE :: ReasoningCacheE
reasoningCacheE goalConfigsOfSameNode :: [GoalConfig]
goalConfigsOfSameNode =
      let nodeName :: String
nodeName = GoalConfig -> String
ReasoningParameters.node (GoalConfig -> String) -> GoalConfig -> String
forall a b. (a -> b) -> a -> b
$ [GoalConfig] -> GoalConfig
forall a. [a] -> a
head [GoalConfig]
goalConfigsOfSameNode
          nodeM :: Maybe (LNode DGNodeLab)
nodeM = (LNode DGNodeLab -> Bool)
-> [LNode DGNodeLab] -> Maybe (LNode DGNodeLab)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (\ (_, nodeLabel :: DGNodeLab
nodeLabel) ->
                         NodeName -> String
showName (DGNodeLab -> NodeName
dgn_name DGNodeLab
nodeLabel) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
nodeName
                       ) ([LNode DGNodeLab] -> Maybe (LNode DGNodeLab))
-> [LNode DGNodeLab] -> Maybe (LNode DGNodeLab)
forall a b. (a -> b) -> a -> b
$ DGraph -> [LNode DGNodeLab]
labNodesDG DGraph
dGraph_
      in  case Maybe (LNode DGNodeLab)
nodeM of
            Nothing ->
              ReasoningCacheE -> IO ReasoningCacheE
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Either String ReasoningCacheGoal
forall a b. a -> Either a b
Left ("Node \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nodeName String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\" not found")
                       Either String ReasoningCacheGoal
-> ReasoningCacheE -> ReasoningCacheE
forall a. a -> [a] -> [a]
: ReasoningCacheE
reasoningCacheE)
            Just node_ :: LNode DGNodeLab
node_@(_, nodeLabel :: DGNodeLab
nodeLabel) -> do
              let gTheoryM :: Maybe G_theory
gTheoryM = Result G_theory -> Maybe G_theory
forall a. Result a -> Maybe a
maybeResult (Result G_theory -> Maybe G_theory)
-> Result G_theory -> Maybe G_theory
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> Result G_theory
getGlobalTheory DGNodeLab
nodeLabel
              G_theory
gTheory <- case Maybe G_theory
gTheoryM of
                Nothing ->
                  String -> IO G_theory
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("Cannot compute global theory of: "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ NodeName -> String
showName (DGNodeLab -> NodeName
dgn_name DGNodeLab
nodeLabel) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n")
                Just gTheory :: G_theory
gTheory -> G_theory -> IO G_theory
forall (m :: * -> *) a. Monad m => a -> m a
return G_theory
gTheory
              let gSublogic :: G_sublogics
gSublogic = G_theory -> G_sublogics
sublogicOfTh G_theory
gTheory
              (ReasoningCacheE -> GoalConfig -> IO ReasoningCacheE)
-> ReasoningCacheE -> [GoalConfig] -> IO ReasoningCacheE
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM (String
-> LNode DGNodeLab
-> G_theory
-> G_sublogics
-> ReasoningCacheE
-> GoalConfig
-> IO ReasoningCacheE
buildReasoningCacheForGoal String
nodeName LNode DGNodeLab
node_ G_theory
gTheory G_sublogics
gSublogic)
                ReasoningCacheE
reasoningCacheE [GoalConfig]
goalConfigsOfSameNode

    buildReasoningCacheForGoal :: String
                               -> (Int, DGNodeLab)
                               -> G_theory
                               -> G_sublogics
                               -> ReasoningCacheE
                               -> ReasoningParameters.GoalConfig
                               -> IO ReasoningCacheE
    buildReasoningCacheForGoal :: String
-> LNode DGNodeLab
-> G_theory
-> G_sublogics
-> ReasoningCacheE
-> GoalConfig
-> IO ReasoningCacheE
buildReasoningCacheForGoal nodeName :: String
nodeName node_ :: LNode DGNodeLab
node_ gTheory :: G_theory
gTheory gSublogic :: G_sublogics
gSublogic reasoningCacheE :: ReasoningCacheE
reasoningCacheE goalConfig :: GoalConfig
goalConfig =
      let reasonerM :: Maybe String
reasonerM = ReasonerConfiguration -> Maybe String
reasoner (ReasonerConfiguration -> Maybe String)
-> ReasonerConfiguration -> Maybe String
forall a b. (a -> b) -> a -> b
$ GoalConfig -> ReasonerConfiguration
reasonerConfiguration GoalConfig
goalConfig
          translationM :: Maybe String
translationM = GoalConfig -> Maybe String
translation GoalConfig
goalConfig
          timeLimit_ :: Int
timeLimit_ = ReasonerConfiguration -> Int
ReasoningParameters.timeLimit (ReasonerConfiguration -> Int) -> ReasonerConfiguration -> Int
forall a b. (a -> b) -> a -> b
$
            GoalConfig -> ReasonerConfiguration
reasonerConfiguration GoalConfig
goalConfig
          caseReasoningCacheEntry :: ReasoningCacheGoal
caseReasoningCacheEntry = ReasoningCacheGoal :: ProverMode
-> LNode DGNodeLab
-> Maybe String
-> GoalConfig
-> G_theory
-> G_sublogics
-> ProverOrConsChecker
-> AnyComorphism
-> Int
-> Bool
-> Maybe ReasonerConfigurationId
-> Maybe ReasoningAttemptId
-> ReasoningCacheGoal
ReasoningCacheGoal
            { rceProverMode :: ProverMode
rceProverMode = ProverMode
proverMode
            , rceNode :: LNode DGNodeLab
rceNode = LNode DGNodeLab
node_
            , rceGoalNameM :: Maybe String
rceGoalNameM = Maybe String
forall a. Maybe a
Nothing
            , rceGoalConfig :: GoalConfig
rceGoalConfig = GoalConfig
goalConfig
            , rceGTheory :: G_theory
rceGTheory = G_theory
gTheory
            , rceGSublogic :: G_sublogics
rceGSublogic = G_sublogics
gSublogic
            , rceReasoner :: ProverOrConsChecker
rceReasoner = ProverOrConsChecker
forall a. HasCallStack => a
undefined -- will be overwritten a few lines below
            , rceComorphism :: AnyComorphism
rceComorphism = AnyComorphism
forall a. HasCallStack => a
undefined -- will be overwritten a few lines below
            , rceTimeLimit :: Int
rceTimeLimit = Int
timeLimit_
            , rceUseDatabase :: Bool
rceUseDatabase = Bool
useDatabase
            , rceReasonerConfigurationKeyM :: Maybe ReasonerConfigurationId
rceReasonerConfigurationKeyM = Maybe ReasonerConfigurationId
forall a. Maybe a
Nothing
            , rceReasoningAttemptKeyM :: Maybe ReasoningAttemptId
rceReasoningAttemptKeyM = Maybe ReasoningAttemptId
forall a. Maybe a
Nothing
            }
      in  case ProverMode
proverMode of
            GlConsistency -> do
              (gConsChecker :: G_cons_checker
gConsChecker, comorphism :: AnyComorphism
comorphism) <-
                Maybe String
-> G_sublogics
-> Maybe String
-> IO (G_cons_checker, AnyComorphism)
findConsChecker Maybe String
translationM G_sublogics
gSublogic Maybe String
reasonerM
              ReasoningCacheE -> IO ReasoningCacheE
forall (m :: * -> *) a. Monad m => a -> m a
return ((ReasoningCacheGoal -> Either String ReasoningCacheGoal
forall a b. b -> Either a b
Right (ReasoningCacheGoal -> Either String ReasoningCacheGoal)
-> ReasoningCacheGoal -> Either String ReasoningCacheGoal
forall a b. (a -> b) -> a -> b
$ ReasoningCacheGoal
caseReasoningCacheEntry
                       { rceReasoner :: ProverOrConsChecker
rceReasoner = G_cons_checker -> ProverOrConsChecker
AbsState.ConsChecker G_cons_checker
gConsChecker
                       , rceComorphism :: AnyComorphism
rceComorphism = AnyComorphism
comorphism
                       }
                     ) Either String ReasoningCacheGoal
-> ReasoningCacheE -> ReasoningCacheE
forall a. a -> [a] -> [a]
: ReasoningCacheE
reasoningCacheE)
            GlProofs -> do
              [(G_prover, AnyComorphism)]
proversAndComorphisms <-
                Maybe String
-> Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getProverAndComorph Maybe String
reasonerM Maybe String
translationM G_sublogics
gSublogic
              (gProver :: G_prover
gProver, comorphism :: AnyComorphism
comorphism) <- case [(G_prover, AnyComorphism)]
proversAndComorphisms of
                [] -> String -> IO (G_prover, AnyComorphism)
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("No matching translation or prover found for "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
nodeName String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n")
                (gProver :: G_prover
gProver, comorphism :: AnyComorphism
comorphism) : _ ->
                  (G_prover, AnyComorphism) -> IO (G_prover, AnyComorphism)
forall (m :: * -> *) a. Monad m => a -> m a
return (G_prover
gProver, AnyComorphism
comorphism)
              let possibleGoalNames :: [String]
possibleGoalNames = ((String, Maybe BasicProof) -> String)
-> [(String, Maybe BasicProof)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe BasicProof) -> String
forall a b. (a, b) -> a
fst ([(String, Maybe BasicProof)] -> [String])
-> [(String, Maybe BasicProof)] -> [String]
forall a b. (a -> b) -> a -> b
$ G_theory -> [(String, Maybe BasicProof)]
getThGoals G_theory
gTheory :: [String]
              let goalNames :: [String]
goalNames = (case GoalConfig -> Maybe String
conjecture GoalConfig
goalConfig of
                    Nothing -> [String]
possibleGoalNames
                    Just goalName_ :: String
goalName_ ->
                      (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
goalName_) [String]
possibleGoalNames) :: [String]
              ReasoningCacheE -> IO ReasoningCacheE
forall (m :: * -> *) a. Monad m => a -> m a
return
                ((String -> Either String ReasoningCacheGoal)
-> [String] -> ReasoningCacheE
forall a b. (a -> b) -> [a] -> [b]
map (\ goalName_ :: String
goalName_ -> ReasoningCacheGoal -> Either String ReasoningCacheGoal
forall a b. b -> Either a b
Right (ReasoningCacheGoal -> Either String ReasoningCacheGoal)
-> ReasoningCacheGoal -> Either String ReasoningCacheGoal
forall a b. (a -> b) -> a -> b
$ ReasoningCacheGoal
caseReasoningCacheEntry
                       { rceGoalNameM :: Maybe String
rceGoalNameM = String -> Maybe String
forall a. a -> Maybe a
Just String
goalName_
                       , rceReasoner :: ProverOrConsChecker
rceReasoner = G_prover -> ProverOrConsChecker
AbsState.Prover G_prover
gProver
                       , rceComorphism :: AnyComorphism
rceComorphism = AnyComorphism
comorphism
                       }
                     ) [String]
goalNames ReasoningCacheE -> ReasoningCacheE -> ReasoningCacheE
forall a. [a] -> [a] -> [a]
++ ReasoningCacheE
reasoningCacheE)

setupReasoning :: HetcatsOpts -> ReasoningCache -> IO ReasoningCache
setupReasoning :: HetcatsOpts -> [ReasoningCacheGoal] -> IO [ReasoningCacheGoal]
setupReasoning opts :: HetcatsOpts
opts reasoningCache :: [ReasoningCacheGoal]
reasoningCache =
  (ReasoningCacheGoal -> IO ReasoningCacheGoal)
-> [ReasoningCacheGoal] -> IO [ReasoningCacheGoal]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ reasoningCacheGoal :: ReasoningCacheGoal
reasoningCacheGoal -> do
         Maybe ReasonerConfigurationId
reasoningConfigurationKey <-
           HetcatsOpts
-> ReasoningCacheGoal -> IO (Maybe ReasonerConfigurationId)
Persistence.Reasoning.setupReasoning HetcatsOpts
opts ReasoningCacheGoal
reasoningCacheGoal
         ReasoningCacheGoal -> IO ReasoningCacheGoal
forall (m :: * -> *) a. Monad m => a -> m a
return ReasoningCacheGoal
reasoningCacheGoal
           { rceReasonerConfigurationKeyM :: Maybe ReasonerConfigurationId
rceReasonerConfigurationKeyM = Maybe ReasonerConfigurationId
reasoningConfigurationKey }
       ) [ReasoningCacheGoal]
reasoningCache


performReasoning :: HetcatsOpts -> LibEnv -> LibName -> DGraph
                 -> String -> ReasoningCache
                 -> ResultT IO (LibEnv, [(DGNodeLab, [ProofResult])])
performReasoning :: HetcatsOpts
-> LibEnv
-> LibName
-> DGraph
-> String
-> [ReasoningCacheGoal]
-> ResultT IO (LibEnv, [(DGNodeLab, [ProofResult])])
performReasoning opts :: HetcatsOpts
opts libEnv :: LibEnv
libEnv libName :: LibName
libName dGraph_ :: DGraph
dGraph_ location :: String
location reasoningCache :: [ReasoningCacheGoal]
reasoningCache = do
  (libEnv' :: LibEnv
libEnv', nodesAndProofResults' :: [(DGNodeLab, [ProofResult])]
nodesAndProofResults') <- IO (LibEnv, [(DGNodeLab, [ProofResult])])
-> ResultT IO (LibEnv, [(DGNodeLab, [ProofResult])])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (LibEnv, [(DGNodeLab, [ProofResult])])
 -> ResultT IO (LibEnv, [(DGNodeLab, [ProofResult])]))
-> IO (LibEnv, [(DGNodeLab, [ProofResult])])
-> ResultT IO (LibEnv, [(DGNodeLab, [ProofResult])])
forall a b. (a -> b) -> a -> b
$ ((LibEnv, [(DGNodeLab, [ProofResult])])
 -> [ReasoningCacheGoal]
 -> IO (LibEnv, [(DGNodeLab, [ProofResult])]))
-> (LibEnv, [(DGNodeLab, [ProofResult])])
-> [[ReasoningCacheGoal]]
-> IO (LibEnv, [(DGNodeLab, [ProofResult])])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
    (\ (libEnvAcc1 :: LibEnv
libEnvAcc1, nodesAndProofResults1 :: [(DGNodeLab, [ProofResult])]
nodesAndProofResults1) reasoningCacheGoalsByNode :: [ReasoningCacheGoal]
reasoningCacheGoalsByNode -> do
      let nodeLabel :: DGNodeLab
nodeLabel = LNode DGNodeLab -> DGNodeLab
forall a b. (a, b) -> b
snd (LNode DGNodeLab -> DGNodeLab) -> LNode DGNodeLab -> DGNodeLab
forall a b. (a -> b) -> a -> b
$ ReasoningCacheGoal -> LNode DGNodeLab
rceNode (ReasoningCacheGoal -> LNode DGNodeLab)
-> ReasoningCacheGoal -> LNode DGNodeLab
forall a b. (a -> b) -> a -> b
$ [ReasoningCacheGoal] -> ReasoningCacheGoal
forall a. [a] -> a
head [ReasoningCacheGoal]
reasoningCacheGoalsByNode
      (libEnvAcc2 :: LibEnv
libEnvAcc2, proofResults2 :: [ProofResult]
proofResults2) <-
        ((LibEnv, [ProofResult])
 -> ReasoningCacheGoal -> IO (LibEnv, [ProofResult]))
-> (LibEnv, [ProofResult])
-> [ReasoningCacheGoal]
-> IO (LibEnv, [ProofResult])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
          (\ (libEnvAcc3 :: LibEnv
libEnvAcc3, proofResults3 :: [ProofResult]
proofResults3) reasoningCacheGoal :: ReasoningCacheGoal
reasoningCacheGoal -> do
            -- update state
            let gTheoryM :: Maybe G_theory
gTheoryM = Result G_theory -> Maybe G_theory
forall a. Result a -> Maybe a
maybeResult (Result G_theory -> Maybe G_theory)
-> Result G_theory -> Maybe G_theory
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> Result G_theory
getGlobalTheory DGNodeLab
nodeLabel
            G_theory
gTheory_ <- case Maybe G_theory
gTheoryM of
              Nothing ->
                String -> IO G_theory
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail ("Cannot compute global theory of: "
                      String -> ShowS
forall a. [a] -> [a] -> [a]
++ NodeName -> String
showName (DGNodeLab -> NodeName
dgn_name DGNodeLab
nodeLabel) String -> ShowS
forall a. [a] -> [a] -> [a]
++ "\n")
              Just gTheory_ :: G_theory
gTheory_ -> G_theory -> IO G_theory
forall (m :: * -> *) a. Monad m => a -> m a
return G_theory
gTheory_
            let reasoningCacheGoal' :: ReasoningCacheGoal
reasoningCacheGoal' = ReasoningCacheGoal
reasoningCacheGoal { rceGTheory :: G_theory
rceGTheory = G_theory
gTheory_ }

            -- preprocess (with database)
            (premisesM :: Maybe [String]
premisesM, reasoningCacheGoal3 :: ReasoningCacheGoal
reasoningCacheGoal3) <-
              HetcatsOpts
-> String
-> ReasoningCacheGoal
-> IO (Maybe [String], ReasoningCacheGoal)
Persistence.Reasoning.preprocessReasoning HetcatsOpts
opts String
location
                ReasoningCacheGoal
reasoningCacheGoal'

            -- run the reasoner
            Result _ (Just (libEnvAcc4 :: LibEnv
libEnvAcc4, proofResult :: ProofResult
proofResult : _)) <- ResultT IO (LibEnv, [ProofResult])
-> IO (Result (LibEnv, [ProofResult]))
forall (m :: * -> *) a. ResultT m a -> m (Result a)
runResultT (ResultT IO (LibEnv, [ProofResult])
 -> IO (Result (LibEnv, [ProofResult])))
-> ResultT IO (LibEnv, [ProofResult])
-> IO (Result (LibEnv, [ProofResult]))
forall a b. (a -> b) -> a -> b
$
              LibEnv
-> LibName
-> DGraph
-> ReasoningCacheGoal
-> Maybe [String]
-> ResultT IO (LibEnv, [ProofResult])
runReasoning LibEnv
libEnvAcc3 LibName
libName DGraph
dGraph_ ReasoningCacheGoal
reasoningCacheGoal3 Maybe [String]
premisesM

            -- postprocess (with database)
            HetcatsOpts
-> ReasoningCacheGoal -> Maybe [String] -> ProofResult -> IO ()
Persistence.Reasoning.postprocessReasoning HetcatsOpts
opts ReasoningCacheGoal
reasoningCacheGoal3
              Maybe [String]
premisesM ProofResult
proofResult

            -- update state
            let proofResults4 :: [ProofResult]
proofResults4 = ProofResult
proofResult ProofResult -> [ProofResult] -> [ProofResult]
forall a. a -> [a] -> [a]
: [ProofResult]
proofResults3
            (LibEnv, [ProofResult]) -> IO (LibEnv, [ProofResult])
forall (m :: * -> *) a. Monad m => a -> m a
return (LibEnv
libEnvAcc4, [ProofResult]
proofResults4)
          )
          (LibEnv
libEnvAcc1, [])
          [ReasoningCacheGoal]
reasoningCacheGoalsByNode
      (LibEnv, [(DGNodeLab, [ProofResult])])
-> IO (LibEnv, [(DGNodeLab, [ProofResult])])
forall (m :: * -> *) a. Monad m => a -> m a
return (LibEnv
libEnvAcc2, (DGNodeLab
nodeLabel, [ProofResult]
proofResults2) (DGNodeLab, [ProofResult])
-> [(DGNodeLab, [ProofResult])] -> [(DGNodeLab, [ProofResult])]
forall a. a -> [a] -> [a]
: [(DGNodeLab, [ProofResult])]
nodesAndProofResults1)
    )
    (LibEnv
libEnv, []) ([[ReasoningCacheGoal]]
 -> IO (LibEnv, [(DGNodeLab, [ProofResult])]))
-> [[ReasoningCacheGoal]]
-> IO (LibEnv, [(DGNodeLab, [ProofResult])])
forall a b. (a -> b) -> a -> b
$
    (ReasoningCacheGoal -> ReasoningCacheGoal -> Bool)
-> [ReasoningCacheGoal] -> [[ReasoningCacheGoal]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy ReasoningCacheGoal -> ReasoningCacheGoal -> Bool
sameNode [ReasoningCacheGoal]
reasoningCache
  (LibEnv, [(DGNodeLab, [ProofResult])])
-> ResultT IO (LibEnv, [(DGNodeLab, [ProofResult])])
forall (m :: * -> *) a. Monad m => a -> m a
return (LibEnv
libEnv', [(DGNodeLab, [ProofResult])]
nodesAndProofResults')
  where
    sameNode :: ReasoningCacheGoal -> ReasoningCacheGoal -> Bool
    sameNode :: ReasoningCacheGoal -> ReasoningCacheGoal -> Bool
sameNode a :: ReasoningCacheGoal
a b :: ReasoningCacheGoal
b = LNode DGNodeLab -> Int
forall a b. (a, b) -> a
fst (ReasoningCacheGoal -> LNode DGNodeLab
rceNode ReasoningCacheGoal
a) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== LNode DGNodeLab -> Int
forall a b. (a, b) -> a
fst (ReasoningCacheGoal -> LNode DGNodeLab
rceNode ReasoningCacheGoal
b)

runReasoning :: LibEnv -> LibName -> DGraph
             -> ReasoningCacheGoal -> Maybe [String]
             -> ResultT IO (LibEnv, [ProofResult])
runReasoning :: LibEnv
-> LibName
-> DGraph
-> ReasoningCacheGoal
-> Maybe [String]
-> ResultT IO (LibEnv, [ProofResult])
runReasoning libEnv :: LibEnv
libEnv libName :: LibName
libName dGraph_ :: DGraph
dGraph_ reasoningCacheGoal :: ReasoningCacheGoal
reasoningCacheGoal premisesM :: Maybe [String]
premisesM =
  let node_ :: LNode DGNodeLab
node_ = ReasoningCacheGoal -> LNode DGNodeLab
rceNode ReasoningCacheGoal
reasoningCacheGoal
      gTheory_ :: G_theory
gTheory_ = ReasoningCacheGoal -> G_theory
rceGTheory ReasoningCacheGoal
reasoningCacheGoal
      gSublogic :: G_sublogics
gSublogic = ReasoningCacheGoal -> G_sublogics
rceGSublogic ReasoningCacheGoal
reasoningCacheGoal
      useTheorems_ :: Bool
useTheorems_ = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
True (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ GoalConfig -> Maybe Bool
useTheorems (GoalConfig -> Maybe Bool) -> GoalConfig -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ ReasoningCacheGoal -> GoalConfig
rceGoalConfig ReasoningCacheGoal
reasoningCacheGoal
      reasonerM :: Maybe String
reasonerM = ReasonerConfiguration -> Maybe String
reasoner (ReasonerConfiguration -> Maybe String)
-> ReasonerConfiguration -> Maybe String
forall a b. (a -> b) -> a -> b
$ GoalConfig -> ReasonerConfiguration
reasonerConfiguration (GoalConfig -> ReasonerConfiguration)
-> GoalConfig -> ReasonerConfiguration
forall a b. (a -> b) -> a -> b
$ ReasoningCacheGoal -> GoalConfig
rceGoalConfig ReasoningCacheGoal
reasoningCacheGoal
      translationM :: Maybe String
translationM = GoalConfig -> Maybe String
translation (GoalConfig -> Maybe String) -> GoalConfig -> Maybe String
forall a b. (a -> b) -> a -> b
$ ReasoningCacheGoal -> GoalConfig
rceGoalConfig ReasoningCacheGoal
reasoningCacheGoal
      timeLimitM :: Maybe Int
timeLimitM = Int -> Maybe Int
forall a. a -> Maybe a
Just (Int -> Maybe Int) -> Int -> Maybe Int
forall a b. (a -> b) -> a -> b
$ ReasonerConfiguration -> Int
ReasoningParameters.timeLimit (ReasonerConfiguration -> Int) -> ReasonerConfiguration -> Int
forall a b. (a -> b) -> a -> b
$ GoalConfig -> ReasonerConfiguration
reasonerConfiguration (GoalConfig -> ReasonerConfiguration)
-> GoalConfig -> ReasonerConfiguration
forall a b. (a -> b) -> a -> b
$
                     ReasoningCacheGoal -> GoalConfig
rceGoalConfig ReasoningCacheGoal
reasoningCacheGoal
      goalName_ :: String
goalName_ = Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe String -> String) -> Maybe String -> String
forall a b. (a -> b) -> a -> b
$ ReasoningCacheGoal -> Maybe String
rceGoalNameM ReasoningCacheGoal
reasoningCacheGoal
      premises :: [String]
premises = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] Maybe [String]
premisesM
  in  case ReasoningCacheGoal -> ProverMode
rceProverMode ReasoningCacheGoal
reasoningCacheGoal of
        GlConsistency -> LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> ResultT IO (LibEnv, [ProofResult])
consNode LibEnv
libEnv LibName
libName DGraph
dGraph_ LNode DGNodeLab
node_ G_sublogics
gSublogic
          Bool
useTheorems_ Maybe String
reasonerM Maybe String
translationM Maybe Int
timeLimitM
        GlProofs -> LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_theory
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> [String]
-> [String]
-> ResultT IO (LibEnv, [ProofResult])
proveNode LibEnv
libEnv LibName
libName DGraph
dGraph_ LNode DGNodeLab
node_ G_theory
gTheory_ G_sublogics
gSublogic
          Bool
useTheorems_ Maybe String
reasonerM Maybe String
translationM Maybe Int
timeLimitM [String
goalName_] [String]
premises

proveNode :: LibEnv -> LibName -> DGraph -> (Int, DGNodeLab)
  -> G_theory -> G_sublogics -> Bool
  -> Maybe String -> Maybe String -> Maybe Int
  -> [String] -> [String]
  -> ResultT IO (LibEnv, [ProofResult])
proveNode :: LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_theory
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> [String]
-> [String]
-> ResultT IO (LibEnv, [ProofResult])
proveNode le :: LibEnv
le ln :: LibName
ln dg :: DGraph
dg nl :: LNode DGNodeLab
nl gTh :: G_theory
gTh subL :: G_sublogics
subL useTh :: Bool
useTh mp :: Maybe String
mp mt :: Maybe String
mt tl :: Maybe Int
tl thms :: [String]
thms axioms :: [String]
axioms = do
 [(G_prover, AnyComorphism)]
ps <- IO [(G_prover, AnyComorphism)]
-> ResultT IO [(G_prover, AnyComorphism)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [(G_prover, AnyComorphism)]
 -> ResultT IO [(G_prover, AnyComorphism)])
-> IO [(G_prover, AnyComorphism)]
-> ResultT IO [(G_prover, AnyComorphism)]
forall a b. (a -> b) -> a -> b
$ Maybe String
-> Maybe String -> G_sublogics -> IO [(G_prover, AnyComorphism)]
getProverAndComorph Maybe String
mp Maybe String
mt G_sublogics
subL
 case [(G_prover, AnyComorphism)]
ps of
  [] -> String -> ResultT IO (LibEnv, [ProofResult])
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "no matching translation or prover found"
  cp :: (G_prover, AnyComorphism)
cp : _ -> do
    let ks :: [String]
ks = ((String, Maybe BasicProof) -> String)
-> [(String, Maybe BasicProof)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe BasicProof) -> String
forall a b. (a, b) -> a
fst ([(String, Maybe BasicProof)] -> [String])
-> [(String, Maybe BasicProof)] -> [String]
forall a b. (a -> b) -> a -> b
$ G_theory -> [(String, Maybe BasicProof)]
getThGoals G_theory
gTh
        diffs :: Set String
diffs = Set String -> Set String -> Set String
forall a. Ord a => Set a -> Set a -> Set a
Set.difference ([String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
thms)
                (Set String -> Set String) -> Set String -> Set String
forall a b. (a -> b) -> a -> b
$ [String] -> Set String
forall a. Ord a => [a] -> Set a
Set.fromList [String]
ks
    Bool -> ResultT IO () -> ResultT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Set String -> Bool
forall a. Set a -> Bool
Set.null Set String
diffs) (ResultT IO () -> ResultT IO ())
-> (String -> ResultT IO ()) -> String -> ResultT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ResultT IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO ()) -> String -> ResultT IO ()
forall a b. (a -> b) -> a -> b
$ "unknown theorems: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Set String -> String
forall a. Show a => a -> String
show Set String
diffs
    Bool -> ResultT IO () -> ResultT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
thms Bool -> Bool -> Bool
&& [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
ks) (ResultT IO () -> ResultT IO ()) -> ResultT IO () -> ResultT IO ()
forall a b. (a -> b) -> a -> b
$ String -> ResultT IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail "no theorems to prove"
    let selectedGoals_ :: [String]
selectedGoals_ = if [String] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
thms then [String]
ks else [String]
thms
    let timeLimit_ :: Int
timeLimit_ = Int -> (Int -> Int) -> Maybe Int -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe 1 (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max 1) Maybe Int
tl
    (nTh :: G_theory
nTh, sens :: [(String, String, String)]
sens, proofStatuses :: [ProofStatus G_proof_tree]
proofStatuses) <- do
      let premises :: [String]
premises = [String]
axioms
      ((nTh :: G_theory
nTh, sens :: [(String, String, String)]
sens), (_, proofStatuses :: [ProofStatus G_proof_tree]
proofStatuses)) <-
        Bool
-> Int
-> [String]
-> [String]
-> G_theory
-> (G_prover, AnyComorphism)
-> ResultT
     IO
     ((G_theory, [(String, String, String)]),
      (ProofState, [ProofStatus G_proof_tree]))
autoProofAtNode Bool
useTh Int
timeLimit_ [String]
selectedGoals_ [String]
premises G_theory
gTh (G_prover, AnyComorphism)
cp
      (G_theory, [(String, String, String)], [ProofStatus G_proof_tree])
-> ResultT
     IO
     (G_theory, [(String, String, String)], [ProofStatus G_proof_tree])
forall (m :: * -> *) a. Monad m => a -> m a
return (G_theory
nTh, [(String, String, String)]
sens, [ProofStatus G_proof_tree]
proofStatuses)
    (LibEnv, [ProofResult]) -> ResultT IO (LibEnv, [ProofResult])
forall (m :: * -> *) a. Monad m => a -> m a
return ( if [(String, String, String)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(String, String, String)]
sens
             then LibEnv
le
             else LibName -> DGraph -> LibEnv -> LibEnv
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert LibName
ln ( LibEnv
-> LibName -> DGraph -> LNode DGNodeLab -> G_theory -> DGraph
updateLabelTheory LibEnv
le LibName
ln DGraph
dg LNode DGNodeLab
nl G_theory
nTh) LibEnv
le
           , [(String, String, String)]
-> (G_prover, AnyComorphism)
-> [ProofStatus G_proof_tree]
-> [ProofResult]
combineToProofResult [(String, String, String)]
sens (G_prover, AnyComorphism)
cp [ProofStatus G_proof_tree]
proofStatuses
           )

combineToProofResult :: [(String, String, String)] -> (G_prover, AnyComorphism)
  -> [ProofStatus G_proof_tree] -> [ProofResult]
combineToProofResult :: [(String, String, String)]
-> (G_prover, AnyComorphism)
-> [ProofStatus G_proof_tree]
-> [ProofResult]
combineToProofResult sens :: [(String, String, String)]
sens (prover :: G_prover
prover, comorphism :: AnyComorphism
comorphism) proofStatuses :: [ProofStatus G_proof_tree]
proofStatuses = let
  findProofStatusByName :: String -> Maybe (ProofStatus G_proof_tree)
  findProofStatusByName :: String -> Maybe (ProofStatus G_proof_tree)
findProofStatusByName n :: String
n =
    case (ProofStatus G_proof_tree -> Bool)
-> [ProofStatus G_proof_tree] -> [ProofStatus G_proof_tree]
forall a. (a -> Bool) -> [a] -> [a]
filter ((String
n String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==) (String -> Bool)
-> (ProofStatus G_proof_tree -> String)
-> ProofStatus G_proof_tree
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProofStatus G_proof_tree -> String
forall proof_tree. ProofStatus proof_tree -> String
goalName) [ProofStatus G_proof_tree]
proofStatuses of
      [] -> Maybe (ProofStatus G_proof_tree)
forall a. Maybe a
Nothing
      (ps :: ProofStatus G_proof_tree
ps : _) -> ProofStatus G_proof_tree -> Maybe (ProofStatus G_proof_tree)
forall a. a -> Maybe a
Just ProofStatus G_proof_tree
ps
  combineSens :: (String, String, String) -> ProofResult
  combineSens :: (String, String, String) -> ProofResult
combineSens (n :: String
n, e :: String
e, d :: String
d) = (String
n, String
e, String
d, G_prover -> ProverOrConsChecker
AbsState.Prover G_prover
prover, AnyComorphism
comorphism,
                           String -> Maybe (ProofStatus G_proof_tree)
findProofStatusByName String
n, Maybe String
forall a. Maybe a
Nothing)
  in ((String, String, String) -> ProofResult)
-> [(String, String, String)] -> [ProofResult]
forall a b. (a -> b) -> [a] -> [b]
map (String, String, String) -> ProofResult
combineSens [(String, String, String)]
sens

-- run over multiple dgnodes and prove available goals for each
proveMultiNodes :: ProverMode -> LibEnv -> LibName -> DGraph
  -> Bool -> Maybe String -> Maybe String -> Maybe Int -> [String] -> [String]
  -> ResultT IO (LibEnv, [(String, [ProofResult])])
proveMultiNodes :: ProverMode
-> LibEnv
-> LibName
-> DGraph
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> [String]
-> [String]
-> ResultT IO (LibEnv, [(String, [ProofResult])])
proveMultiNodes pm :: ProverMode
pm le :: LibEnv
le ln :: LibName
ln dg :: DGraph
dg useTh :: Bool
useTh mp :: Maybe String
mp mt :: Maybe String
mt tl :: Maybe Int
tl nodeSel :: [String]
nodeSel axioms :: [String]
axioms = let
  runProof :: LibEnv -> G_theory -> (Int, DGNodeLab)
    -> ResultT IO (LibEnv, [ProofResult])
  runProof :: LibEnv
-> G_theory
-> LNode DGNodeLab
-> ResultT IO (LibEnv, [ProofResult])
runProof le' :: LibEnv
le' gTh :: G_theory
gTh nl :: LNode DGNodeLab
nl = let
    subL :: G_sublogics
subL = G_theory -> G_sublogics
sublogicOfTh G_theory
gTh
    dg' :: DGraph
dg' = LibName -> LibEnv -> DGraph
lookupDGraph LibName
ln LibEnv
le' in case ProverMode
pm of
    GlConsistency -> LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> ResultT IO (LibEnv, [ProofResult])
consNode LibEnv
le' LibName
ln DGraph
dg' LNode DGNodeLab
nl G_sublogics
subL Bool
useTh Maybe String
mp Maybe String
mt Maybe Int
tl
    GlProofs ->
      LibEnv
-> LibName
-> DGraph
-> LNode DGNodeLab
-> G_theory
-> G_sublogics
-> Bool
-> Maybe String
-> Maybe String
-> Maybe Int
-> [String]
-> [String]
-> ResultT IO (LibEnv, [ProofResult])
proveNode LibEnv
le' LibName
ln DGraph
dg' LNode DGNodeLab
nl G_theory
gTh G_sublogics
subL Bool
useTh Maybe String
mp Maybe String
mt Maybe Int
tl
        (((String, Maybe BasicProof) -> String)
-> [(String, Maybe BasicProof)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe BasicProof) -> String
forall a b. (a, b) -> a
fst ([(String, Maybe BasicProof)] -> [String])
-> [(String, Maybe BasicProof)] -> [String]
forall a b. (a -> b) -> a -> b
$ G_theory -> [(String, Maybe BasicProof)]
getThGoals G_theory
gTh) [String]
axioms
  nodes2check :: [LNode DGNodeLab]
nodes2check = (LNode DGNodeLab -> Bool) -> [LNode DGNodeLab] -> [LNode DGNodeLab]
forall a. (a -> Bool) -> [a] -> [a]
filter (case [String]
nodeSel of
    [] -> case ProverMode
pm of
            GlConsistency -> Bool -> LNode DGNodeLab -> Bool
forall a b. a -> b -> a
const Bool
True
            GlProofs -> DGNodeLab -> Bool
hasOpenGoals (DGNodeLab -> Bool)
-> (LNode DGNodeLab -> DGNodeLab) -> LNode DGNodeLab -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LNode DGNodeLab -> DGNodeLab
forall a b. (a, b) -> b
snd
    _ -> (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
nodeSel) (String -> Bool)
-> (LNode DGNodeLab -> String) -> LNode DGNodeLab -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DGNodeLab -> String
getDGNodeName (DGNodeLab -> String)
-> (LNode DGNodeLab -> DGNodeLab) -> LNode DGNodeLab -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LNode DGNodeLab -> DGNodeLab
forall a b. (a, b) -> b
snd) ([LNode DGNodeLab] -> [LNode DGNodeLab])
-> [LNode DGNodeLab] -> [LNode DGNodeLab]
forall a b. (a -> b) -> a -> b
$ DGraph -> [LNode DGNodeLab]
labNodesDG DGraph
dg
  in ((LibEnv, [(String, [ProofResult])])
 -> LNode DGNodeLab
 -> ResultT IO (LibEnv, [(String, [ProofResult])]))
-> (LibEnv, [(String, [ProofResult])])
-> [LNode DGNodeLab]
-> ResultT IO (LibEnv, [(String, [ProofResult])])
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM
  (\ (le' :: LibEnv
le', res :: [(String, [ProofResult])]
res) nl :: LNode DGNodeLab
nl@(_, dgn :: DGNodeLab
dgn) ->
    case Result G_theory -> Maybe G_theory
forall a. Result a -> Maybe a
maybeResult (Result G_theory -> Maybe G_theory)
-> Result G_theory -> Maybe G_theory
forall a b. (a -> b) -> a -> b
$ DGNodeLab -> Result G_theory
getGlobalTheory DGNodeLab
dgn of
      Nothing -> String -> ResultT IO (LibEnv, [(String, [ProofResult])])
forall (m :: * -> *) a. MonadFail m => String -> m a
Fail.fail (String -> ResultT IO (LibEnv, [(String, [ProofResult])]))
-> String -> ResultT IO (LibEnv, [(String, [ProofResult])])
forall a b. (a -> b) -> a -> b
$
                    "cannot compute global theory of:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ DGNodeLab -> String
forall a. Show a => a -> String
show DGNodeLab
dgn
      Just gTh :: G_theory
gTh -> do
        (le'' :: LibEnv
le'', proofResults :: [ProofResult]
proofResults) <- LibEnv
-> G_theory
-> LNode DGNodeLab
-> ResultT IO (LibEnv, [ProofResult])
runProof LibEnv
le' G_theory
gTh LNode DGNodeLab
nl
        (LibEnv, [(String, [ProofResult])])
-> ResultT IO (LibEnv, [(String, [ProofResult])])
forall (m :: * -> *) a. Monad m => a -> m a
return (LibEnv
le'', (DGNodeLab -> String
getDGNodeName DGNodeLab
dgn, [ProofResult]
proofResults) (String, [ProofResult])
-> [(String, [ProofResult])] -> [(String, [ProofResult])]
forall a. a -> [a] -> [a]
: [(String, [ProofResult])]
res)
  )
  (LibEnv
le, [])
  [LNode DGNodeLab]
nodes2check

formatResultsAux :: Bool -> ProverMode -> String -> [ProofResult] -> Element
formatResultsAux :: Bool -> ProverMode -> String -> [ProofResult] -> Element
formatResultsAux xF :: Bool
xF pm :: ProverMode
pm nm :: String
nm sens :: [ProofResult]
sens = String -> Element -> Element
forall t. Node t => String -> t -> Element
unode String
nm (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ case ([ProofResult]
sens, ProverMode
pm) of
    ([(_, e :: String
e, d :: String
d, _, _, _, _)], GlConsistency) | Bool
xF -> String -> String -> Element
formatConsNode String
e String
d
    _ -> Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "results") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div" ([Element] -> Element) -> [Element] -> Element
forall a b. (a -> b) -> a -> b
$ Bool -> [ProofResult] -> [Element]
formatGoals Bool
xF [ProofResult]
sens

mkPath :: Session -> LibName -> Int -> String
mkPath :: Session -> LibName -> Int -> String
mkPath sess :: Session
sess l :: LibName
l k :: Int
k =
        '/' Char -> ShowS
forall a. a -> [a] -> [a]
: [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [ LibName -> String
libToFileName LibName
l String -> ShowS
forall a. [a] -> [a] -> [a]
++ "?session="
                     | LibName
l LibName -> LibName -> Bool
forall a. Eq a => a -> a -> Bool
/= Session -> LibName
sessLibName Session
sess ]
        String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
k

extPath :: Session -> LibName -> Int -> String
extPath :: Session -> LibName -> Int -> String
extPath sess :: Session
sess l :: LibName
l k :: Int
k = Session -> LibName -> Int -> String
mkPath Session
sess LibName
l Int
k String -> ShowS
forall a. [a] -> [a] -> [a]
++
        if LibName
l LibName -> LibName -> Bool
forall a. Eq a => a -> a -> Bool
/= Session -> LibName
sessLibName Session
sess then "&" else "?"

globalCommands :: [String]
globalCommands :: [String]
globalCommands = ((GlobCmd, LibName -> LibEnv -> Result LibEnv) -> String)
-> [(GlobCmd, LibName -> LibEnv -> Result LibEnv)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (GlobCmd -> String
cmdlGlobCmd (GlobCmd -> String)
-> ((GlobCmd, LibName -> LibEnv -> Result LibEnv) -> GlobCmd)
-> (GlobCmd, LibName -> LibEnv -> Result LibEnv)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GlobCmd, LibName -> LibEnv -> Result LibEnv) -> GlobCmd
forall a b. (a, b) -> a
fst) [(GlobCmd, LibName -> LibEnv -> Result LibEnv)]
allGlobLibAct

sessAns :: LibName -> ResultT IO String -> (Session, Int)
  -> ResultT IO (String, String)
sessAns :: LibName
-> ResultT IO String
-> (Session, Int)
-> ResultT IO (String, String)
sessAns libName :: LibName
libName svgComp :: ResultT IO String
svgComp (sess :: Session
sess, k :: Int
k) =
  ResultT IO String
svgComp ResultT IO String
-> (String -> ResultT IO (String, String))
-> ResultT IO (String, String)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ svg :: String
svg -> (String, String) -> ResultT IO (String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((String, String) -> ResultT IO (String, String))
-> (String, String) -> ResultT IO (String, String)
forall a b. (a -> b) -> a -> b
$ LibName -> String -> (Session, Int) -> (String, String)
sessAnsAux LibName
libName String
svg (Session
sess, Int
k)

sessAnsAux :: LibName -> String -> (Session, Int) -> (String, String)
sessAnsAux :: LibName -> String -> (Session, Int) -> (String, String)
sessAnsAux libName :: LibName
libName svg :: String
svg (sess :: Session
sess, k :: Int
k) =
  let libEnv :: LibEnv
libEnv = Session -> LibEnv
sessLibEnv Session
sess
      ln :: String
ln = LibName -> String
libToFileName LibName
libName
      libref :: LibName -> (Element, [Element])
libref l :: LibName
l =
        ( String -> String -> Element
aRef (Session -> LibName -> Int -> String
mkPath Session
sess LibName
l Int
k) (LibName -> String
libToFileName LibName
l)
        , String -> String -> Element
aRef (Session -> LibName -> Int -> String
mkPath Session
sess LibName
l Int
k) "default"
            Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (\ d :: String
d -> String -> String -> Element
aRef (Session -> LibName -> Int -> String
extPath Session
sess LibName
l Int
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
d) String
d) [String]
displayTypes
        )
      libPath :: String
libPath = Session -> LibName -> Int -> String
extPath Session
sess LibName
libName Int
k
      ref :: String -> Element
ref d :: String
d = String -> String -> Element
aRef (String
libPath String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
d) String
d
      autoProofBt :: Element
autoProofBt = String -> String -> Element
aRef ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ "?autoproof") "automatic proofs"
      consBt :: Element
consBt = String -> String -> Element
aRef ('/' Char -> ShowS
forall a. a -> [a] -> [a]
: Int -> String
forall a. Show a => a -> String
show Int
k String -> ShowS
forall a. [a] -> [a] -> [a]
++ "?consistency") "consistency checker"
-- the html quicklinks to nodes and edges have been removed with R.16827
  in  ( String
htmlC
      , String -> String -> [Element] -> ShowS
htmlPage
          ("Hets, the DOLiator - (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> ShowS
forall a. Show a => a -> ShowS
shows Int
k ")" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ln)
          []
          [ Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h1" ("Library " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
ln))
          , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "div"
              [ String -> String -> Element
pageOptionsFormat "" String
libPath
              , String -> [Element] -> Element
dropDownElement "Tools" [Element
autoProofBt, Element
consBt]
              , String -> [Element] -> Element
dropDownElement "Commands" ((String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map String -> Element
ref [String]
globalCommands)
              , String -> [(Element, [Element])] -> Element
dropDownToLevelsElement "Imported Libraries" ([(Element, [Element])] -> Element)
-> [(Element, [Element])] -> Element
forall a b. (a -> b) -> a -> b
$ (LibName -> (Element, [Element]))
-> [LibName] -> [(Element, [Element])]
forall a b. (a -> b) -> [a] -> [b]
map LibName -> (Element, [Element])
libref ([LibName] -> [(Element, [Element])])
-> [LibName] -> [(Element, [Element])]
forall a b. (a -> b) -> a -> b
$ LibEnv -> [LibName]
forall k a. Map k a -> [k]
Map.keys LibEnv
libEnv
              ]
          , Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "class" "row") (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "div" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "h3" "Development Graph (click on node or edge)"
          ]
          String
svg
      )

getHetsLibContent :: HetcatsOpts -> String -> [QueryPair] -> IO [Element]
getHetsLibContent :: HetcatsOpts -> String -> [QueryPair] -> IO [Element]
getHetsLibContent opts :: HetcatsOpts
opts dir :: String
dir query :: [QueryPair]
query = do
  let hlibs :: [String]
hlibs = HetcatsOpts -> [String]
libdirs HetcatsOpts
opts
  [String]
ds <- if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
dir Bool -> Bool -> Bool
|| String -> Bool
isAbsolute String
dir then [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
hlibs else
       (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
doesDirectoryExist ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> ShowS
</> String
dir) [String]
hlibs
  [String]
fs <- ([[String]] -> [String]) -> IO [[String]] -> IO [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> String -> Ordering) -> [String] -> [String]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy String -> String -> Ordering
cmpFilePath ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf ".") ([String] -> [String])
-> ([[String]] -> [String]) -> [[String]] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat)
    (IO [[String]] -> IO [String]) -> IO [[String]] -> IO [String]
forall a b. (a -> b) -> a -> b
$ (String -> IO [String]) -> [String] -> IO [[String]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO [String]
getDirContents [String]
ds
  [Element] -> IO [Element]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Element] -> IO [Element]) -> [Element] -> IO [Element]
forall a b. (a -> b) -> a -> b
$ (String -> Element) -> [String] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ([QueryPair] -> String -> Element
mkHtmlRef [QueryPair]
query) ([String] -> [Element]) -> [String] -> [Element]
forall a b. (a -> b) -> a -> b
$ ShowS
getParent String
dir String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
fs

getParent :: String -> String
getParent :: ShowS
getParent = ShowS
addTrailingPathSeparator ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("/" String -> ShowS
</>) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
takeDirectory
  ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
dropTrailingPathSeparator

-- | a variant that adds a trailing slash
getDirContents :: FilePath -> IO [FilePath]
getDirContents :: String -> IO [String]
getDirContents d :: String
d = do
    [String]
fs <- String -> IO [String]
getDirectoryContents String
d
    (String -> IO String) -> [String] -> IO [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ f :: String
f -> String -> IO Bool
doesDirectoryExist (String
d String -> ShowS
</> String
f) IO Bool -> (Bool -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ b :: Bool
b -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return
            (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ if Bool
b then ShowS
addTrailingPathSeparator String
f else String
f) [String]
fs

aRef :: String -> String -> Element
aRef :: String -> String -> Element
aRef lnk :: String
lnk txt :: String
txt = Attr -> Element -> Element
add_attr (String -> String -> Attr
mkAttr "href" String
lnk) (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
forall t. Node t => String -> t -> Element
unode "a" String
txt

mkHtmlRef :: [QueryPair] -> String -> Element
mkHtmlRef :: [QueryPair] -> String -> Element
mkHtmlRef query :: [QueryPair]
query entry :: String
entry = String -> Element -> Element
forall t. Node t => String -> t -> Element
unode "dir" (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ String -> String -> Element
aRef
  (String
entry String -> ShowS
forall a. [a] -> [a] -> [a]
++ if [QueryPair] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [QueryPair]
query then "" else '?' Char -> ShowS
forall a. a -> [a] -> [a]
: String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "&"
         ((QueryPair -> String) -> [QueryPair] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ (x :: String
x, ms :: Maybe String
ms) -> String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> ShowS -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe "" ('=' Char -> ShowS
forall a. a -> [a] -> [a]
:) Maybe String
ms) [QueryPair]
query)) String
entry

plain :: String -> Element
plain :: String -> Element
plain = String -> String -> Element
forall t. Node t => String -> t -> Element
unode "p"

inputNode :: Element
inputNode :: Element
inputNode = String -> () -> Element
forall t. Node t => String -> t -> Element
unode "input" ()

submitButton :: Element
submitButton :: Element
submitButton = [Attr] -> Element -> Element
add_attrs
    [ String -> String -> Attr
mkAttr "type" "submit"
    , String -> String -> Attr
mkAttr "value" "submit"
    , String -> String -> Attr
mkAttr "class" "ui button"
    ] Element
inputNode

mkForm :: String -> [Element] -> Element
mkForm :: String -> [Element] -> Element
mkForm a :: String
a =
  [Attr] -> Element -> Element
add_attrs [ String -> String -> Attr
mkAttr "action" String
a
            , String -> String -> Attr
mkAttr "enctype" "multipart/form-data"
            , String -> String -> Attr
mkAttr "method" "post"
            , String -> String -> Attr
mkAttr "class" "ui basic form"
            ] (Element -> Element)
-> ([Element] -> Element) -> [Element] -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Element] -> Element
forall t. Node t => String -> t -> Element
unode "form"