{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-|
Module      : Language.Alloy.Internal.Call
Copyright   : (c) Marcellus Siegburg, 2019 - 2021
License     : MIT

This module provides the basic internal functionality to retrieve the raw
results from calling Alloy.
It provides data types and functions to interact with Alloy.
-}
module Language.Alloy.Internal.Call (
  CallAlloyConfig (maxInstances, noOverflow, timeout),
  defaultCallAlloyConfig,
  getRawInstances,
  getRawInstancesWith,
  ) where

import qualified Data.ByteString                  as BS (
  hGetLine,
  intercalate,
  stripPrefix,
  writeFile,
  )
import qualified Data.ByteString.Char8            as BS (unlines)

import Control.Concurrent (
  ThreadId,
  forkIO, killThread, newEmptyMVar, putMVar, takeMVar, threadDelay,
  )
import Control.Exception                (IOException)
import Control.Monad                    (unless, void, when)
import Data.ByteString                  (ByteString)
import Data.ByteString.Char8            (unpack)
import Data.Hashable                    (hash)
import Data.IORef                       (IORef, newIORef, readIORef)
import Data.List.Split                  (splitOn)
import Data.Maybe                       (fromMaybe)
import System.Directory
  (XdgDirectory (..), createDirectory, doesFileExist, doesDirectoryExist,
   getTemporaryDirectory, getXdgDirectory)
import System.Directory.Internal        (setFileMode)
import System.Directory.Internal.Prelude
  (catch, isDoesNotExistError)
import System.Exit                      (ExitCode (..))
import System.FilePath
  ((</>), (<.>), searchPathSeparator, takeDirectory)
import System.IO
  (BufferMode (..), Handle, hClose, hFlush, hIsEOF, hPutStr, hSetBuffering)
import System.IO.Unsafe                 (unsafePerformIO)
import System.Process (
  CreateProcess (..), StdStream (..), ProcessHandle,
  createProcess, proc, terminateProcess, waitForProcess,
  )
#if defined(mingw32_HOST_OS)
import System.Win32.Info                (getUserName)
#else
import System.Posix.User                (getLoginName)
#endif

import Language.Alloy.RessourceNames (
  alloyJarName, className, classPackage, commonsCliJarName, slf4jJarName,
  )
import Language.Alloy.Ressources (
  alloyJar,
  classFile,
  commonsCliJar,
  slf4jJar,
  )

{-|
Configuration for calling alloy. These are:

 * maximal number of instances to retrieve ('Nothing' for all)
 * whether to not overflow when calculating numbers within Alloy
 * an timeout after which to forcibly kill Alloy
   (retrieving only instances that were returned before killing the process)
-}
data CallAlloyConfig = CallAlloyConfig {
  -- | maximal number of instances to retrieve ('Nothing' for all)
  CallAlloyConfig -> Maybe Integer
maxInstances :: Maybe Integer,
  -- | whether to not overflow when calculating numbers within Alloy
  CallAlloyConfig -> Bool
noOverflow   :: Bool,
  -- | the time in microseconds after which to forcibly kill Alloy
  --   ('Nothing' for never)
  CallAlloyConfig -> Maybe Int
timeout      :: Maybe Int
  }

{-|
Default configuration for calling Alloy. Defaults to:

 * retrieve all instances
 * do not overflow
-}
defaultCallAlloyConfig :: CallAlloyConfig
defaultCallAlloyConfig :: CallAlloyConfig
defaultCallAlloyConfig = CallAlloyConfig :: Maybe Integer -> Bool -> Maybe Int -> CallAlloyConfig
CallAlloyConfig {
  maxInstances :: Maybe Integer
maxInstances = Maybe Integer
forall a. Maybe a
Nothing,
  noOverflow :: Bool
noOverflow   = Bool
True,
  timeout :: Maybe Int
timeout      = Maybe Int
forall a. Maybe a
Nothing
  }

