diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,12 @@ # Revision history for minizinc-process +## Unreleased changes + +## 0.1.1.0 -- 2020-11-07 + +* Add streaming results API. +* Add helper to set extra arguments. + ## 0.1.0.0 -- YYYY-mm-dd * Initial version. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -71,6 +71,23 @@ (in our example, this type application is the only indication needed to tell the compiler to deserialize `Output` objects). +# Usage in a project + +In a typical project, you will have fixed models and varying inputs. +That is, you would like to carry the models along with the code (e.g., a web +application or gRPC server using minizinc in the background) in a same +repository as your Haskell code. One option is to leverage the support of cabal +[data-files](https://www.haskell.org/cabal/users-guide/developing-packages.html#accessing-data-files-from-package-code). + +You will still need some mapping functions to translate between domain objects +like `User` into the JSON values that MiniZinc requires: objects do not map +well with relations. We may consider compile-time helpers like TemplateHaskell, +but at this time it would not be immediately feasible. Be at peace with this. + +For now, the implementation leverages file-system to pass the JSON object to +MiniZinc, this design means you should pay attention to disk usage and maybe +clean the clutter. + # Misc. The author of this package is not affiliated with MiniZinc. diff --git a/minizinc-process.cabal b/minizinc-process.cabal --- a/minizinc-process.cabal +++ b/minizinc-process.cabal @@ -4,7 +4,7 @@ -- http://haskell.org/cabal/users-guide/ name: minizinc-process -version: 0.1.0.0 +version: 0.1.1.0 synopsis: A set of helpers to call minizinc models. description: MiniZinc is a language and a toolchain to solve discrete optimization problems. This package provides simple wrappers around the MiniZinc executable to pass inputs and read outputs. homepage: https://github.com/lucasdicioccio/minizinc-process#readme @@ -32,22 +32,13 @@ src build-depends: base >=4.13 && <4.14 , aeson + , attoparsec , bytestring , containers , directory , hashable + , process , process-extras , stringsearch , text default-language: Haskell2010 - ---executable minizinc-process-exe --- main-is: Main.hs --- -- other-modules: --- -- other-extensions: --- build-depends: base >=4.13 && <4.14 --- , minizinc-process-lib --- , aeson --- , hashable --- , text --- -- hs-source-dirs: diff --git a/src/Process/Minizinc.hs b/src/Process/Minizinc.hs --- a/src/Process/Minizinc.hs +++ b/src/Process/Minizinc.hs @@ -1,5 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor #-} -- | A set of types and functions to help calling Minizinc as an external binary. -- @@ -9,15 +11,23 @@ module Process.Minizinc ( MiniZinc (..), simpleMiniZinc, + withArgs, Solver (..), SolverName, MilliSeconds, runLastMinizincJSON, + SearchState(..), + ResultHandler(..), + runMinizincJSON, ) where -import Control.Monad ((>=>)) -import Data.Aeson (FromJSON, ToJSON, decode, encode) +import Control.Monad ((>=>), void) +import Control.Applicative ((<|>)) +import Data.Attoparsec.ByteString (Parser, parse, IResult(..)) +import Data.Attoparsec.Combinator (try) +import Data.Aeson (FromJSON, fromJSON, ToJSON, decode, encode, Value, Result(..)) +import Data.Aeson.Parser.Internal (json') import Data.ByteString (ByteString) import qualified Data.ByteString as ByteString import qualified Data.ByteString.Lazy as LByteString @@ -26,6 +36,8 @@ import Data.Hashable (Hashable, hash) import qualified Data.List as List import System.Process.ByteString (readProcessWithExitCode) +import System.Process (createProcess, proc, StdStream(CreatePipe), std_out) +import GHC.IO.Handle (Handle, hClose, hIsEOF) -- | Type alias asking for milliseconds. type MilliSeconds a = Int @@ -66,6 +78,10 @@ (const solver) (const []) +-- | Helper to set arguments. +withArgs :: [String] -> MiniZinc input answer -> MiniZinc input answer +withArgs args mzn = mzn { mkExtraArgs = const args } + -- | Runs MiniZinc on the input and parses output for the last answer. -- -- The parser for now is primitive and all the parsing occurs after processing @@ -99,6 +115,90 @@ fullPath ] +data SearchState a + = Exhausted a + | Incomplete a + | Unsatisfiable + | InternalError String + deriving (Show, Eq, Ord, Functor) + +reduce :: FromJSON a => SearchState Value -> SearchState a +reduce Unsatisfiable = Unsatisfiable +reduce (InternalError s) = InternalError s +reduce (Exhausted val) = case fromJSON val of + Success obj -> Exhausted obj + Error err -> InternalError err +reduce (Incomplete val) = case fromJSON val of + Success obj -> Incomplete obj + Error err -> InternalError err + +data ResultHandler obj b + = ResultHandler + { handleNext :: b -> SearchState Value -> IO (b, Maybe (ResultHandler obj b)) + } + +runMinizincJSON :: + forall input answer b. + (ToJSON input, FromJSON answer) => + MiniZinc input answer -> + input -> + b -> + ResultHandler answer b -> + IO b +runMinizincJSON minizinc obj v0 resultHandler = do + LByteString.writeFile fullPath $ encode obj + (_, Just out, _, _) <- createProcess (proc "minizinc" args){ std_out = CreatePipe } + vRet <- go out (parse oneResult) "" v0 resultHandler + hClose out + pure vRet + where + go :: Handle + -> (ByteString -> IResult ByteString (SearchState Value)) + -> ByteString + -> b + -> ResultHandler answer b + -> IO b + go out parsebuf buf v1 handler + | ByteString.null buf = do + eof <- hIsEOF out + if eof + then + inputFinished v1 + else do + dat <- ByteString.hGetLine out + go out parsebuf dat v1 handler + | otherwise = do + case parsebuf buf of + Done remainderBuf stateVal -> do + (v2, nextHandler) <- (handleNext handler) v1 (reduce stateVal) + case nextHandler of + Nothing -> userFinished v2 + Just resultHandler -> go out (parse oneResult) remainderBuf v2 resultHandler + Fail _ _ err -> do + (v2,_) <- (handleNext handler) v1 (InternalError err) + finalizeFailure v2 + Partial f -> go out f "" v1 handler + + inputFinished = pure + userFinished = pure + finalizeFailure = pure + + fullPath :: FilePath + fullPath = mkTmpDataPath minizinc obj + args :: [String] + args = + [ "--time-limit", + show (mkTimeLimit minizinc obj), + "--solver", + showSolver (mkSolver minizinc obj), + "--output-mode", + "json" + ] + ++ (mkExtraArgs minizinc obj) + ++ [ model minizinc, + fullPath + ] + showSolver :: Solver -> String showSolver = \case Chuffed -> "Chuffed" @@ -121,3 +221,24 @@ safehead xs = Just $ head xs resultSeparator = "\n----------\n" openCurlybrace = "{" + + +-- | NOTE: the parser is fed with hGetLine (stripping EOL markers) +-- this assumption simplifies the grammar below +oneResult :: Parser (SearchState Value) +oneResult = + try unsat + <|> sat + where + unsat = unsatMark *> pure Unsatisfiable + + sat = reverseAp <$> json' <*> searchstate + reverseAp val constructor = constructor val + + searchstate = + try (resultMark *> exhaustiveMark *> pure Exhausted) + <|> try (resultMark *> pure Incomplete) + + resultMark = "----------" + exhaustiveMark = "==========" + unsatMark = "=====UNSATISFIABLE====="