{-# NOINLINE mclassPath #-}
{-|
'IORef' for storing the class path.
-}
mclassPath :: IORef (Maybe FilePath)
mclassPath :: IORef (Maybe FilePath)
mclassPath = IO (IORef (Maybe FilePath)) -> IORef (Maybe FilePath)
forall a. IO a -> a
unsafePerformIO (Maybe FilePath -> IO (IORef (Maybe FilePath))
forall a. a -> IO (IORef a)
newIORef Maybe FilePath
forall a. Maybe a
Nothing)

{-|
This function may be used to get all raw model instances for a given Alloy
specification. It calls Alloy via a Java interface and splits the raw instance
answers before returning the resulting list of raw instances.
-}
getRawInstances
  :: Maybe Integer
  -- ^ How many instances to return; 'Nothing' for all.
  -> String
  -- ^ The Alloy specification which should be loaded.
  -> IO [ByteString]
getRawInstances :: Maybe Integer -> FilePath -> IO [ByteString]
getRawInstances Maybe Integer
maxIs = CallAlloyConfig -> FilePath -> IO [ByteString]
getRawInstancesWith CallAlloyConfig
defaultCallAlloyConfig {
  maxInstances :: Maybe Integer
maxInstances = Maybe Integer
maxIs
  }

{-|
This function may be used to get all raw model instances for a given Alloy
specification. It calls Alloy via a Java interface and splits the raw instance
answers before returning the resulting list of raw instances.
Parameters are set using a 'CallAlloyConfig'.
-}
getRawInstancesWith
  :: CallAlloyConfig
  -- ^ The configuration to be used.
  -> String
  -- ^ The Alloy specification which should be loaded.
  -> IO [ByteString]
getRawInstancesWith :: CallAlloyConfig -> FilePath -> IO [ByteString]
getRawInstancesWith CallAlloyConfig
config FilePath
content = do
  FilePath
classPath <- IO FilePath
getClassPath
  let callAlloy :: CreateProcess
callAlloy = FilePath -> [FilePath] -> CreateProcess
proc FilePath
"java"
        ([FilePath] -> CreateProcess) -> [FilePath] -> CreateProcess
forall a b. (a -> b) -> a -> b
$ [FilePath
"-cp", FilePath
classPath, FilePath
classPackage FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
'.' Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
className,
           FilePath
"-i", Integer -> FilePath
forall a. Show a => a -> FilePath
show (Integer -> FilePath) -> Integer -> FilePath
forall a b. (a -> b) -> a -> b
$ Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe (-Integer
1) (Maybe Integer -> Integer) -> Maybe Integer -> Integer
forall a b. (a -> b) -> a -> b
$ CallAlloyConfig -> Maybe Integer
maxInstances CallAlloyConfig
config]
        [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath
"-o" | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ CallAlloyConfig -> Bool
noOverflow CallAlloyConfig
config]
  (Just Handle
hin, Just Handle
hout, Just Handle
herr, ProcessHandle
ph) <-
    CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
callAlloy {
        std_out :: StdStream
std_out = StdStream
CreatePipe,
        std_in :: StdStream
std_in  = StdStream
CreatePipe,
        std_err :: StdStream
std_err = StdStream
CreatePipe
      }
  (ThreadId, MVar [ByteString])
pout <- Handle -> IO (ThreadId, MVar [ByteString])
listenForOutput Handle
hout
  (ThreadId, MVar [ByteString])
perr <- Handle -> IO (ThreadId, MVar [ByteString])
listenForOutput Handle
herr
#ifndef mingw32_HOST_OS
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hin BufferMode
NoBuffering
#endif
  Handle -> FilePath -> IO ()
hPutStr Handle
hin FilePath
content
  Handle -> IO ()
hFlush Handle
hin
  Handle -> IO ()
hClose Handle
hin
  IO () -> (Int -> IO ()) -> Maybe Int -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> (Int -> IO ThreadId) -> Int -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> Handle -> Handle -> ProcessHandle -> Int -> IO ThreadId
startTimeout Handle
hin Handle
hout Handle
herr ProcessHandle
ph) (Maybe Int -> IO ()) -> Maybe Int -> IO ()
forall a b. (a -> b) -> a -> b
$ CallAlloyConfig -> Maybe Int
timeout CallAlloyConfig
config
  [ByteString]
out <- (ThreadId, MVar [ByteString]) -> IO [ByteString]
forall b. (ThreadId, MVar b) -> IO b
getOutput (ThreadId, MVar [ByteString])
pout
  [ByteString]
err <- (ThreadId, MVar [ByteString]) -> IO [ByteString]
forall b. (ThreadId, MVar b) -> IO b
getOutput (ThreadId, MVar [ByteString])
perr
  ProcessHandle -> IO ()
printContentOnError ProcessHandle
ph
  let err' :: [ByteString]
err' = [ByteString] -> [ByteString]
removeInfoLines [ByteString]
err
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
err') (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> FilePath
unpack (ByteString -> FilePath) -> ByteString -> FilePath
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BS.unlines [ByteString]
err'
  [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> IO [ByteString])
-> [ByteString] -> IO [ByteString]
forall a b. (a -> b) -> a -> b
$ ([ByteString] -> ByteString) -> [[ByteString]] -> [ByteString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"\n")
    ([[ByteString]] -> [ByteString]) -> [[ByteString]] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ([ByteString] -> Bool) -> [[ByteString]] -> [[ByteString]]
forall a. (a -> Bool) -> [a] -> [a]
filterLast ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
partialInstance) (ByteString -> Bool)
-> ([ByteString] -> ByteString) -> [ByteString] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
forall a. [a] -> a
last)
    ([[ByteString]] -> [[ByteString]])
-> [[ByteString]] -> [[ByteString]]
forall a b. (a -> b) -> a -> b
$ Int -> [[ByteString]] -> [[ByteString]]
forall a. Int -> [a] -> [a]
drop Int
1 ([[ByteString]] -> [[ByteString]])
-> [[ByteString]] -> [[ByteString]]
forall a b. (a -> b) -> a -> b
$ [ByteString] -> [ByteString] -> [[ByteString]]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn [ByteString
begin] [ByteString]
out
  where
    begin :: ByteString
    begin :: ByteString
begin = ByteString
"---INSTANCE---"
    filterLast :: (a -> Bool) -> [a] -> [a]
filterLast a -> Bool
_ []     = []
    filterLast a -> Bool
p x :: [a]
x@[a
_]  = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
p [a]
x
    filterLast a -> Bool
p (a
x:[a]
xs) = a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:(a -> Bool) -> [a] -> [a]
filterLast a -> Bool
p [a]
xs
    getWholeOutput :: Handle -> IO [ByteString]
getWholeOutput Handle
h = do
      Bool
eof <- Handle -> IO Bool
hIsEOF Handle
h
      if Bool
eof
        then [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return []
      else IO [ByteString]
-> (IOException -> IO [ByteString]) -> IO [ByteString]
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
        ((:) (ByteString -> [ByteString] -> [ByteString])
-> IO ByteString -> IO ([ByteString] -> [ByteString])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO ByteString
BS.hGetLine Handle
h IO ([ByteString] -> [ByteString])
-> IO [ByteString] -> IO [ByteString]
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Handle -> IO [ByteString]
getWholeOutput Handle
h)
        (\(IOException
_ :: IOException) -> [ByteString] -> IO [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return [ByteString
partialInstance])
    printContentOnError :: ProcessHandle -> IO ()
printContentOnError ProcessHandle
ph = do
      ExitCode
code <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
ph
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ExitCode
code ExitCode -> ExitCode -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> ExitCode
ExitFailure Int
1)
        (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed parsing the Alloy code:\n" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
content
    listenForOutput :: Handle -> IO (ThreadId, MVar [ByteString])
listenForOutput Handle
h = do
      MVar [ByteString]
mvar <- IO (MVar [ByteString])
forall a. IO (MVar a)
newEmptyMVar
      ThreadId
pid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> IO [ByteString]
getWholeOutput Handle
h IO [ByteString] -> ([ByteString] -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= MVar [ByteString] -> [ByteString] -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar [ByteString]
mvar
      (ThreadId, MVar [ByteString]) -> IO (ThreadId, MVar [ByteString])
forall (m :: * -> *) a. Monad m => a -> m a
return (ThreadId
pid, MVar [ByteString]
mvar)
    getOutput :: (ThreadId, MVar b) -> IO b
getOutput (ThreadId
pid, MVar b
mvar) = do
      b
output <- MVar b -> IO b
forall a. MVar a -> IO a
takeMVar MVar b
mvar
      ThreadId -> IO ()
killThread ThreadId
pid
      b -> IO b
forall (m :: * -> *) a. Monad m => a -> m a
return b
output

partialInstance :: ByteString
partialInstance :: ByteString
partialInstance = ByteString
"---PARTIAL_INSTANCE---"

{-|
Removes lines such as

@
[main] INFO kodkod.engine.config.Reporter - detecting symmetries ...
[main] INFO kodkod.engine.config.Reporter - detected 16 equivalence classes of atoms ...
[main] INFO kodkod.engine.config.Reporter - optimizing bounds and formula (breaking predicate symmetries, inlining, skolemizing) ...
[main] INFO kodkod.engine.config.Reporter - translating to boolean ...
[main] INFO kodkod.engine.config.Reporter - generating lex-leader symmetry breaking predicate ...
@

and

@
PARTIAL_INSTANCE
@

which seem to be appearing since Alloy-6.0.0
-}
removeInfoLines :: [ByteString] -> [ByteString]
removeInfoLines :: [ByteString] -> [ByteString]
removeInfoLines (ByteString
x:[ByteString]
xs)
  | Just ByteString
_ <- ByteString -> ByteString -> Maybe ByteString
BS.stripPrefix ByteString
"[main] INFO" ByteString
x
  = [ByteString] -> [ByteString]
removeInfoLines [ByteString]
xs
  | ByteString
x ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
partialInstance
  = [ByteString] -> [ByteString]
removeInfoLines [ByteString]
xs
removeInfoLines [ByteString]
xs = [ByteString]
xs

{-|
Start a new process that aborts execution by closing all handles and
killing the processes after the given amount of time.
-}
startTimeout
  :: Handle
  -- ^ the input handle to close
  -> Handle
  -- ^ the output handle to close
  -> Handle
  -- ^ the error handle to close
  -> ProcessHandle
  -- ^ the main process handle
  -> Int -> IO ThreadId
startTimeout :: Handle -> Handle -> Handle -> ProcessHandle -> Int -> IO ThreadId
startTimeout Handle
i Handle
o Handle
e ProcessHandle
ph Int
t = IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
  Int -> IO ()
threadDelay Int
t
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
e
  IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Handle -> IO ()
hClose Handle
o
  ProcessHandle -> IO ()
terminateProcess ProcessHandle
ph
  Handle -> IO ()
hClose Handle
i

{-|
Check if the class path was determined already, if so use it, otherwise call
'readClassPath'.

Returns the class path.
-}
getClassPath :: IO FilePath
getClassPath :: IO FilePath
getClassPath = do
  Maybe FilePath
mclassPath' <- IORef (Maybe FilePath) -> IO (Maybe FilePath)
forall a. IORef a -> IO a
readIORef IORef (Maybe FilePath)
mclassPath
  IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
readClassPath FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FilePath
mclassPath'

fallbackToTempDir :: IO FilePath -> IO FilePath
fallbackToTempDir :: IO FilePath -> IO FilePath
fallbackToTempDir IO FilePath
m = IO FilePath -> (IOException -> IO FilePath) -> IO FilePath
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch IO FilePath
m ((IOException -> IO FilePath) -> IO FilePath)
-> (IOException -> IO FilePath) -> IO FilePath
forall a b. (a -> b) -> a -> b
$ \IOException
e ->
  if IOException -> Bool
isDoesNotExistError IOException
e
  then do
    FilePath
tmp    <- IO FilePath
getTemporaryDirectory
#if defined(mingw32_HOST_OS)
    login  <- getUserName
#else
    FilePath
login  <- IO FilePath
getLoginName
#endif
    let tmpDir :: FilePath
tmpDir = FilePath
tmp FilePath -> FilePath -> FilePath
</> Int -> FilePath
forall a. Show a => a -> FilePath
show (FilePath -> Int
forall a. Hashable a => a -> Int
hash FilePath
login) FilePath -> FilePath -> FilePath
</> FilePath
appName
    FilePath -> IO ()
createUserDirectoriesIfMissing FilePath
tmpDir
    FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
tmpDir
  else FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e

{-|
Read the class path version specified in the user directory, if it is not
current or if it does not exist, call 'createVersionFile'.

Returns the class path.
-}
readClassPath :: IO FilePath
readClassPath :: IO FilePath
readClassPath = do
  FilePath
configDir <- IO FilePath -> IO FilePath
fallbackToTempDir (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgConfig FilePath
appName
  let versionFile :: FilePath
versionFile = FilePath
configDir FilePath -> FilePath -> FilePath
</> FilePath
"version"
  Bool
exists <- FilePath -> IO Bool
doesFileExist FilePath
versionFile
  if Bool
exists
    then do
    Int
version <- FilePath -> Int
forall a. Read a => FilePath -> a
read (FilePath -> Int) -> IO FilePath -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
readFile FilePath
versionFile
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
version Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
versionHash) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
createVersionFile FilePath
configDir FilePath
versionFile
    else FilePath -> FilePath -> IO ()
createVersionFile FilePath
configDir FilePath
versionFile
  FilePath
dataDir <- XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgData (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
appName FilePath -> FilePath -> FilePath
</> FilePath
"dataDir"
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
dataDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
searchPathSeparator Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
alloyJarName
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
searchPathSeparator Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
commonsCliJarName
    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
searchPathSeparator Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
slf4jJarName

{-|
Create all library files within the users 'XdgDirectory' by calling
'createDataDir' then place the current version number into a configuration File.
-}
createVersionFile :: FilePath -> FilePath -> IO ()
createVersionFile :: FilePath -> FilePath -> IO ()
createVersionFile FilePath
configDir FilePath
versionFile = do
  IO ()
createDataDir
  FilePath -> IO ()
createUserDirectoriesIfMissing FilePath
configDir
  FilePath -> FilePath -> IO ()
writeFile FilePath
versionFile (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
versionHash

{-|
Create all library files within the users 'XdgDirectory' based on the source
files enclosed into this library (see also 'Language.Alloy.RessourceNames' and
'Language.Alloy.Ressources').
-}
createDataDir :: IO ()
createDataDir :: IO ()
createDataDir = do
  FilePath
dataDir <- IO FilePath -> IO FilePath
fallbackToTempDir (IO FilePath -> IO FilePath) -> IO FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ XdgDirectory -> FilePath -> IO FilePath
getXdgDirectory XdgDirectory
XdgData (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
appName FilePath -> FilePath -> FilePath
</> FilePath
"dataDir"
  FilePath -> IO ()
createUserDirectoriesIfMissing (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
classPackage
  FilePath -> ByteString -> IO ()
BS.writeFile (FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
classPackage FilePath -> FilePath -> FilePath
</> FilePath
className FilePath -> FilePath -> FilePath
<.> FilePath
"class") ByteString
classFile
  FilePath -> ByteString -> IO ()
BS.writeFile (FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
alloyJarName) ByteString
alloyJar
  FilePath -> ByteString -> IO ()
BS.writeFile (FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
commonsCliJarName) ByteString
commonsCliJar
  FilePath -> ByteString -> IO ()
BS.writeFile (FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
slf4jJarName) ByteString
slf4jJar

{-|
Creates user directories using the file permissions 700.
This function creates the specified directory and all its parent directories as
well (if they are also missing).
-}
createUserDirectoriesIfMissing :: FilePath -> IO ()
createUserDirectoriesIfMissing :: FilePath -> IO ()
createUserDirectoriesIfMissing FilePath
fp = do
  Bool
isDir <- FilePath -> IO Bool
doesDirectoryExist FilePath
fp
  let parent :: FilePath
parent = FilePath -> FilePath
takeDirectory FilePath
fp
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
isDir Bool -> Bool -> Bool
|| FilePath
parent FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
fp) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath -> IO ()
createUserDirectoriesIfMissing FilePath
parent
    FilePath -> IO ()
createDirectory FilePath
fp
#ifndef mingw32_HOST_OS
    FilePath -> Mode -> IO ()
setFileMode FilePath
fp (Mode
7Mode -> Mode -> Mode
forall a. Num a => a -> a -> a
*Mode
8Mode -> Mode -> Mode
forall a. Num a => a -> a -> a
*Mode
8)
#endif

{-|
The application name (used to store data in a specific directory.
-}
appName :: String
appName :: FilePath
appName = FilePath
"call-alloy"

{-# INLINE versionHash #-}
{-|
Used to determine possible source code and Alloy version changes across multiple
versions of this library.
-}
versionHash :: Int
versionHash :: Int
versionHash = Int -> Int
forall a. Hashable a => a -> Int
hash (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
alloyHash Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
commonsCliHash Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
slf4jHash Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
classFileHash
  where
    alloyHash :: Int
alloyHash = ByteString -> Int
forall a. Hashable a => a -> Int
hash ByteString
alloyJar
    commonsCliHash :: Int
commonsCliHash = ByteString -> Int
forall a. Hashable a => a -> Int
hash ByteString
commonsCliJar
    classFileHash :: Int
classFileHash = ByteString -> Int
forall a. Hashable a => a -> Int
hash ByteString
classFile
    slf4jHash :: Int
slf4jHash = ByteString -> Int
forall a. Hashable a => a -> Int
hash ByteString
slf4jJar