diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +The MIT License (MIT) +Copyright © 2017 Paul Ogris + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the “Software”), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/clingo.cabal b/clingo.cabal new file mode 100644 --- /dev/null +++ b/clingo.cabal @@ -0,0 +1,197 @@ +name: clingo +version: 0.2.0.0 +synopsis: Haskell bindings to the Clingo ASP solver +description: Please see README.md +homepage: https://github.com/tsahyt/clingo-haskell#readme +license: MIT +license-file: LICENSE +author: Paul Ogris +maintainer: paul@tsahyt.com +copyright: 2017 Paul Ogris +category: ASP, Symbolic Computation, Logic Programming, FFI +build-type: Simple +cabal-version: >=1.10 + +flag examples + description: Build examples + default: False + +library + hs-source-dirs: src + exposed-modules: Clingo + Clingo.AST + Clingo.Configuration + Clingo.Control + Clingo.Inspection.Symbolic + Clingo.Inspection.Theory + Clingo.Inspection.Ground + Clingo.Model + Clingo.ProgramBuilding + Clingo.Propagation + Clingo.Solving + Clingo.Statistics + Clingo.Symbol + Clingo.Internal.AST + Clingo.Internal.Configuration + Clingo.Internal.Inspection.Symbolic + Clingo.Internal.Inspection.Theory + Clingo.Internal.Propagation + Clingo.Internal.Statistics + Clingo.Internal.Symbol + Clingo.Internal.Types + Clingo.Internal.Utils + Clingo.Raw + Clingo.Raw.AST + Clingo.Raw.Basic + Clingo.Raw.Configuration + Clingo.Raw.Control + Clingo.Raw.Enums + Clingo.Raw.Inspection.Symbolic + Clingo.Raw.Inspection.Theory + Clingo.Raw.Model + Clingo.Raw.ProgramBuilding + Clingo.Raw.Propagation + Clingo.Raw.Solving + Clingo.Raw.Statistics + Clingo.Raw.Symbol + Clingo.Raw.Types + build-depends: base >= 4.7 && < 5, + bifunctors >= 5.4 && < 6, + transformers == 0.5.*, + mtl == 2.2.*, + exceptions == 0.8.*, + text == 1.2.*, + wl-pprint-text, + deepseq == 1.4.*, + StateVar == 1.1.*, + hashable == 1.2.* + extra-libraries: clingo + ghc-options: -Wall + default-language: Haskell2010 + +executable version + if flag(examples) + build-depends: base, clingo + else + buildable: False + + hs-source-dirs: examples + main-is: Version.hs + default-language: Haskell2010 + +executable dot-propagator + if flag(examples) + build-depends: base, clingo, text + else + buildable: False + + hs-source-dirs: examples + main-is: DotPropagator.hs + default-language: Haskell2010 + +executable control + if flag(examples) + build-depends: base, clingo, text + else + buildable: False + + hs-source-dirs: examples + main-is: Control.hs + default-language: Haskell2010 + +executable configuration + if flag(examples) + build-depends: base, clingo, text, StateVar + else + buildable: False + + hs-source-dirs: examples + ghc-options: -Wall + main-is: Configuration.hs + default-language: Haskell2010 + +executable theory-atoms + if flag(examples) + build-depends: base, clingo, text + else + buildable: False + + hs-source-dirs: examples + main-is: TheoryAtoms.hs + default-language: Haskell2010 + +executable symbolic-atoms + if flag(examples) + build-depends: base, clingo, text + else + buildable: False + + hs-source-dirs: examples + main-is: SymbolicAtoms.hs + default-language: Haskell2010 + +executable ast + if flag(examples) + build-depends: base, clingo, text + else + buildable: False + + hs-source-dirs: examples + main-is: AST.hs + default-language: Haskell2010 + +executable backend + if flag(examples) + build-depends: base, clingo, text + else + buildable: False + + hs-source-dirs: examples + main-is: Backend.hs + default-language: Haskell2010 + +executable model + if flag(examples) + build-depends: base, clingo, text + else + buildable: False + + hs-source-dirs: examples + main-is: Model.hs + default-language: Haskell2010 + +executable solve-async + if flag(examples) + build-depends: base, clingo, text, monad-loops, MonadRandom + else + buildable: False + + hs-source-dirs: examples + main-is: SolveAsync.hs + ghc-options: -threaded + default-language: Haskell2010 + +executable statistics + if flag(examples) + build-depends: base, clingo, text, wl-pprint-text, StateVar + else + buildable: False + + hs-source-dirs: examples + main-is: Statistics.hs + default-language: Haskell2010 + +executable propagator + if flag(examples) + build-depends: base, clingo, text, containers, transformers + else + buildable: False + + hs-source-dirs: examples + main-is: Propagator.hs + default-language: Haskell2010 + + +source-repository head + type: git + location: https://github.com/tsahyt/clingo-haskell diff --git a/examples/AST.hs b/examples/AST.hs new file mode 100644 --- /dev/null +++ b/examples/AST.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class + +import Clingo.AST +import Clingo.Control +import Clingo.Model +import Clingo.ProgramBuilding +import Clingo.Symbol +import Clingo.Solving + +printModel :: (MonadIO (m s), MonadModel m) => Model s -> m s () +printModel m = do + syms <- map prettySymbol + <$> modelSymbols m (selectNone { selectShown = True }) + liftIO (putStr "Model: " >> print syms) + +rewrite :: Term a -> Statement a b -> Statement a b +rewrite a@(TermSymbol loc sym) (StmtRule l (Rule h b)) = + let lit = BodyLiteral loc NoSign (LiteralTerm loc NoSign a) + in StmtRule l (Rule h (lit : b)) +rewrite _ x = x + +main :: IO () +main = withDefaultClingo $ do + builder <- programBuilder + + -- create enable atom + sym <- createId "enable" True + let loc = Location "" "" 0 0 0 0 + atom = TermSymbol loc sym + + -- add rewritten statements into the builder + addStatements builder . map (rewrite atom) + =<< parseProgram "a :- not b. b :- not a." Nothing 20 + + -- add #external enable. + addStatements builder [ StmtExternal loc (External atom []) ] + + ground [Part "base" []] Nothing + + liftIO $ putStrLn "Solving with enable = false..." + withSolver [] (allModels >=> mapM_ printModel) + + liftIO $ putStrLn "Solving with enable = true..." + assignExternal sym TruthTrue + withSolver [] (allModels >=> mapM_ printModel) + + liftIO $ putStrLn "Solving with enable = false..." + assignExternal sym TruthFalse + withSolver [] (allModels >=> mapM_ printModel) diff --git a/examples/Backend.hs b/examples/Backend.hs new file mode 100644 --- /dev/null +++ b/examples/Backend.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Clingo.Control +import Clingo.Symbol +import Clingo.Solving +import Clingo.Model +import Clingo.ProgramBuilding +import Clingo.Inspection.Symbolic + +import Text.Printf +import qualified Data.Text.IO as T + +printModel :: (MonadIO (m s), MonadModel m) => Model s -> m s () +printModel m = do + syms <- map prettySymbol + <$> modelSymbols m (selectNone { selectShown = True }) + liftIO (putStr "Model: " >> print syms) + +main :: IO () +main = withDefaultClingo $ do + addProgram "base" [] "{a; b; c}." + ground [Part "base" []] Nothing + + atoms <- flip fromSymbolicAtoms (map literal) =<< symbolicAtoms + backend >>= \b -> do + atomD <- atom b + addGroundStatements b + [ rule False [atomD] (take 2 atoms) + , rule False [] + [ negateAspifLiteral (atomAspifLiteral atomD) + , atoms !! 2] + ] + + withSolver [] (allModels >=> mapM_ printModel) diff --git a/examples/Configuration.hs b/examples/Configuration.hs new file mode 100644 --- /dev/null +++ b/examples/Configuration.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Clingo.Control +import Clingo.Configuration +import Clingo.Symbol +import Clingo.Solving +import Clingo.Model + +printModel :: (MonadIO (m s), MonadModel m) => Model s -> m s () +printModel m = do + syms <- map prettySymbol + <$> modelSymbols m (selectNone { selectShown = True }) + liftIO (putStr "Model: " >> print syms) + +(>>?=) :: (Monad m, Foldable t) => m (t a) -> (a -> m b) -> m () +a >>?= b = a >>= mapM_ b + +main :: IO () +main = withDefaultClingo $ do + conf <- configuration + + -- enumerate all models + fromConfig conf (atMap "solve" >=> atMap "models" >=> value) >>?= ($= "0") + + -- use berkmin + fromConfig conf (atMap "solver" >=> atArray 0 >=> atMap "heuristic" + >=> value) + >>?= ($= "berkmin") + + addProgram "base" [] "a :- not b. b :- not a." + ground [Part "base" []] Nothing + withSolver [] (allModels >=> mapM_ printModel) diff --git a/examples/Control.hs b/examples/Control.hs new file mode 100644 --- /dev/null +++ b/examples/Control.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Clingo.Control +import Clingo.Symbol +import Clingo.Model +import Clingo.Solving + +import Text.Printf +import qualified Data.Text.IO as T + +printModel :: (MonadIO (m s), MonadModel m) => Model s -> m s () +printModel m = do + syms <- map prettySymbol + <$> modelSymbols m (selectNone { selectShown = True }) + liftIO (putStr "Model: " >> print syms) + +main :: IO () +main = withDefaultClingo $ do + addProgram "base" [] "a :- not b. b :- not a." + ground [Part "base" []] Nothing + withSolver [] (allModels >=> mapM_ printModel) diff --git a/examples/DotPropagator.hs b/examples/DotPropagator.hs new file mode 100644 --- /dev/null +++ b/examples/DotPropagator.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +module Main where + +import Control.Monad.IO.Class +import Control.Monad +import Control.Concurrent +import Clingo.Control +import Clingo.Solving +import Clingo.Propagation +import Clingo.Inspection.Symbolic + +import System.Environment (getArgs) +import System.IO (hFlush, stdout) + +sleepTime :: Int +sleepTime = 10000 + +mapIO :: (MonadIO m, Foldable t) => IO b -> t a -> m () +mapIO = mapM_ . const . liftIO + +writeDots :: [Literal s] -> Propagation 'Solving s () +writeDots = mapIO (putChar '.' >> hFlush stdout >> threadDelay sleepTime) + +takeDots :: [Literal s] -> Propagation 'Solving s () +takeDots = mapIO (putStr "\b \b" >> hFlush stdout >> threadDelay sleepTime) + +watchAll :: Propagation 'Init s () +watchAll = mapM_ ((addWatch =<<) . solverLiteral . literal) + =<< flip fromSymbolicAtoms id =<< propSymbolicAtoms + +main :: IO () +main = withDefaultClingo $ do + path <- head <$> liftIO getArgs + registerPropagator False $ emptyPropagator + { propInit = Just watchAll + , propPropagate = Just writeDots + , propUndo = Just takeDots + } + loadProgram path + ground [Part "base" []] Nothing + withSolver [] (void . allModels) + liftIO (putChar '\n') diff --git a/examples/Model.hs b/examples/Model.hs new file mode 100644 --- /dev/null +++ b/examples/Model.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Clingo.Control +import Clingo.Symbol +import Clingo.Model +import Clingo.Solving +import Data.List (intersperse) +import Data.Text (Text) +import System.Environment (getArgs) + +import Text.Printf +import qualified Data.Text.IO as T + +printModel :: Model s -> Text -> SymbolSelection -> IOSym s () +printModel m label s = do + syms <- map prettySymbol <$> modelSymbols m s + liftIO $ do + T.putStr (label `mappend` ": ") + T.putStrLn . mconcat $ intersperse " " syms + +printSolution :: Model s -> IOSym s () +printSolution m = do + t <- modelType m + n <- modelNumber m + let tstring = case t of + StableModel -> "Stable model" + BraveConsequences -> "Brave consequences" + CautiousConsequences -> "Cautious consequences" + + liftIO (printf "%s %d:\n" (tstring :: String) n) + mapM_ (uncurry (printModel m)) + [ (" shown", selectNone { selectShown = True }) + , (" atoms", selectNone { selectAtoms = True }) + , (" terms", selectNone { selectTerms = True }) + , (" ~atoms", selectNone { selectAtoms = True + , useComplement = True }) + ] + +main :: IO () +main = getArgs >>= \args -> + withClingo (defaultClingo { clingoArgs = args }) $ do + addProgram "base" [] "1 {a; b} 1. #show c : b. #show a/0." + ground [Part "base" []] Nothing + withSolver [] (allModels >=> mapM_ printSolution) diff --git a/examples/Propagator.hs b/examples/Propagator.hs new file mode 100644 --- /dev/null +++ b/examples/Propagator.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE PatternGuards #-} +module Main where + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.IO.Class +import Clingo.Control +import Clingo.Symbol +import Clingo.Solving +import Clingo.Model +import Clingo.Propagation +import Clingo.Inspection.Symbolic + +import Data.Map (Map) +import Data.Maybe +import Data.IntMap (IntMap) +import qualified Data.Map as M +import qualified Data.IntMap as I + +import Text.Printf +import qualified Data.Text.IO as T + +newtype Hole = Hole Int + deriving (Eq, Show, Ord) + +data PigeonData s = PigeonData + { placements :: Map (Literal s) Hole + , assignments :: IntMap (Map Hole (Literal s)) + } + deriving (Show) + +assignHole :: Integer -> Hole -> Literal s -> PigeonData s -> PigeonData s +assignHole tid hole lit pd = pd + { assignments = + I.adjust (M.insert hole lit) (fromIntegral tid) (assignments pd) } + +unassignHole :: Integer -> Literal s -> Hole -> PigeonData s -> PigeonData s +unassignHole tid lit hole pd = pd + { assignments = I.adjust go (fromIntegral tid) (assignments pd) } + where go m | Just l <- M.lookup hole m + , l == lit = M.delete hole m + | otherwise = m + +forceMVar :: MonadIO m => MVar a -> a -> m () +forceMVar mvar x = liftIO $ do + _ <- tryTakeMVar mvar + putMVar mvar x + +onModel :: Model s -> IOSym s Continue +onModel m = do + syms <- map prettySymbol + <$> modelSymbols m (selectNone { selectShown = True }) + liftIO (putStr "Model: " >> print syms) + return Continue + +main :: IO () +main = withDefaultClingo $ do + addProgram "pigeon" ["h","p"] + "1 { place(P,H) : H = 1..h } 1 :- P = 1..p." + + holes <- createNumber 8 + pigeons <- createNumber 9 + ground [Part "pigeon" [holes, pigeons]] Nothing + + propState <- liftIO newEmptyMVar + registerPropagator False (pigeonator propState) + + solveRet <- withSolver [] getResult + liftIO (print solveRet) + +-- TODO: Propagator with symbol inspection methods? +pigeonator :: MVar (PigeonData s) -> Propagator s +pigeonator mvar = emptyPropagator + { propInit = Just $ do + -- obtain place/2 atoms + placeSig <- createSignature "place" 2 True + watches <- propSymbolicAtoms + >>= \sa -> fromSymbolicAtomsSig sa placeSig id + + -- watch and create initial placements + mapM_ ((addWatch =<<) . solverLiteral . literal) watches + ps <- forM watches $ \atom -> do + let hole = do + arg <- symbolGetArg (symbol atom) 1 + Hole . fromIntegral <$> symbolNumber arg + lit <- solverLiteral . literal $ atom + return $ (,) <$> pure lit <*> hole + + -- initialize the PigeonData structure for all threads + threads <- fromIntegral <$> countThreads + forceMVar mvar $ + let xs = zip (take threads [0..]) (repeat M.empty) + in PigeonData (M.fromList . catMaybes $ ps) (I.fromList xs) + + , propPropagate = Just $ \changes -> do + -- get previous assignment + thread <- getThreadId + + -- apply and check assignments done by solver + forM_ changes $ \lit -> do + state <- liftIO (readMVar mvar) + let Just holes = fromIntegral thread `I.lookup` assignments state + Just hole = lit `M.lookup` placements state + prev = hole `M.lookup` holes + case prev of + Nothing -> liftIO $ + modifyMVar_ mvar (return . assignHole thread hole lit) + Just p -> do + let c = Clause (map negateLiteral [lit, p]) ClauseLearnt + addClause c + propagate + + , propUndo = Just $ \changes -> do + thread <- getThreadId + state <- liftIO (readMVar mvar) + + let cs' = mapMaybe + (\l -> (,) <$> pure l <*> M.lookup l (placements state)) + changes + liftIO $ + modifyMVar_ mvar $ + return . flip (foldr (uncurry (unassignHole thread))) cs' + } diff --git a/examples/SolveAsync.hs b/examples/SolveAsync.hs new file mode 100644 --- /dev/null +++ b/examples/SolveAsync.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Main where + +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Random +import Control.Monad.Loops +import Control.Monad.IO.Class +import Clingo.Control +import Clingo.Symbol +import Clingo.Solving +import Clingo.Model +import Data.IORef + +import Text.Printf +import qualified Data.Text.IO as T + +-- | Approximate Pi with a rather literal translation of the C example. +approxPi :: MonadIO m => MVar Bool -> m Double +approxPi running = liftIO $ do + let rmax = 512 + samples <- newIORef 0 + incircle <- newIORef 0 + whileM (readMVar running) $ do + modifyIORef' samples succ + (x :: Int) <- getRandomR (-rmax, rmax) + (y :: Int) <- getRandomR (-rmax, rmax) + when (x * x + y * y <= rmax * rmax) $ + modifyIORef' incircle succ + s <- readIORef samples + c <- readIORef incircle + return $ 4 * fromIntegral c / fromIntegral s + +main :: IO () +main = withDefaultClingo $ do + addProgram "base" [] $ + "#const n = 17.\ + \ 1 { p(X); q(X) } 1 :- X = 1..n.\ + \ :- not n+1 { p(1..n); q(1..n) }." + ground [Part "base" []] Nothing + + running <- liftIO (newMVar True) + solver <- solve SolveModeAsync [] $ Just $ \_ -> do + void (liftIO (swapMVar running False)) + return Continue + + pi <- approxPi running + liftIO (putStrLn $ "pi = " ++ show pi) + liftIO . print =<< getResult solver + + solverClose solver diff --git a/examples/Statistics.hs b/examples/Statistics.hs new file mode 100644 --- /dev/null +++ b/examples/Statistics.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad.IO.Class +import Clingo.Symbol +import Clingo.Solving +import Clingo.Control +import Clingo.Configuration +import Clingo.Model +import Clingo.Statistics + +import Data.StateVar + +import Data.Text.Lazy (fromStrict) +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +instance Pretty v => Pretty (StatsTree v) where + pretty (SValue v) = pretty v + pretty (SArray x) = vcat $ map (nest 1 . pretty . snd) x + pretty (SMap s) = vcat $ map (nest 1 . go) s + where go (k,t) = text (fromStrict k) <> colon <> line + <> nest 1 (pretty t) + +printModel :: (MonadIO (m s), MonadModel m) => Model s -> m s () +printModel m = do + syms <- map prettySymbol + <$> modelSymbols m (selectNone { selectShown = True }) + liftIO (putStr "Model: " >> print syms) + +main :: IO () +main = withDefaultClingo $ do + -- Set configuration to put out more stats + Just sconfig <- flip fromConfig (atMap "stats" >=> value) =<< configuration + sconfig $= "1" + + -- Ground and solve a simple program + addProgram "base" [] "a :- not b. b :- not a." + ground [Part "base" []] Nothing + _ <- withSolver [] (allModels >=> mapM_ printModel) + stats <- statistics + + -- Print whole stats tree + liftIO (putStrLn "\nStatistics") + fullTree <- subStats stats pure + liftIO (putDoc (pretty fullTree <> line)) + + -- Print just the solving subtree + liftIO (putStrLn "\nSelected solving.solver statistics") + solving <- subStats stats (atMap "solving" >=> atMap "solvers") + liftIO (putDoc (pretty solving <> line)) + + -- Selecting only number of equations + liftIO (putStrLn "\nNumber of equations") + eqs <- fromStats stats (atMap "problem" >=> atMap "lp" >=> atMap "eqs" + >=> value) + liftIO (putDoc (pretty eqs <> line)) diff --git a/examples/SymbolicAtoms.hs b/examples/SymbolicAtoms.hs new file mode 100644 --- /dev/null +++ b/examples/SymbolicAtoms.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Arrow +import Control.Monad +import Control.Monad.IO.Class +import Clingo.Control +import Clingo.Symbol +import Clingo.Model +import Clingo.Inspection.Symbolic + +import Data.Maybe +import Data.Text (Text) + +import qualified Data.Text.IO as T + +printSymbol :: SymbolicAtom s -> Text +printSymbol atom = + let isFact = guard (fact atom) *> pure ", fact" + isExternal = guard (external atom) *> pure ", external" + name = prettySymbol (symbol atom) + in mconcat . catMaybes $ [ Just " ", Just name, isFact, isExternal ] + +main :: IO () +main = withDefaultClingo $ do + addProgram "base" [] "a. {b}. #external c." + ground [Part "base" []] Nothing + + liftIO (T.putStrLn "Symbolic Atoms:") + sa <- symbolicAtoms + mapM_ (liftIO . T.putStrLn . printSymbol) =<< fromSymbolicAtoms sa id diff --git a/examples/TheoryAtoms.hs b/examples/TheoryAtoms.hs new file mode 100644 --- /dev/null +++ b/examples/TheoryAtoms.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Maybe +import Clingo.Control +import Clingo.Symbol +import Clingo.Solving +import Clingo.Model +import Clingo.ProgramBuilding + +import Text.Printf +import qualified Data.Text as T + +import Clingo.Inspection.Theory + +printModel :: (MonadIO (m s), MonadModel m) => Model s -> m s () +printModel m = do + syms <- map prettySymbol + <$> modelSymbols m (selectNone { selectShown = True }) + liftIO (putStr "Model: " >> print syms) + +theory :: TheoryAtoms s -> Clingo s (AspifLiteral s) +theory t = do + -- obtain number of theory atoms via length + size <- fromTheoryAtoms t length + liftIO (putStrLn $ "number of grounded theory atoms: " ++ show size) + + -- find the atom b/1 and determine whether it has a guard + atomB <- fromTheoryAtoms t (head . filter (nameIs "b")) + liftIO (putStrLn $ "theory atom b/1 has guard: " ++ + show (isJust . atomGuard $ atomB)) + + return (atomLiteral atomB) + + where nameIs a x = case termName (atomTerm x) of + Nothing -> False + Just b -> a == b + +main :: IO () +main = withDefaultClingo $ do + addProgram "base" [] $ mconcat + [ "#theory t {" + , " term { + : 1, binary, left };" + , " &a/0 : term, any;" + , " &b/1 : term, {=}, term, any" + , "}." + , "x :- &a { 1+2 }." + , "y :- &b(3) { } = 17." ] + ground [Part "base" []] Nothing + lit <- theory =<< theoryAtoms + flip addGroundStatements [ assume [lit] ] =<< backend + withSolver [] (allModels >=> mapM_ printModel) diff --git a/examples/Version.hs b/examples/Version.hs new file mode 100644 --- /dev/null +++ b/examples/Version.hs @@ -0,0 +1,8 @@ +module Main where + +import Text.Printf +import Clingo.Control + +main = do + (a,b,c) <- version + printf "Hello, this is clingo version %d.%d.%d.\n" a b c diff --git a/src/Clingo.hs b/src/Clingo.hs new file mode 100644 --- /dev/null +++ b/src/Clingo.hs @@ -0,0 +1,13 @@ +module Clingo +( + module X +) +where + +import Clingo.Control as X +import Clingo.Model as X +import Clingo.Solving as X +import Clingo.Symbol as X +import Clingo.Propagation as X +import Clingo.Statistics as X +import Clingo.Configuration as X diff --git a/src/Clingo/AST.hs b/src/Clingo/AST.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/AST.hs @@ -0,0 +1,121 @@ +module Clingo.AST +( + parseProgram, + fromPureAST, + toPureAST, + + T.Location (..), + Sign (..), + T.Signature, + T.Symbol, + UnaryOperation (..), + UnaryOperator (..), + BinaryOperation (..), + BinaryOperator (..), + Interval (..), + Function (..), + Pool (..), + Term (..), + CspProductTerm (..), + CspSumTerm (..), + CspGuard (..), + ComparisonOperator (..), + CspLiteral (..), + Identifier (..), + Comparison (..), + Literal (..), + AggregateGuard (..), + ConditionalLiteral (..), + Aggregate (..), + BodyAggregateElement (..), + BodyAggregate (..), + AggregateFunction (..), + HeadAggregateElement (..), + HeadAggregate (..), + Disjunction (..), + DisjointElement (..), + Disjoint (..), + TheoryTermArray (..), + TheoryFunction (..), + TheoryUnparsedTermElement (..), + TheoryUnparsedTerm (..), + TheoryTerm (..), + TheoryAtomElement (..), + TheoryGuard (..), + TheoryAtom (..), + HeadLiteral (..), + BodyLiteral (..), + TheoryOperatorDefinition (..), + TheoryOperatorType (..), + TheoryTermDefinition (..), + TheoryGuardDefinition (..), + TheoryAtomDefinition (..), + TheoryAtomDefinitionType (..), + TheoryDefinition (..), + Rule (..), + Definition (..), + ShowSignature (..), + ShowTerm (..), + Minimize (..), + Script (..), + ScriptType (..), + Program (..), + External (..), + Edge (..), + Heuristic (..), + Project (..), + Statement (..) +) +where + +import Control.Monad.IO.Class + +import Data.Bifunctor +import Data.Bitraversable +import Data.Text (Text, unpack) +import Data.IORef +import Numeric.Natural + +import Foreign hiding (Pool) +import Foreign.C + +import Clingo.Symbol +import Clingo.Internal.AST +import Clingo.Internal.Utils +import qualified Clingo.Internal.Types as T +import qualified Clingo.Raw as Raw + +-- | Parse a logic program into a list of statements. +parseProgram :: Text -- ^ Program + -> Maybe (ClingoWarning -> Text -> IO ()) -- ^ Logger Callback + -> Natural -- ^ Logger Call Limit + -> T.Clingo s [Statement (T.Symbol s) (T.Signature s)] +parseProgram prog logger limit = do + ref <- liftIO (newIORef []) + marshall0 $ + withCString (unpack prog) $ \p -> do + logCB <- maybe (pure nullFunPtr) T.wrapCBLogger logger + astCB <- wrapCBAst (\s -> modifyIORef ref (s :)) + Raw.parseProgram p astCB nullPtr + logCB nullPtr (fromIntegral limit) + liftIO (reverse <$> readIORef ref) + +-- | An AST can be constructed in a pure environment using 'PureSymbol' and +-- 'PureSignature' and then registered with the solver when required. Creation +-- calls for the same symbol in multiple places will be repeated, i.e. no symbol +-- table is being created internally by this function! +fromPureAST :: (Monad (m s), MonadSymbol m) + => [Statement PureSymbol PureSignature] + -> m s [Statement (T.Symbol s) (T.Signature s)] +fromPureAST = traverse (bitraverse unpureSymbol unpureSignature) + +toPureAST :: [Statement (T.Symbol s) (T.Signature s)] + -> [Statement PureSymbol PureSignature] +toPureAST = fmap (bimap toPureSymbol toPureSignature) + +wrapCBAst :: MonadIO m + => (Statement (T.Symbol s) (T.Signature s) -> IO ()) + -> m (FunPtr (Ptr Raw.AstStatement -> Ptr () -> IO Raw.CBool)) +wrapCBAst f = liftIO $ Raw.mkCallbackAst go + where go :: Ptr Raw.AstStatement -> Ptr () -> IO Raw.CBool + go stmt _ = reraiseIO $ f =<< fromRawStatement =<< peek stmt diff --git a/src/Clingo/Configuration.hs b/src/Clingo/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Configuration.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Configuration +( + -- * Tree interface + ConfTree (..), + AMVTree (..), + (>=>), + fromConfig, + fromConfigMany, + + -- * Re-exported from StateVar + StateVar, + ($=), + get +) +where + +import Control.DeepSeq +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch +import Data.Bifunctor +import Data.Text (Text) +import Data.StateVar + +import GHC.Generics + +import Clingo.Internal.Types +import Clingo.Internal.Configuration + +import System.IO.Unsafe + +-- | The configuration tree type, polymorphic over the leaf values. +data ConfTree v + = CValue v + | CMap (Maybe v) [(Text, ConfTree v)] + | CArray (Maybe v) [(Int, ConfTree v)] + | CBoth (Maybe v) [((Text, Int), ConfTree v)] + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + +instance NFData v => NFData (ConfTree v) + +getTree :: (MonadIO m, MonadThrow m) + => Configuration s -> m (ConfTree (StateVar Text)) +getTree s = configurationRoot s >>= liftIO . go + where go k = unsafeInterleaveIO $ do + t <- configurationType s k + case t of + -- Both constructors + CType val True True -> do + len <- configurationArraySize s k + (nms, cs, os) <- goMap len k + return . CBoth (getVal val k) $ + zip (zip nms (map fromIntegral os)) cs + + -- Array constructor + CType val True False -> do + len <- configurationArraySize s k + let offsets = take (fromIntegral len) [0..] + cs <- mapM (go <=< configurationArrayAt s k) offsets + return . CArray (getVal val k) $ + zip (map fromIntegral offsets) cs + + -- Map constructor + CType val False True -> do + len <- configurationMapSize s k + (nms, cs, _) <- goMap len k + return $ CMap (getVal val k) (zip nms cs) + + -- Only value + CType True _ _ -> return $ CValue (keyStateVar s k) + + _ -> error "Unknown configuration type" + + getVal val k = if val then Just (keyStateVar s k) else Nothing + + goMap len k = do + let offsets = take (fromIntegral len) [0..] + nms <- mapM (configurationMapSubkeyName s k) offsets + cs <- mapM (go <=< configurationMapAt s k) nms + return (nms, cs, offsets) + +keyStateVar :: Configuration s -> CKey -> StateVar Text +keyStateVar c k = makeStateVar getV setV + where getV = configurationValueGet c k + setV = configurationValueSet c k + +instance AMVTree ConfTree where + atArray i (CArray _ a) = lookup i a + atArray i (CBoth _ xs) = lookup i . map (first snd) $ xs + atArray _ _ = Nothing + + atMap i (CMap _ m) = lookup i m + atMap i (CBoth _ xs) = lookup i . map (first fst) $ xs + atMap _ _ = Nothing + + value (CValue v) = Just v + value (CArray (Just v) _) = Just v + value (CBoth (Just v) _) = Just v + value (CMap (Just v) _) = Just v + value _ = Nothing + +-- | Get a configuration option from the tree. If any lookup fails, the result +-- will be 'Nothing'. The tree will be traversed lazily, but the result is +-- evaluated before returning! +fromConfig :: Configuration s + -> (ConfTree (StateVar Text) -> Maybe w) + -> Clingo s (Maybe w) +fromConfig s f = head <$> fromConfigMany s [f] + +-- | Like 'fromConfig' but supporting multiple paths. +fromConfigMany :: Configuration s + -> [ConfTree (StateVar Text) -> Maybe w] + -> Clingo s [Maybe w] +fromConfigMany s fs = getTree s >>= \t -> return (force fs <*> [t]) diff --git a/src/Clingo/Control.hs b/src/Clingo/Control.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Control.hs @@ -0,0 +1,346 @@ +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +module Clingo.Control +( + IOSym, + Clingo, + ClingoWarning, + warningString, + ClingoSetting (..), + defaultClingo, + withDefaultClingo, + withClingo, + + Part (..), + + loadProgram, + addProgram, + ground, + interrupt, + cleanup, + registerPropagator, + registerUnsafePropagator, + Continue (..), + SymbolicLiteral (..), + SolveResult (..), + exhausted, + Solver, + solve, + withSolver, + SolveMode, + pattern SolveModeAsync, + pattern SolveModeYield, + + statistics, + programBuilder, + configuration, + backend, + symbolicAtoms, + theoryAtoms, + + TruthValue, + pattern TruthTrue, + pattern TruthFalse, + pattern TruthFree, + negateTruth, + assignExternal, + releaseExternal, + getConst, + hasConst, + useEnumAssumption, + + version +) +where + +import Control.Monad.IO.Class +import Control.Monad.Trans +import Control.Monad.Catch +import Data.Text (Text, pack, unpack) +import Data.Foldable + +import Foreign +import Foreign.C + +import Numeric.Natural + +import qualified Clingo.Raw as Raw +import Clingo.Internal.Utils +import Clingo.Internal.Symbol +import Clingo.Internal.Types +import Clingo.Solving (solverClose) +import Clingo.Propagation (Propagator, propagatorToIO) + +-- | Data type to encapsulate the settings for clingo. +data ClingoSetting = ClingoSetting + { clingoArgs :: [String] + , clingoLogger :: Maybe (ClingoWarning -> Text -> IO ()) + , msgLimit :: Natural } + +-- | Default settings for clingo. This is like calling clingo with no arguments, +-- and no logger. +defaultClingo :: ClingoSetting +defaultClingo = ClingoSetting [] Nothing 0 + +-- | The entry point into a computation utilizing clingo. Inside, a handle to +-- the clingo solver is available, which can not leave scope. By the same +-- mechanism, derived handles cannot be passed out either. +withClingo :: ClingoSetting -> (forall s. Clingo s r) -> IO r +withClingo settings action = do + let argc = length (clingoArgs settings) + argv <- liftIO $ mapM newCString (clingoArgs settings) + ctrl <- marshall1 $ \x -> + withArray argv $ \argvArr -> do + logCB <- maybe (pure nullFunPtr) wrapCBLogger + (clingoLogger settings) + let argv' = case clingoArgs settings of + [] -> nullPtr + _ -> argvArr + Raw.controlNew argv' (fromIntegral argc) + logCB nullPtr (fromIntegral . msgLimit $ settings) x + finally (runClingo ctrl action) $ do + Raw.controlFree ctrl + liftIO $ mapM_ free argv + +-- | Equal to @withClingo defaultClingo@ +withDefaultClingo :: (forall s. Clingo s r) -> IO r +withDefaultClingo = withClingo defaultClingo + +-- | Load a logic program from a file. +loadProgram :: FilePath -> Clingo s () +loadProgram path = askC >>= \ctrl -> + marshall0 (withCString path (Raw.controlLoad ctrl)) + +-- | Add an ungrounded logic program to the solver as a 'Text'. This function +-- can be used in order to utilize clingo's parser. See 'parseProgram' for when +-- you want to modify the AST before adding it. +addProgram :: Foldable t + => Text -- ^ Part Name + -> t Text -- ^ Part Arguments + -> Text -- ^ Program Code + -> Clingo s () +addProgram name params code = askC >>= \ctrl -> marshall0 $ + withCString (unpack name) $ \n -> + withCString (unpack code) $ \c -> do + ptrs <- mapM (newCString . unpack) (toList params) + withArrayLen ptrs $ \s ps -> + Raw.controlAdd ctrl n ps (fromIntegral s) c + +-- | A 'Part' is one building block of a logic program in clingo. Parts can be +-- grounded separately and can have arguments, which need to be initialized with +-- the solver. +data Part s = Part + { partName :: Text + , partParams :: [Symbol s] } + +rawPart :: Part s -> IO Raw.Part +rawPart p = Raw.Part <$> newCString (unpack (partName p)) + <*> newArray (map rawSymbol . partParams $ p) + <*> pure (fromIntegral (length . partParams $ p)) + +freeRawPart :: Raw.Part -> IO () +freeRawPart p = do + free (Raw.partName p) + free (Raw.partParams p) + +-- | Ground logic program parts. A callback can be provided to inject symbols +-- when needed. +ground :: [Part s] -- ^ Parts to be grounded + -> Maybe + (Location -> Text -> [Symbol s] -> ([Symbol s] -> IO ()) -> IO ()) + -- ^ Callback for injecting symbols + -> Clingo s () +ground parts extFun = askC >>= \ctrl -> marshall0 $ do + rparts <- mapM rawPart parts + res <- withArrayLen rparts $ \len arr -> do + groundCB <- maybe (pure nullFunPtr) wrapCBGround extFun + Raw.controlGround ctrl arr (fromIntegral len) groundCB nullPtr + mapM_ freeRawPart rparts + return res + +wrapCBGround :: MonadIO m + => (Location -> Text -> [Symbol s] + -> ([Symbol s] -> IO ()) -> IO ()) + -> m (FunPtr (Raw.CallbackGround ())) +wrapCBGround f = liftIO $ Raw.mkCallbackGround go + where go :: Raw.CallbackGround () + go loc name arg args _ cbSym _ = reraiseIO $ do + loc' <- fromRawLocation =<< peek loc + name' <- pack <$> peekCString name + syms <- mapM pureSymbol =<< peekArray (fromIntegral args) arg + f loc' name' syms (unwrapCBSymbol $ Raw.getCallbackSymbol cbSym) + +unwrapCBSymbol :: Raw.CallbackSymbol () -> ([Symbol s] -> IO ()) +unwrapCBSymbol f syms = + withArrayLen (map rawSymbol syms) $ \len arr -> + marshall0 (f arr (fromIntegral len) nullPtr) + +-- | Interrupt the current solve call. +interrupt :: Clingo s () +interrupt = Raw.controlInterrupt =<< askC + +-- | Clean up the domains of clingo's grounding component using the solving +-- component's top level assignment. +-- +-- This function removes atoms from domains that are false and marks atoms as +-- facts that are true. With multi-shot solving, this can result in smaller +-- groundings because less rules have to be instantiated and more +-- simplifications can be applied. +cleanup :: Clingo s () +cleanup = marshall0 . Raw.controlCleanup =<< askC + +-- | A datatype that can be used to indicate whether solving shall continue or +-- not. +data Continue = Continue | Stop + deriving (Eq, Show, Ord, Read, Enum, Bounded) + +continueBool :: Continue -> Bool +continueBool Continue = True +continueBool Stop = False + +-- | Solve the currently grounded logic program enumerating its models. Takes an +-- optional event callback. Since Clingo 5.2, the callback is no longer the only +-- way to interact with models. The callback can still be used to obtain the +-- same functionality as before. It will be called with 'Nothing' when there is +-- no more model. +-- +-- Furthermore, asynchronous solving and iterative solving is also controlled +-- from this function. See "Clingo.Solving" for more details. +-- +-- The 'Solver' must be closed explicitly after use. See 'withSolver' for a +-- bracketed version. +solve :: SolveMode -> [SymbolicLiteral s] + -> Maybe (Maybe (Model s) -> IOSym s Continue) + -> Clingo s (Solver s) +solve mode assumptions onEvent = do + ctrl <- askC + Solver <$> marshall1 (go ctrl) + where go ctrl x = + withArrayLen (map rawSymLit assumptions) $ \len arr -> do + eventCB <- maybe (pure nullFunPtr) wrapCBEvent onEvent + Raw.controlSolve + ctrl (rawSolveMode mode) + arr (fromIntegral len) eventCB nullPtr + x + +withSolver :: [SymbolicLiteral s] + -> (forall s1. Solver s1 -> IOSym s1 r) + -> Clingo s r +withSolver assumptions f = do + x <- solve SolveModeYield assumptions Nothing + Clingo (lift (f x)) + `finally` solverClose x + +wrapCBEvent :: MonadIO m + => (Maybe (Model s) -> IOSym s Continue) + -> m (FunPtr (Raw.CallbackEvent ())) +wrapCBEvent f = liftIO $ Raw.mkCallbackEvent go + where go :: Raw.SolveEvent + -> Ptr Raw.Model + -> Ptr a + -> Ptr Raw.CBool + -> IO Raw.CBool + go ev m _ r = reraiseIO $ do + m' <- case ev of + Raw.SolveEventModel -> Just . Model <$> peek m + Raw.SolveEventFinish -> pure Nothing + _ -> error "wrapCBEvent: Invalid solve event" + poke r . fromBool. continueBool =<< iosym (f m') + +-- | Obtain statistics handle. See 'Clingo.Statistics'. +statistics :: Clingo s (Statistics s) +statistics = fmap Statistics . marshall1 . Raw.controlStatistics =<< askC + +-- | Obtain program builder handle. See 'Clingo.ProgramBuilding'. +programBuilder :: Clingo s (ProgramBuilder s) +programBuilder = fmap ProgramBuilder . marshall1 + . Raw.controlProgramBuilder =<< askC + +-- | Obtain backend handle. See 'Clingo.ProgramBuilding'. +backend :: Clingo s (Backend s) +backend = fmap Backend . marshall1 . Raw.controlBackend =<< askC + +-- | Obtain configuration handle. See 'Clingo.Configuration'. +configuration :: Clingo s (Configuration s) +configuration = fmap Configuration . marshall1 + . Raw.controlConfiguration =<< askC + +-- | Obtain symbolic atoms handle. See 'Clingo.Inspection.SymbolicAtoms'. +symbolicAtoms :: Clingo s (SymbolicAtoms s) +symbolicAtoms = fmap SymbolicAtoms . marshall1 + . Raw.controlSymbolicAtoms =<< askC + +-- | Obtain theory atoms handle. See 'Clingo.Inspection.TheoryAtoms'. +theoryAtoms :: Clingo s (TheoryAtoms s) +theoryAtoms = fmap TheoryAtoms . marshall1 . Raw.controlTheoryAtoms =<< askC + +-- | Configure how learnt constraints are handled during enumeration. +-- +-- If the enumeration assumption is enabled, then all information learnt from +-- the solver's various enumeration modes is removed after a solve call. This +-- includes enumeration of cautious or brave consequences, enumeration of +-- answer sets with or without projection, or finding optimal models, as well +-- as clauses added with clingo_solve_control_add_clause(). +useEnumAssumption :: Bool -> Clingo s () +useEnumAssumption b = askC >>= \ctrl -> + marshall0 $ Raw.controlUseEnumAssumption ctrl (fromBool b) + +-- | Assign a truth value to an external atom. +-- +-- If the atom does not exist or is not external, this is a noop. +assignExternal :: Symbol s -> TruthValue -> Clingo s () +assignExternal s t = askC >>= \ctrl -> + marshall0 $ Raw.controlAssignExternal ctrl (rawSymbol s) (rawTruthValue t) + +-- | Release an external atom. +-- +-- After this call, an external atom is no longer external and subject to +-- program simplifications. If the atom does not exist or is not external, +-- this is a noop. +releaseExternal :: Symbol s -> Clingo s () +releaseExternal s = askC >>= \ctrl -> + marshall0 $ Raw.controlReleaseExternal ctrl (rawSymbol s) + +-- | Get the symbol for a constant definition @#const name = symbol@. +getConst :: Text -> Clingo s (Symbol s) +getConst name = askC >>= \ctrl -> pureSymbol =<< marshall1 (go ctrl) + where go ctrl x = withCString (unpack name) $ \cstr -> + Raw.controlGetConst ctrl cstr x + +-- | Check if there is a constant definition for the given constant. +hasConst :: Text -> Clingo s Bool +hasConst name = askC >>= \ctrl -> toBool <$> marshall1 (go ctrl) + where go ctrl x = withCString (unpack name) $ \cstr -> + Raw.controlHasConst ctrl cstr x + + +-- | Register a custom propagator with the solver. +-- +-- If the sequential flag is set to true, the propagator is called +-- sequentially when solving with multiple threads. +-- +-- See the 'Clingo.Propagation' module for more information. +registerPropagator :: Bool -> Propagator s -> Clingo s () +registerPropagator sequ prop = do + ctrl <- askC + prop' <- rawPropagator . propagatorToIO $ prop + res <- liftIO $ with prop' $ \ptr -> + Raw.controlRegisterPropagator ctrl ptr nullPtr (fromBool sequ) + checkAndThrow res + +-- | Like 'registerPropagator' but allows using 'IOPropagator's from +-- 'Clingo.Internal.Propagation'. This function is unsafe! +registerUnsafePropagator :: Bool -> IOPropagator s -> Clingo s () +registerUnsafePropagator sequ prop = do + ctrl <- askC + prop' <- rawPropagator prop + res <- liftIO $ with prop' $ \ptr -> + Raw.controlRegisterPropagator ctrl ptr nullPtr (fromBool sequ) + checkAndThrow res + +-- | Get clingo version. +version :: MonadIO m => m (Int, Int, Int) +version = do + (a,b,c) <- marshall3V Raw.version + return (fromIntegral a, fromIntegral b, fromIntegral c) diff --git a/src/Clingo/Inspection/Ground.hs b/src/Clingo/Inspection/Ground.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Inspection/Ground.hs @@ -0,0 +1,140 @@ +module Clingo.Inspection.Ground +( + TermId (..), + ElementId (..), + AspifStmt (..), + registerGroundObserver +) +where + +import Control.Monad.IO.Class +import Data.Text (Text, pack) + +import Foreign +import Foreign.C +import Numeric.Natural + +import Clingo.ProgramBuilding +import Clingo.Internal.Types +import Clingo.Internal.Utils + +import qualified Clingo.Raw as Raw + +newtype TermId = TermId { termId :: Raw.Identifier } + deriving (Show, Eq, Ord) + +newtype ElementId = ElementId { elementId :: Raw.Identifier } + deriving (Show, Eq, Ord) + +data AspifStmt s + = GRule Bool [Atom s] [Literal s] + | GWeightedRule Bool [Atom s] Natural [WeightedLiteral s] + | GMinimize Natural [WeightedLiteral s] + | GProject [Atom s] + | GExternal (Atom s) ExternalType + | GAssume [Literal s] + | GHeuristic (Atom s) HeuristicType Integer Natural [Literal s] + | GAcycEdge Node Node [Literal s] + | GTheoryTermNumber TermId Integer + | GTheoryTermString TermId Text + | GTheoryTermTuple TermId [TermId] + | GTheoryTermSet TermId [TermId] + | GTheoryTermList TermId [TermId] + | GTheoryTermFunction TermId TermId [TermId] + | GTheoryElement ElementId [TermId] [Literal s] + | GTheoryAtom (Maybe (Atom s)) TermId [ElementId] + | GTheoryAtomGuard (Maybe (Atom s)) TermId [ElementId] TermId TermId + +mkRawGPO :: MonadIO m + => (Bool -> IOSym s ()) + -> (AspifStmt s -> IOSym s ()) + -> m (Raw.GroundProgramObserver ()) +mkRawGPO inf k = liftIO $ Raw.GroundProgramObserver + <$> Raw.mkGpoInitProgram (\b _ -> reraiseIO (iosym (inf (toBool b)))) + <*> pure nullFunPtr + <*> pure nullFunPtr + <*> Raw.mkGpoRule rul + <*> Raw.mkGpoWeightRule wrule + <*> Raw.mkGpoMinimize minim + <*> Raw.mkGpoProject proj + <*> Raw.mkGpoExternal exter + <*> Raw.mkGpoAssume assum + <*> Raw.mkGpoHeuristic heuristi + <*> Raw.mkGpoAcycEdge acyc + <*> Raw.mkGpoTheoryTermNum ttnum + <*> Raw.mkGpoTheoryTermStr ttstr + <*> Raw.mkGpoTheoryTermCmp ttcomp + <*> Raw.mkGpoTheoryElement telem + <*> Raw.mkGpoTheoryAtom tatom + <*> Raw.mkGpoTheoryAtomGrd tatomg + + where rul b as an ls ln _ = reraiseIO $ do + as' <- map Atom <$> peekArray (fromIntegral an) as + ls' <- map Literal <$> peekArray (fromIntegral ln) ls + iosym (k (GRule (toBool b) as' ls')) + wrule b as an w ws wn _ = reraiseIO $ do + as' <- map Atom <$> peekArray (fromIntegral an) as + ws' <- map fromRawWeightedLiteral <$> + peekArray (fromIntegral wn) ws + iosym (k (GWeightedRule (toBool b) as' (fromIntegral w) ws')) + minim w ws wn _ = reraiseIO $ do + ws' <- map fromRawWeightedLiteral <$> + peekArray (fromIntegral wn) ws + iosym (k (GMinimize (fromIntegral w) ws')) + proj as an _ = reraiseIO $ do + as' <- map Atom <$> peekArray (fromIntegral an) as + iosym (k (GProject as')) + exter a t _ = reraiseIO $ + iosym (k (GExternal (Atom a) (fromRawExtT t))) + assum ls n _ = reraiseIO $ do + ls' <- map Literal <$> peekArray (fromIntegral n) ls + iosym (k (GAssume ls')) + heuristi a t c d ls n _ = reraiseIO $ do + let a' = Atom a + t' = fromRawHeuT t + c' = fromIntegral c + d' = fromIntegral d + ls' <- map Literal <$> peekArray (fromIntegral n) ls + iosym (k (GHeuristic a' t' c' d' ls')) + acyc a b ls n _ = reraiseIO $ do + let a' = Node . fromIntegral $ a + b' = Node . fromIntegral $ b + ls' <- map Literal <$> peekArray (fromIntegral n) ls + iosym (k (GAcycEdge a' b' ls')) + ttnum i x _ = reraiseIO $ + iosym (k (GTheoryTermNumber (TermId i) (fromIntegral x))) + ttstr i t _ = reraiseIO $ do + t' <- pack <$> peekCString t + iosym (k (GTheoryTermString (TermId i) t')) + ttcomp i a is n _ = reraiseIO $ do + is' <- map TermId <$> peekArray (fromIntegral n) is + case a of + (-1) -> iosym (k (GTheoryTermTuple (TermId i) is')) + (-2) -> iosym (k (GTheoryTermSet (TermId i) is')) + (-3) -> iosym (k (GTheoryTermList (TermId i) is')) + a' -> iosym (k (GTheoryTermFunction (TermId i) + (TermId (fromIntegral a')) is')) + telem i is n ls ln _ = reraiseIO $ do + is' <- map TermId <$> peekArray (fromIntegral n) is + ls' <- map Literal <$> peekArray (fromIntegral ln) ls + iosym (k (GTheoryElement (ElementId i) is' ls')) + tatom i t es n = reraiseIO $ do + let i' = if i == 0 then Nothing else Just (Atom (fromIntegral i)) + t' = TermId t + es' <- map ElementId <$> peekArray (fromIntegral n) es + iosym (k (GTheoryAtom i' t' es')) + tatomg i t es n a b _ = reraiseIO $ do + let i' = if i == 0 then Nothing else Just (Atom (fromIntegral i)) + t' = TermId t + a' = TermId a + b' = TermId b + es' <- map ElementId <$> peekArray (fromIntegral n) es + iosym (k (GTheoryAtomGuard i' t' es' a' b')) + +registerGroundObserver :: (Bool -> IOSym s ()) + -> (AspifStmt s -> IOSym s ()) + -> Clingo s () +registerGroundObserver i k = do + ctrl <- askC + gpo <- mkRawGPO i k + marshall0 $ with gpo $ \ptr -> Raw.controlRegisterObserver ctrl ptr nullPtr diff --git a/src/Clingo/Inspection/Symbolic.hs b/src/Clingo/Inspection/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Inspection/Symbolic.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} +module Clingo.Inspection.Symbolic +( + SymbolicAtoms, + SymbolicAtom (..), + AspifLiteral, + fromSymbolicAtoms, + fromSymbolicAtomsSig, + S.symbolicAtomsSignatures +) +where + +import Control.DeepSeq +import Control.Monad.IO.Class +import Control.Monad.Catch + +import GHC.Generics + +import Clingo.Internal.Types +import qualified Clingo.Internal.Inspection.Symbolic as S + +import System.IO.Unsafe + +data SymbolicAtom s = SymbolicAtom + { external :: Bool + , literal :: AspifLiteral s + , symbol :: Symbol s + , fact :: Bool + } + deriving (Generic) + +instance NFData (SymbolicAtom s) + +fromSymbolicAtoms :: (MonadIO m, MonadThrow m, NFData a) + => SymbolicAtoms s + -> ([SymbolicAtom s] -> a) + -> m a +fromSymbolicAtoms s f = force . f <$> buildSAtoms Nothing s + +fromSymbolicAtomsSig :: (MonadIO m, MonadThrow m, NFData a) + => SymbolicAtoms s + -> Signature s + -> ([SymbolicAtom s] -> a) + -> m a +fromSymbolicAtomsSig s sig f = force . f <$> buildSAtoms (Just sig) s + +getSAtom :: (MonadIO m, MonadThrow m) + => S.SymbolicAtoms s -> S.SIterator s -> m (SymbolicAtom s) +getSAtom s i = SymbolicAtom + <$> S.symbolicAtomsIsExternal s i + <*> S.symbolicAtomsLiteral s i + <*> S.symbolicAtomsSymbol s i + <*> S.symbolicAtomsIsFact s i + +buildSAtoms :: (MonadIO m, MonadThrow m) + => Maybe (Signature s) -> S.SymbolicAtoms s -> m [SymbolicAtom s] +buildSAtoms sig s = do + start <- S.symbolicAtomsBegin s sig + end <- S.symbolicAtomsEnd s + liftIO $ go end start + where go end i = unsafeInterleaveIO $ do + abort <- S.symbolicAtomsIteratorEq s end i + if abort then return [] + else let next = S.symbolicAtomsNext s i + in (:) <$> getSAtom s i <*> (go end =<< next) diff --git a/src/Clingo/Inspection/Theory.hs b/src/Clingo/Inspection/Theory.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Inspection/Theory.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE DeriveGeneric #-} +module Clingo.Inspection.Theory +( + TheoryAtoms, + AspifLiteral, + + Guard (..), + Element (..), + GroundTheoryAtom (..), + GroundTheoryTerm (..), + renderTerm, + termName, + + fromTheoryAtoms +) +where + +import Control.DeepSeq +import Control.Monad.IO.Class +import Control.Monad.Catch +import Data.Maybe + +import Data.Text (Text) +import GHC.Generics + +import qualified Clingo.Internal.Inspection.Theory as I +import Clingo.Internal.Types + +import System.IO.Unsafe + +data Guard s = Guard Text (GroundTheoryTerm s) + deriving (Generic) + +instance NFData (Guard s) + +data Element s = Element + { elementTuple :: [GroundTheoryTerm s] + , elementCondition :: [AspifLiteral s] + , elementConditionId :: AspifLiteral s + , renderElement :: Text + } + deriving (Generic) + +instance NFData (Element s) + +data GroundTheoryAtom s = GroundTheoryAtom + { atomGuard :: Maybe (Guard s) + , atomTerm :: GroundTheoryTerm s + , atomElements :: [Element s] + , atomLiteral :: AspifLiteral s + , renderAtom :: Text + } + deriving (Generic) + +instance NFData (GroundTheoryAtom s) + +data GroundTheoryTerm s + = SymbolTerm Text Text + | FunctionTerm Text Text [GroundTheoryTerm s] + | NumberTerm Text Integer + | TupleTerm Text [Element s] + | ListTerm Text [Element s] + | SetTerm Text [Element s] + deriving (Generic) + +instance NFData (GroundTheoryTerm s) + +renderTerm :: GroundTheoryTerm s -> Text +renderTerm (SymbolTerm r _) = r +renderTerm (FunctionTerm r _ _) = r +renderTerm (NumberTerm r _) = r +renderTerm (TupleTerm r _) = r +renderTerm (ListTerm r _) = r +renderTerm (SetTerm r _) = r + +termName :: GroundTheoryTerm s -> Maybe Text +termName (SymbolTerm _ n) = Just n +termName (FunctionTerm _ n _) = Just n +termName _ = Nothing + +fromTheoryAtoms :: (MonadIO m, MonadThrow m, NFData w) + => TheoryAtoms s -> ([GroundTheoryAtom s] -> w) -> m w +fromTheoryAtoms t f = do + size <- I.theoryAtomsSize t + ids <- mapM (I.theoryAtomsId t) (take (fromIntegral size) [0..]) + atoms <- mapM (buildAtom t) (catMaybes ids) + return . force $ f atoms + +buildTerm :: MonadIO m + => TheoryAtoms s -> I.TermId -> m (GroundTheoryTerm s) +buildTerm t i = liftIO . unsafeInterleaveIO $ do + typ <- I.theoryAtomsTermType t i + case typ of + I.TheorySymbol -> SymbolTerm + <$> I.theoryAtomsTermToString t i + <*> I.theoryAtomsTermName t i + I.TheoryFunction -> FunctionTerm + <$> I.theoryAtomsTermToString t i + <*> I.theoryAtomsTermName t i + <*> (mapM (buildTerm t) =<< I.theoryAtomsTermArguments t i) + I.TheoryNumber -> NumberTerm + <$> I.theoryAtomsTermToString t i + <*> I.theoryAtomsTermNumber t i + I.TheoryList -> ListTerm + <$> I.theoryAtomsTermToString t i + <*> pure [] + I.TheorySet -> SetTerm + <$> I.theoryAtomsTermToString t i + <*> pure [] + I.TheoryTuple -> TupleTerm + <$> I.theoryAtomsTermToString t i + <*> pure [] + _ -> error "Invalid theory term type" + +buildElement :: MonadIO m + => TheoryAtoms s -> I.ElementId -> m (Element s) +buildElement t i = liftIO . unsafeInterleaveIO $ Element + <$> (mapM (buildTerm t) =<< I.theoryAtomsElementTuple t i) + <*> I.theoryAtomsElementCondition t i + <*> I.theoryAtomsElementConditionId t i + <*> I.theoryAtomsElementToString t i + +buildAtom :: MonadIO m + => TheoryAtoms s -> I.AtomId -> m (GroundTheoryAtom s) +buildAtom t i = liftIO . unsafeInterleaveIO $ GroundTheoryAtom + <$> buildGuard + <*> (buildTerm t =<< I.theoryAtomsAtomTerm t i) + <*> (mapM (buildElement t) =<< I.theoryAtomsAtomElements t i) + <*> I.theoryAtomsAtomLiteral t i + <*> I.theoryAtomsAtomToString t i + + where buildGuard = do + b <- I.theoryAtomsAtomHasGuard t i + if b + then do + (x, tid) <- I.theoryAtomsAtomGuard t i + term <- buildTerm t tid + return $ Just (Guard x term) + else return Nothing diff --git a/src/Clingo/Internal/AST.hs b/src/Clingo/Internal/AST.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/AST.hs @@ -0,0 +1,1690 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE OverloadedStrings #-} +module Clingo.Internal.AST where + +import Control.Monad +import Data.Text (Text, unpack, pack) +import Data.Text.Lazy (fromStrict) +import Data.Bifunctor +import Data.Bifoldable +import Data.Bitraversable +import Numeric.Natural +import Foreign hiding (Pool, freePool) +import Foreign.C + +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +import Clingo.Internal.Types (Location, rawLocation, freeRawLocation, + fromRawLocation, Symbol (..), Signature (..)) +import Clingo.Internal.Symbol (pureSymbol, pureSignature) +import Clingo.Raw.AST + +newArray' :: Storable a => [a] -> IO (Ptr a) +newArray' [] = pure nullPtr +newArray' xs = newArray xs + +freeArray :: Storable a => Ptr a -> CSize -> (a -> IO ()) -> IO () +freeArray p n f = unless (p == nullPtr) $ do + p' <- peekArray (fromIntegral n) p + mapM_ f p' + free p + +freeIndirection :: Storable a => Ptr a -> (a -> IO ()) -> IO () +freeIndirection p f = unless (p == nullPtr) $ do + p' <- peek p + f p' + free p + +peekMaybe :: Storable a => Ptr a -> IO (Maybe a) +peekMaybe p + | p == nullPtr = return Nothing + | otherwise = Just <$> peek p + +fromIndirect :: Storable a => Ptr a -> (a -> IO b) -> IO b +fromIndirect p f = peek p >>= f + +data Sign = NoSign | NegationSign | DoubleNegationSign + deriving (Eq, Show, Ord) + +instance Pretty Sign where + pretty NoSign = empty + pretty NegationSign = text "not" + pretty DoubleNegationSign = text "not not" + +rawSign :: Sign -> AstSign +rawSign s = case s of + NoSign -> AstSignNone + NegationSign -> AstSignNegation + DoubleNegationSign -> AstSignDoubleNegation + +fromRawSign :: AstSign -> Sign +fromRawSign s = case s of + AstSignNone -> NoSign + AstSignNegation -> NegationSign + AstSignDoubleNegation -> DoubleNegationSign + _ -> error "Invalid clingo_ast_sign_t" + +data UnaryOperation a = UnaryOperation UnaryOperator (Term a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (UnaryOperation a) where + pretty (UnaryOperation o t) = pretty o <+> pretty t + +rawUnaryOperation :: UnaryOperation (Symbol s) -> IO AstUnaryOperation +rawUnaryOperation (UnaryOperation o t) = + AstUnaryOperation <$> pure (rawUnaryOperator o) <*> rawTerm t + +freeUnaryOperation :: AstUnaryOperation -> IO () +freeUnaryOperation (AstUnaryOperation _ t) = freeTerm t + +fromRawUnaryOperation :: AstUnaryOperation -> IO (UnaryOperation (Symbol s)) +fromRawUnaryOperation (AstUnaryOperation o t) = UnaryOperation + <$> pure (fromRawUnaryOperator o) + <*> fromRawTerm t + +data UnaryOperator = UnaryMinus | Negation | Absolute + deriving (Eq, Show, Ord) + +instance Pretty UnaryOperator where + pretty UnaryMinus = text "-" + pretty _ = text "" -- TODO + +rawUnaryOperator :: UnaryOperator -> AstUnaryOperator +rawUnaryOperator o = case o of + UnaryMinus -> AstUnaryOperatorMinus + Negation -> AstUnaryOperatorNegation + Absolute -> AstUnaryOperatorAbsolute + +fromRawUnaryOperator :: AstUnaryOperator -> UnaryOperator +fromRawUnaryOperator o = case o of + AstUnaryOperatorMinus -> UnaryMinus + AstUnaryOperatorNegation -> Negation + AstUnaryOperatorAbsolute -> Absolute + _ -> error "Invalid clingo_ast_unary_operator_t" + +data BinaryOperation a = BinaryOperation BinaryOperator (Term a) (Term a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (BinaryOperation a) where + pretty (BinaryOperation o a b) = pretty a <+> pretty o <+> pretty b + +rawBinaryOperation :: BinaryOperation (Symbol s) -> IO AstBinaryOperation +rawBinaryOperation (BinaryOperation o l r) = + AstBinaryOperation <$> pure (rawBinaryOperator o) + <*> rawTerm l <*> rawTerm r + +freeBinaryOperation :: AstBinaryOperation -> IO () +freeBinaryOperation (AstBinaryOperation _ a b) = freeTerm a >> freeTerm b + +fromRawBinaryOperation :: AstBinaryOperation -> IO (BinaryOperation (Symbol s)) +fromRawBinaryOperation (AstBinaryOperation o a b) = BinaryOperation + <$> pure (fromRawBinaryOperator o) <*> fromRawTerm a <*> fromRawTerm b + +data BinaryOperator = Xor | Or | And | Plus | Minus | Mult | Div | Mod + deriving (Eq, Show, Ord) + +instance Pretty BinaryOperator where + pretty o = text $ case o of + Xor -> "^" + Or -> "|" + And -> "&" + Plus -> "+" + Minus -> "-" + Mult -> "*" + Div -> "/" + Mod -> "%" + +rawBinaryOperator :: BinaryOperator -> AstBinaryOperator +rawBinaryOperator o = case o of + Xor -> AstBinaryOperatorXor + Or -> AstBinaryOperatorOr + And -> AstBinaryOperatorAnd + Plus -> AstBinaryOperatorPlus + Minus -> AstBinaryOperatorMinus + Mult -> AstBinaryOperatorMultiplication + Div -> AstBinaryOperatorDivision + Mod -> AstBinaryOperatorModulo + +fromRawBinaryOperator :: AstBinaryOperator -> BinaryOperator +fromRawBinaryOperator o = case o of + AstBinaryOperatorXor -> Xor + AstBinaryOperatorOr -> Or + AstBinaryOperatorAnd -> And + AstBinaryOperatorPlus -> Plus + AstBinaryOperatorMinus -> Minus + AstBinaryOperatorMultiplication -> Mult + AstBinaryOperatorDivision -> Div + AstBinaryOperatorModulo -> Mod + _ -> error "Invalid clingo_ast_binary_operator_t" + +data Interval a = Interval (Term a) (Term a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Interval a) where + pretty (Interval a b) = pretty a <> text ".." <> pretty b + +rawInterval :: Interval (Symbol s) -> IO AstInterval +rawInterval (Interval a b) = AstInterval <$> rawTerm a <*> rawTerm b + +freeInterval :: AstInterval -> IO () +freeInterval (AstInterval a b) = freeTerm a >> freeTerm b + +fromRawInterval :: AstInterval -> IO (Interval (Symbol s)) +fromRawInterval (AstInterval a b) = Interval <$> fromRawTerm a <*> fromRawTerm b + +data Function a = Function Text [Term a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Function a) where + pretty (Function t []) = text . fromStrict $ t + pretty (Function t xs) = (text . fromStrict $ t) <> tupled (map pretty xs) + +rawFunction :: Function (Symbol s) -> IO AstFunction +rawFunction (Function n ts) = do + n' <- newCString (unpack n) + ts' <- newArray' =<< mapM rawTerm ts + return $ AstFunction n' ts' (fromIntegral . length $ ts) + +freeFunction :: AstFunction -> IO () +freeFunction (AstFunction s ts n) = do + free s + freeArray ts n freeTerm + +fromRawFunction :: AstFunction -> IO (Function (Symbol s)) +fromRawFunction (AstFunction s ts n) = Function + <$> fmap pack (peekCString s) + <*> (mapM fromRawTerm =<< peekArray (fromIntegral n) ts) + +data Pool a = Pool [Term a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Pool a) where + pretty (Pool _) = text "" -- TODO! + +rawPool :: Pool (Symbol s) -> IO AstPool +rawPool (Pool ts) = do + ts' <- newArray' =<< mapM rawTerm ts + return $ AstPool ts' (fromIntegral . length $ ts) + +freePool :: AstPool -> IO () +freePool (AstPool ts n) = freeArray ts n freeTerm + +fromRawPool :: AstPool -> IO (Pool (Symbol s)) +fromRawPool (AstPool ts n) = Pool + <$> (mapM fromRawTerm =<< peekArray (fromIntegral n) ts) + +data Term a + = TermSymbol Location a + | TermVariable Location Text + | TermUOp Location (UnaryOperation a) + | TermBOp Location (BinaryOperation a) + | TermInterval Location (Interval a) + | TermFunction Location (Function a) + | TermExtFunction Location (Function a) + | TermPool Location (Pool a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Term a) where + pretty (TermSymbol _ a) = pretty a + pretty (TermVariable _ t) = text . fromStrict $ t + pretty (TermUOp _ o) = pretty o + pretty (TermBOp _ o) = pretty o + pretty (TermInterval _ i) = pretty i + pretty (TermFunction _ f) = pretty f + pretty (TermExtFunction _ f) = pretty f + pretty (TermPool _ p) = pretty p + +rawTerm :: Term (Symbol s) -> IO AstTerm +rawTerm (TermSymbol l s) = AstTermSymbol <$> rawLocation l + <*> pure (rawSymbol s) +rawTerm (TermVariable l n) = AstTermVariable <$> rawLocation l + <*> newCString (unpack n) +rawTerm (TermUOp l u) = AstTermUOp <$> rawLocation l + <*> (new =<< rawUnaryOperation u) +rawTerm (TermBOp l u) = AstTermBOp <$> rawLocation l + <*> (new =<< rawBinaryOperation u) +rawTerm (TermInterval l i) = AstTermInterval <$> rawLocation l + <*> (new =<< rawInterval i) +rawTerm (TermFunction l f) = AstTermFunction <$> rawLocation l + <*> (new =<< rawFunction f) +rawTerm (TermExtFunction l f) = + AstTermExtFunction <$> rawLocation l + <*> (new =<< rawFunction f) +rawTerm (TermPool l p) = AstTermPool <$> rawLocation l + <*> (new =<< rawPool p) + +freeTerm :: AstTerm -> IO () +freeTerm (AstTermSymbol l _) = freeRawLocation l +freeTerm (AstTermVariable l _) = freeRawLocation l +freeTerm (AstTermUOp l o) = + freeRawLocation l >> freeIndirection o freeUnaryOperation +freeTerm (AstTermBOp l o) = + freeRawLocation l >> freeIndirection o freeBinaryOperation +freeTerm (AstTermInterval l i) = + freeRawLocation l >> freeIndirection i freeInterval +freeTerm (AstTermFunction l f) = + freeRawLocation l >> freeIndirection f freeFunction +freeTerm (AstTermExtFunction l f) = + freeRawLocation l >> freeIndirection f freeFunction +freeTerm (AstTermPool l p) = + freeRawLocation l >> freeIndirection p freePool + +fromRawTerm :: AstTerm -> IO (Term (Symbol s)) +fromRawTerm (AstTermSymbol l s) = TermSymbol + <$> fromRawLocation l <*> pureSymbol s +fromRawTerm (AstTermVariable l s) = TermVariable + <$> fromRawLocation l <*> fmap pack (peekCString s) +fromRawTerm (AstTermUOp l o) = TermUOp + <$> fromRawLocation l <*> fromIndirect o fromRawUnaryOperation +fromRawTerm (AstTermBOp l o) = TermBOp + <$> fromRawLocation l <*> fromIndirect o fromRawBinaryOperation +fromRawTerm (AstTermInterval l i) = TermInterval + <$> fromRawLocation l <*> fromIndirect i fromRawInterval +fromRawTerm (AstTermFunction l f) = TermFunction + <$> fromRawLocation l <*> fromIndirect f fromRawFunction +fromRawTerm (AstTermExtFunction l f) = TermExtFunction + <$> fromRawLocation l <*> fromIndirect f fromRawFunction +fromRawTerm (AstTermPool l p) = TermPool + <$> fromRawLocation l <*> fromIndirect p fromRawPool + +data CspProductTerm a = CspProductTerm Location (Term a) (Maybe (Term a)) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawCspProductTerm :: CspProductTerm (Symbol s) -> IO AstCspProductTerm +rawCspProductTerm (CspProductTerm l t m) = AstCspProductTerm + <$> rawLocation l + <*> rawTerm t + <*> maybe (return nullPtr) (new <=< rawTerm) m + +freeCspProductTerm :: AstCspProductTerm -> IO () +freeCspProductTerm (AstCspProductTerm l t p) = do + freeRawLocation l + freeTerm t + freeIndirection p freeTerm + +fromRawCspProductTerm :: AstCspProductTerm -> IO (CspProductTerm (Symbol s)) +fromRawCspProductTerm (AstCspProductTerm l t x) = CspProductTerm + <$> fromRawLocation l + <*> fromRawTerm t + <*> (mapM fromRawTerm =<< peekMaybe x) + +data CspSumTerm a = CspSumTerm Location [CspProductTerm a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawCspSumTerm :: CspSumTerm (Symbol s) -> IO AstCspSumTerm +rawCspSumTerm (CspSumTerm l ts) = do + l' <- rawLocation l + ts' <- newArray' =<< mapM rawCspProductTerm ts + return $ AstCspSumTerm l' ts' (fromIntegral . length $ ts) + +freeCspSumTerm :: AstCspSumTerm -> IO () +freeCspSumTerm (AstCspSumTerm l ts n) = do + freeRawLocation l + freeArray ts n freeCspProductTerm + +fromRawCspSumTerm :: AstCspSumTerm -> IO (CspSumTerm (Symbol s)) +fromRawCspSumTerm (AstCspSumTerm l ts n) = CspSumTerm + <$> fromRawLocation l + <*> (mapM fromRawCspProductTerm =<< peekArray (fromIntegral n) ts) + +data CspGuard a = CspGuard ComparisonOperator (CspSumTerm a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawCspGuard :: CspGuard (Symbol s) -> IO AstCspGuard +rawCspGuard (CspGuard o t) = AstCspGuard + <$> pure (rawComparisonOperator o) <*> rawCspSumTerm t + +freeCspGuard :: AstCspGuard -> IO () +freeCspGuard (AstCspGuard _ t) = freeCspSumTerm t + +fromRawCspGuard :: AstCspGuard -> IO (CspGuard (Symbol s)) +fromRawCspGuard (AstCspGuard o t) = CspGuard + <$> pure (fromRawComparisonOperator o) + <*> fromRawCspSumTerm t + +data ComparisonOperator = GreaterThan | LessThan | LessEqual | GreaterEqual + | NotEqual | Equal + deriving (Eq, Show, Ord) + +instance Pretty ComparisonOperator where + pretty c = text $ case c of + GreaterThan -> ">" + LessThan -> "<" + LessEqual -> "<=" + GreaterEqual -> ">=" + NotEqual -> "!=" + Equal -> "=" + +rawComparisonOperator :: ComparisonOperator -> AstComparisonOperator +rawComparisonOperator o = case o of + GreaterThan -> AstComparisonOperatorGreaterThan + LessThan -> AstComparisonOperatorLessThan + LessEqual -> AstComparisonOperatorLessEqual + GreaterEqual -> AstComparisonOperatorGreaterEqual + NotEqual -> AstComparisonOperatorNotEqual + Equal -> AstComparisonOperatorEqual + +fromRawComparisonOperator :: AstComparisonOperator -> ComparisonOperator +fromRawComparisonOperator o = case o of + AstComparisonOperatorGreaterThan -> GreaterThan + AstComparisonOperatorLessThan -> LessThan + AstComparisonOperatorLessEqual -> LessEqual + AstComparisonOperatorGreaterEqual -> GreaterEqual + AstComparisonOperatorNotEqual -> NotEqual + AstComparisonOperatorEqual -> Equal + _ -> error "Invalid clingo_ast_comparison_operator_type_t" + +data CspLiteral a = CspLiteral (CspSumTerm a) [CspGuard a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawCspLiteral :: CspLiteral (Symbol s) -> IO AstCspLiteral +rawCspLiteral (CspLiteral t gs) = do + gs' <- newArray' =<< mapM rawCspGuard gs + t' <- rawCspSumTerm t + return $ AstCspLiteral t' gs' (fromIntegral . length $ gs) + +freeCspLiteral :: AstCspLiteral -> IO () +freeCspLiteral (AstCspLiteral t p n) = do + freeCspSumTerm t + freeArray p n freeCspGuard + +fromRawCspLiteral :: AstCspLiteral -> IO (CspLiteral (Symbol s)) +fromRawCspLiteral (AstCspLiteral t gs n) = CspLiteral + <$> fromRawCspSumTerm t + <*> (mapM fromRawCspGuard =<< peekArray (fromIntegral n) gs) + +data Identifier = Identifier Location Text + deriving (Eq, Show, Ord) + +instance Pretty Identifier where + pretty (Identifier _ t) = text . fromStrict $ t + +rawIdentifier :: Identifier -> IO AstId +rawIdentifier (Identifier l t) = do + l' <- rawLocation l + t' <- newCString (unpack t) + return $ AstId l' t' + +freeIdentifier :: AstId -> IO () +freeIdentifier (AstId l t) = freeRawLocation l >> free t + +fromRawIdentifier :: AstId -> IO Identifier +fromRawIdentifier (AstId l n) = Identifier + <$> fromRawLocation l + <*> fmap pack (peekCString n) + +data Comparison a = Comparison ComparisonOperator (Term a) (Term a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Comparison a) where + pretty (Comparison o a b) = pretty a <+> pretty o <+> pretty b + +rawComparison :: Comparison (Symbol s) -> IO AstComparison +rawComparison (Comparison o a b) = AstComparison + <$> pure (rawComparisonOperator o) <*> rawTerm a <*> rawTerm b + +freeComparison :: AstComparison -> IO () +freeComparison (AstComparison _ a b) = freeTerm a >> freeTerm b + +fromRawComparison :: AstComparison -> IO (Comparison (Symbol s)) +fromRawComparison (AstComparison o a b) = Comparison + <$> pure (fromRawComparisonOperator o) <*> fromRawTerm a <*> fromRawTerm b + +data Literal a + = LiteralBool Location Sign Bool + | LiteralTerm Location Sign (Term a) + | LiteralComp Location Sign (Comparison a) + | LiteralCSPL Location Sign (CspLiteral a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Literal a) where + pretty (LiteralBool _ s b) = pretty s <+> if b then text "true" else empty + pretty (LiteralTerm _ s t) = pretty s <+> pretty t + pretty (LiteralComp _ s c) = pretty s <+> pretty c + pretty _ = undefined -- TODO + +rawLiteral :: Literal (Symbol s) -> IO AstLiteral +rawLiteral (LiteralBool l s b) = AstLiteralBool + <$> rawLocation l <*> pure (rawSign s) <*> pure (fromBool b) +rawLiteral (LiteralTerm l s t) = AstLiteralTerm + <$> rawLocation l <*> pure (rawSign s) <*> (new =<< rawTerm t) +rawLiteral (LiteralComp l s c) = AstLiteralComp + <$> rawLocation l <*> pure (rawSign s) <*> (new =<< rawComparison c) +rawLiteral (LiteralCSPL l s x) = AstLiteralCSPL + <$> rawLocation l <*> pure (rawSign s) <*> (new =<< rawCspLiteral x) + +freeLiteral :: AstLiteral -> IO () +freeLiteral (AstLiteralBool l _ _) = freeRawLocation l +freeLiteral (AstLiteralTerm l _ t) = + freeRawLocation l >> freeIndirection t freeTerm +freeLiteral (AstLiteralComp l _ c) = + freeRawLocation l >> freeIndirection c freeComparison +freeLiteral (AstLiteralCSPL l _ x) = + freeRawLocation l >> freeIndirection x freeCspLiteral + +fromRawLiteral :: AstLiteral -> IO (Literal (Symbol s)) +fromRawLiteral (AstLiteralBool l s b) = LiteralBool + <$> fromRawLocation l <*> pure (fromRawSign s) <*> pure (toBool b) +fromRawLiteral (AstLiteralTerm l s b) = LiteralTerm + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect b fromRawTerm +fromRawLiteral (AstLiteralComp l s b) = LiteralComp + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect b fromRawComparison +fromRawLiteral (AstLiteralCSPL l s b) = LiteralCSPL + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect b fromRawCspLiteral + +data AggregateGuard a = AggregateGuard ComparisonOperator (Term a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +-- | Instance describing left-guards. +instance Pretty a => Pretty (AggregateGuard a) where + pretty (AggregateGuard o t) = pretty t <+> pretty o + +aguardPRight :: Pretty a => AggregateGuard a -> Doc +aguardPRight (AggregateGuard o t) = pretty o <+> pretty t + +aguardPLeft :: Pretty a => AggregateGuard a -> Doc +aguardPLeft = pretty + +rawAggregateGuard :: AggregateGuard (Symbol s) -> IO AstAggregateGuard +rawAggregateGuard (AggregateGuard o t) = AstAggregateGuard + <$> pure (rawComparisonOperator o) <*> rawTerm t + +rawAggregateGuardM :: Maybe (AggregateGuard (Symbol s)) + -> IO (Ptr AstAggregateGuard) +rawAggregateGuardM Nothing = return nullPtr +rawAggregateGuardM (Just g) = new =<< rawAggregateGuard g + +freeAggregateGuard :: AstAggregateGuard -> IO () +freeAggregateGuard (AstAggregateGuard _ t) = freeTerm t + +fromRawAggregateGuard :: AstAggregateGuard -> IO (AggregateGuard (Symbol s)) +fromRawAggregateGuard (AstAggregateGuard o t) = AggregateGuard + <$> pure (fromRawComparisonOperator o) <*> fromRawTerm t + +data ConditionalLiteral a = ConditionalLiteral (Literal a) [Literal a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (ConditionalLiteral a) where + pretty (ConditionalLiteral l []) = pretty l + pretty (ConditionalLiteral l xs) = + pretty l <+> colon <+> cat (punctuate (comma <> space) (map pretty xs)) + +rawConditionalLiteral :: ConditionalLiteral (Symbol s) + -> IO AstConditionalLiteral +rawConditionalLiteral (ConditionalLiteral l ls) = do + l' <- rawLiteral l + ls' <- newArray' =<< mapM rawLiteral ls + return $ AstConditionalLiteral l' ls' (fromIntegral . length $ ls) + +freeConditionalLiteral :: AstConditionalLiteral -> IO () +freeConditionalLiteral (AstConditionalLiteral l ls n) = do + freeLiteral l + freeArray ls n freeLiteral + +fromRawConditionalLiteral :: AstConditionalLiteral + -> IO (ConditionalLiteral (Symbol s)) +fromRawConditionalLiteral (AstConditionalLiteral l ls n) = ConditionalLiteral + <$> fromRawLiteral l + <*> (mapM fromRawLiteral =<< peekArray (fromIntegral n) ls) + +data Aggregate a = Aggregate [ConditionalLiteral a] + (Maybe (AggregateGuard a)) + (Maybe (AggregateGuard a)) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Aggregate a) where + pretty (Aggregate xs l r) = + pretty l <+> body <+> pretty (fmap aguardPRight r) + where body = braces . align . cat $ + punctuate (semi <> space) (map pretty xs) + +rawAggregate :: Aggregate (Symbol s) -> IO AstAggregate +rawAggregate (Aggregate ls a b) = do + ls' <- newArray' =<< mapM rawConditionalLiteral ls + a' <- rawAggregateGuardM a + b' <- rawAggregateGuardM b + return $ AstAggregate ls' (fromIntegral . length $ ls) a' b' + +freeAggregate :: AstAggregate -> IO () +freeAggregate (AstAggregate ls n a b) = do + freeIndirection a freeAggregateGuard + freeIndirection b freeAggregateGuard + freeArray ls n freeConditionalLiteral + +fromRawAggregate :: AstAggregate -> IO (Aggregate (Symbol s)) +fromRawAggregate (AstAggregate ls n a b) = Aggregate + <$> (mapM fromRawConditionalLiteral =<< peekArray (fromIntegral n) ls) + <*> (mapM fromRawAggregateGuard =<< peekMaybe a) + <*> (mapM fromRawAggregateGuard =<< peekMaybe b) + +data BodyAggregateElement a = BodyAggregateElement [Term a] [Literal a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (BodyAggregateElement a) where + pretty (BodyAggregateElement ts ls) = + let ts' = map pretty ts + ls' = map pretty ls + in hcat (punctuate comma ts') <+> colon <+> hcat (punctuate comma ls') + +rawBodyAggregateElement :: BodyAggregateElement (Symbol s) + -> IO AstBodyAggregateElement +rawBodyAggregateElement (BodyAggregateElement ts ls) = do + ts' <- newArray' =<< mapM rawTerm ts + ls' <- newArray' =<< mapM rawLiteral ls + return $ AstBodyAggregateElement ts' (fromIntegral . length $ ts) + ls' (fromIntegral . length $ ls) + +freeBodyAggregateElement :: AstBodyAggregateElement -> IO () +freeBodyAggregateElement (AstBodyAggregateElement ts nt ls nl) = do + freeArray ts nt freeTerm + freeArray ls nl freeLiteral + +fromRawBodyAggregateElement :: AstBodyAggregateElement + -> IO (BodyAggregateElement (Symbol s)) +fromRawBodyAggregateElement (AstBodyAggregateElement ts nt ls nl) = + BodyAggregateElement + <$> (mapM fromRawTerm =<< peekArray (fromIntegral nt) ts) + <*> (mapM fromRawLiteral =<< peekArray (fromIntegral nl) ls) + +data BodyAggregate a = BodyAggregate AggregateFunction [BodyAggregateElement a] + (Maybe (AggregateGuard a)) + (Maybe (AggregateGuard a)) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (BodyAggregate a) where + pretty (BodyAggregate f xs l r) = + pretty f <+> pretty l <+> body <+> pretty (fmap aguardPRight r) + where body = braces . align . cat $ punctuate semi (map pretty xs) + +rawBodyAggregate :: BodyAggregate (Symbol s) -> IO AstBodyAggregate +rawBodyAggregate (BodyAggregate f es a b) = AstBodyAggregate + <$> pure (rawAggregateFunction f) + <*> (newArray' =<< mapM rawBodyAggregateElement es) + <*> pure (fromIntegral . length $ es) + <*> rawAggregateGuardM a + <*> rawAggregateGuardM b + +freeBodyAggregate :: AstBodyAggregate -> IO () +freeBodyAggregate (AstBodyAggregate _ es n a b) = do + freeArray es n freeBodyAggregateElement + freeIndirection a freeAggregateGuard + freeIndirection b freeAggregateGuard + +fromRawBodyAggregate :: AstBodyAggregate -> IO (BodyAggregate (Symbol s)) +fromRawBodyAggregate (AstBodyAggregate f es n a b) = BodyAggregate + <$> pure (fromRawAggregateFunction f) + <*> (mapM fromRawBodyAggregateElement =<< peekArray (fromIntegral n) es) + <*> (mapM fromRawAggregateGuard =<< peekMaybe a) + <*> (mapM fromRawAggregateGuard =<< peekMaybe b) + +data AggregateFunction = Count | Sum | Sump | Min | Max + deriving (Eq, Show, Ord) + +instance Pretty AggregateFunction where + pretty c = text $ case c of + Count -> "#count" + Sum -> "#sum" + Sump -> "#sump" + Min -> "#min" + Max -> "#max" + +rawAggregateFunction :: AggregateFunction -> AstAggregateFunction +rawAggregateFunction f = case f of + Count -> AstAggregateFunctionCount + Sum -> AstAggregateFunctionSum + Sump -> AstAggregateFunctionSump + Min -> AstAggregateFunctionMin + Max -> AstAggregateFunctionMax + +fromRawAggregateFunction :: AstAggregateFunction -> AggregateFunction +fromRawAggregateFunction f = case f of + AstAggregateFunctionCount -> Count + AstAggregateFunctionSum -> Sum + AstAggregateFunctionSump -> Sump + AstAggregateFunctionMin -> Min + AstAggregateFunctionMax -> Max + _ -> error "Invalid clingo_ast_aggregate_function_t" + +data HeadAggregateElement a = + HeadAggregateElement [Term a] (ConditionalLiteral a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (HeadAggregateElement a) where + pretty (HeadAggregateElement ts l) = + let ts' = map pretty ts + in hcat (punctuate comma ts') <+> colon <+> pretty l + +rawHeadAggregateElement :: HeadAggregateElement (Symbol s) + -> IO AstHeadAggregateElement +rawHeadAggregateElement (HeadAggregateElement ts l) = AstHeadAggregateElement + <$> (newArray' =<< mapM rawTerm ts) + <*> pure (fromIntegral . length $ ts) + <*> rawConditionalLiteral l + +freeHeadAggregateElement :: AstHeadAggregateElement -> IO () +freeHeadAggregateElement (AstHeadAggregateElement p n l) = do + freeArray p n freeTerm + freeConditionalLiteral l + +fromRawHeadAggregateElement :: AstHeadAggregateElement + -> IO (HeadAggregateElement (Symbol s)) +fromRawHeadAggregateElement (AstHeadAggregateElement ts n l) = + HeadAggregateElement + <$> (mapM fromRawTerm =<< peekArray (fromIntegral n) ts) + <*> fromRawConditionalLiteral l + +data HeadAggregate a = HeadAggregate AggregateFunction + [HeadAggregateElement a] + (Maybe (AggregateGuard a)) + (Maybe (AggregateGuard a)) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (HeadAggregate a) where + pretty (HeadAggregate f xs l r) = + pretty f <+> pretty l <+> body <+> pretty (fmap aguardPRight r) + where body = braces . align . sep $ punctuate semi (map pretty xs) + +rawHeadAggregate :: HeadAggregate (Symbol s) -> IO AstHeadAggregate +rawHeadAggregate (HeadAggregate f es a b) = AstHeadAggregate + <$> pure (rawAggregateFunction f) + <*> (newArray' =<< mapM rawHeadAggregateElement es) + <*> pure (fromIntegral . length $ es) + <*> rawAggregateGuardM a + <*> rawAggregateGuardM b + +freeHeadAggregate :: AstHeadAggregate -> IO () +freeHeadAggregate (AstHeadAggregate _ es n a b) = do + freeArray es n freeHeadAggregateElement + freeIndirection a freeAggregateGuard + freeIndirection b freeAggregateGuard + +fromRawHeadAggregate :: AstHeadAggregate -> IO (HeadAggregate (Symbol s)) +fromRawHeadAggregate (AstHeadAggregate f es n a b) = HeadAggregate + <$> pure (fromRawAggregateFunction f) + <*> (mapM fromRawHeadAggregateElement =<< peekArray (fromIntegral n) es) + <*> (mapM fromRawAggregateGuard =<< peekMaybe a) + <*> (mapM fromRawAggregateGuard =<< peekMaybe b) + +data Disjunction a = Disjunction [ConditionalLiteral a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Disjunction a) where + pretty (Disjunction xs) = hcat (punctuate (char '|') $ map pretty xs) + +rawDisjunction :: Disjunction (Symbol s) -> IO AstDisjunction +rawDisjunction (Disjunction ls) = AstDisjunction + <$> (newArray' =<< mapM rawConditionalLiteral ls) + <*> pure (fromIntegral . length $ ls) + +freeDisjunction :: AstDisjunction -> IO () +freeDisjunction (AstDisjunction ls n) = freeArray ls n freeConditionalLiteral + +fromRawDisjunction :: AstDisjunction -> IO (Disjunction (Symbol s)) +fromRawDisjunction (AstDisjunction ls n) = Disjunction + <$> (mapM fromRawConditionalLiteral =<< peekArray (fromIntegral n) ls) + +data DisjointElement a = + DisjointElement Location [Term a] (CspSumTerm a) [Literal a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawDisjointElement :: DisjointElement (Symbol s) -> IO AstDisjointElement +rawDisjointElement (DisjointElement l ts s ls) = AstDisjointElement + <$> rawLocation l + <*> (newArray' =<< mapM rawTerm ts) + <*> pure (fromIntegral . length $ ts) + <*> rawCspSumTerm s + <*> (newArray' =<< mapM rawLiteral ls) + <*> pure (fromIntegral . length $ ls) + +freeDisjointElement :: AstDisjointElement -> IO () +freeDisjointElement (AstDisjointElement l ts nt s ls nl) = do + freeRawLocation l + freeCspSumTerm s + freeArray ts nt freeTerm + freeArray ls nl freeLiteral + +fromRawDisjointElement :: AstDisjointElement -> IO (DisjointElement (Symbol s)) +fromRawDisjointElement (AstDisjointElement l ts nt s ls nl) = DisjointElement + <$> fromRawLocation l + <*> (mapM fromRawTerm =<< peekArray (fromIntegral nt) ts) + <*> fromRawCspSumTerm s + <*> (mapM fromRawLiteral =<< peekArray (fromIntegral nl) ls) + +data Disjoint a = Disjoint [DisjointElement a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawDisjoint :: Disjoint (Symbol s) -> IO AstDisjoint +rawDisjoint (Disjoint es) = AstDisjoint + <$> (newArray' =<< mapM rawDisjointElement es) + <*> pure (fromIntegral . length $ es) + +freeDisjoint :: AstDisjoint -> IO () +freeDisjoint (AstDisjoint ls n) = freeArray ls n freeDisjointElement + +fromRawDisjoint :: AstDisjoint -> IO (Disjoint (Symbol s)) +fromRawDisjoint (AstDisjoint es n) = Disjoint + <$> (mapM fromRawDisjointElement =<< peekArray (fromIntegral n) es) + +data TheoryTermArray a = TheoryTermArray [TheoryTerm a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryTermArray :: TheoryTermArray (Symbol s) -> IO AstTheoryTermArray +rawTheoryTermArray (TheoryTermArray ts) = AstTheoryTermArray + <$> (newArray' =<< mapM rawTheoryTerm ts) + <*> pure (fromIntegral . length $ ts) + +freeTheoryTermArray :: AstTheoryTermArray -> IO () +freeTheoryTermArray (AstTheoryTermArray ts n) = freeArray ts n freeTheoryTerm + +fromRawTheoryTermArray :: AstTheoryTermArray -> IO (TheoryTermArray (Symbol s)) +fromRawTheoryTermArray (AstTheoryTermArray ts n) = TheoryTermArray + <$> (mapM fromRawTheoryTerm =<< peekArray (fromIntegral n) ts) + +data TheoryFunction a = TheoryFunction Text [TheoryTerm a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryFunction :: TheoryFunction (Symbol s) -> IO AstTheoryFunction +rawTheoryFunction (TheoryFunction t ts) = AstTheoryFunction + <$> newCString (unpack t) + <*> (newArray' =<< mapM rawTheoryTerm ts) + <*> pure (fromIntegral . length $ ts) + +freeTheoryFunction :: AstTheoryFunction -> IO () +freeTheoryFunction (AstTheoryFunction s p n) = do + free s + freeArray p n freeTheoryTerm + +fromRawTheoryFunction :: AstTheoryFunction -> IO (TheoryFunction (Symbol s)) +fromRawTheoryFunction (AstTheoryFunction s ts n) = TheoryFunction + <$> fmap pack (peekCString s) + <*> (mapM fromRawTheoryTerm =<< peekArray (fromIntegral n) ts) + +data TheoryUnparsedTermElement a = + TheoryUnparsedTermElement [Text] (TheoryTerm a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryUnparsedTermElement :: TheoryUnparsedTermElement (Symbol s) + -> IO AstTheoryUnparsedTermElement +rawTheoryUnparsedTermElement (TheoryUnparsedTermElement ts t) = + AstTheoryUnparsedTermElement + <$> (newArray' =<< mapM (newCString . unpack) ts) + <*> pure (fromIntegral . length $ ts) + <*> rawTheoryTerm t + +freeTheoryUnparsedTermElement :: AstTheoryUnparsedTermElement -> IO () +freeTheoryUnparsedTermElement (AstTheoryUnparsedTermElement ss n t) = do + freeTheoryTerm t + freeArray ss n free + +fromRawTheoryUnparsedTermElement :: AstTheoryUnparsedTermElement + -> IO (TheoryUnparsedTermElement (Symbol s)) +fromRawTheoryUnparsedTermElement (AstTheoryUnparsedTermElement ns n t) = + TheoryUnparsedTermElement + <$> (mapM (fmap pack . peekCString) =<< peekArray (fromIntegral n) ns) + <*> fromRawTheoryTerm t + +data TheoryUnparsedTerm a = TheoryUnparsedTerm [TheoryUnparsedTermElement a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryUnparsedTerm :: TheoryUnparsedTerm (Symbol s) + -> IO AstTheoryUnparsedTerm +rawTheoryUnparsedTerm (TheoryUnparsedTerm es) = AstTheoryUnparsedTerm + <$> (newArray' =<< mapM rawTheoryUnparsedTermElement es) + <*> pure (fromIntegral . length $ es) + +freeTheoryUnparsedTerm :: AstTheoryUnparsedTerm -> IO () +freeTheoryUnparsedTerm (AstTheoryUnparsedTerm es n) = + freeArray es n freeTheoryUnparsedTermElement + +fromRawTheoryUnparsedTerm :: AstTheoryUnparsedTerm + -> IO (TheoryUnparsedTerm (Symbol s)) +fromRawTheoryUnparsedTerm (AstTheoryUnparsedTerm es n) = TheoryUnparsedTerm + <$> (mapM fromRawTheoryUnparsedTermElement + =<< peekArray (fromIntegral n) es) + +data TheoryTerm a + = TheoryTermSymbol Location a + | TheoryTermVariable Location Text + | TheoryTermTuple Location (TheoryTermArray a) + | TheoryTermList Location (TheoryTermArray a) + | TheoryTermSet Location (TheoryTermArray a) + | TheoryTermFunction Location (TheoryFunction a) + | TheoryTermUnparsed Location (TheoryUnparsedTerm a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryTerm :: TheoryTerm (Symbol s) -> IO AstTheoryTerm +rawTheoryTerm (TheoryTermSymbol l s) = + AstTheoryTermSymbol <$> rawLocation l <*> pure (rawSymbol s) +rawTheoryTerm (TheoryTermVariable l t) = + AstTheoryTermVariable <$> rawLocation l <*> newCString (unpack t) +rawTheoryTerm (TheoryTermTuple l a) = + AstTheoryTermTuple <$> rawLocation l <*> (new =<< rawTheoryTermArray a) +rawTheoryTerm (TheoryTermList l a) = + AstTheoryTermList <$> rawLocation l <*> (new =<< rawTheoryTermArray a) +rawTheoryTerm (TheoryTermSet l a) = + AstTheoryTermSet <$> rawLocation l <*> (new =<< rawTheoryTermArray a) +rawTheoryTerm (TheoryTermFunction l f) = + AstTheoryTermFunction <$> rawLocation l <*> (new =<< rawTheoryFunction f) +rawTheoryTerm (TheoryTermUnparsed l t) = + AstTheoryTermUnparsed <$> rawLocation l + <*> (new =<< rawTheoryUnparsedTerm t) + +freeTheoryTerm :: AstTheoryTerm -> IO () +freeTheoryTerm (AstTheoryTermSymbol l _) = freeRawLocation l +freeTheoryTerm (AstTheoryTermVariable l _) = freeRawLocation l +freeTheoryTerm (AstTheoryTermTuple l a) = do + freeRawLocation l + freeIndirection a freeTheoryTermArray +freeTheoryTerm (AstTheoryTermList l a) = do + freeRawLocation l + freeIndirection a freeTheoryTermArray +freeTheoryTerm (AstTheoryTermSet l a) = do + freeRawLocation l + freeIndirection a freeTheoryTermArray +freeTheoryTerm (AstTheoryTermFunction l f) = do + freeRawLocation l + freeIndirection f freeTheoryFunction +freeTheoryTerm (AstTheoryTermUnparsed l t) = do + freeRawLocation l + freeIndirection t freeTheoryUnparsedTerm + +fromRawTheoryTerm :: AstTheoryTerm -> IO (TheoryTerm (Symbol s)) +fromRawTheoryTerm (AstTheoryTermSymbol l s) = + TheoryTermSymbol <$> fromRawLocation l <*> pureSymbol s +fromRawTheoryTerm (AstTheoryTermVariable l t) = + TheoryTermVariable <$> fromRawLocation l <*> fmap pack (peekCString t) +fromRawTheoryTerm (AstTheoryTermTuple l a) = + TheoryTermTuple <$> fromRawLocation l + <*> fromIndirect a fromRawTheoryTermArray +fromRawTheoryTerm (AstTheoryTermList l a) = + TheoryTermList <$> fromRawLocation l + <*> fromIndirect a fromRawTheoryTermArray +fromRawTheoryTerm (AstTheoryTermSet l a) = + TheoryTermSet <$> fromRawLocation l + <*> fromIndirect a fromRawTheoryTermArray +fromRawTheoryTerm (AstTheoryTermFunction l f) = + TheoryTermFunction <$> fromRawLocation l + <*> fromIndirect f fromRawTheoryFunction +fromRawTheoryTerm (AstTheoryTermUnparsed l t) = + TheoryTermUnparsed <$> fromRawLocation l + <*> fromIndirect t fromRawTheoryUnparsedTerm + +data TheoryAtomElement a = TheoryAtomElement [TheoryTerm a] [Literal a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryAtomElement :: TheoryAtomElement (Symbol s) -> IO AstTheoryAtomElement +rawTheoryAtomElement (TheoryAtomElement ts ls) = AstTheoryAtomElement + <$> (newArray' =<< mapM rawTheoryTerm ts) + <*> pure (fromIntegral . length $ ts) + <*> (newArray' =<< mapM rawLiteral ls) + <*> pure (fromIntegral . length $ ls) + +freeTheoryAtomElement :: AstTheoryAtomElement -> IO () +freeTheoryAtomElement (AstTheoryAtomElement ts nt ls nl) = do + freeArray ts nt freeTheoryTerm + freeArray ls nl freeLiteral + +fromRawTheoryAtomElement :: AstTheoryAtomElement + -> IO (TheoryAtomElement (Symbol s)) +fromRawTheoryAtomElement (AstTheoryAtomElement ts nt ls nl) = TheoryAtomElement + <$> (mapM fromRawTheoryTerm =<< peekArray (fromIntegral nt) ts) + <*> (mapM fromRawLiteral =<< peekArray (fromIntegral nl) ls) + +data TheoryGuard a = TheoryGuard Text (TheoryTerm a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryGuard :: TheoryGuard (Symbol s) -> IO AstTheoryGuard +rawTheoryGuard (TheoryGuard s t) = AstTheoryGuard + <$> newCString (unpack s) + <*> rawTheoryTerm t + +freeTheoryGuard :: AstTheoryGuard -> IO () +freeTheoryGuard (AstTheoryGuard s t) = free s >> freeTheoryTerm t + +fromRawTheoryGuard :: AstTheoryGuard -> IO (TheoryGuard (Symbol s)) +fromRawTheoryGuard (AstTheoryGuard n t) = TheoryGuard + <$> fmap pack (peekCString n) + <*> fromRawTheoryTerm t + +data TheoryAtom a = TheoryAtom (Term a) [TheoryAtomElement a] (TheoryGuard a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawTheoryAtom :: TheoryAtom (Symbol s) -> IO AstTheoryAtom +rawTheoryAtom (TheoryAtom t es g) = AstTheoryAtom + <$> rawTerm t + <*> (newArray' =<< mapM rawTheoryAtomElement es) + <*> pure (fromIntegral . length $ es) + <*> rawTheoryGuard g + +freeTheoryAtom :: AstTheoryAtom -> IO () +freeTheoryAtom (AstTheoryAtom t es n g) = do + freeTerm t + freeTheoryGuard g + freeArray es n freeTheoryAtomElement + +fromRawTheoryAtom :: AstTheoryAtom -> IO (TheoryAtom (Symbol s)) +fromRawTheoryAtom (AstTheoryAtom t es n g) = TheoryAtom + <$> fromRawTerm t + <*> (mapM fromRawTheoryAtomElement =<< peekArray (fromIntegral n) es) + <*> fromRawTheoryGuard g + +data HeadLiteral a + = HeadLiteral Location (Literal a) + | HeadDisjunction Location (Disjunction a) + | HeadLitAggregate Location (Aggregate a) + | HeadHeadAggregate Location (HeadAggregate a) + | HeadTheoryAtom Location (TheoryAtom a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (HeadLiteral a) where + pretty (HeadLiteral _ l) = pretty l + pretty (HeadDisjunction _ d) = pretty d + pretty (HeadLitAggregate _ a) = pretty a + pretty (HeadHeadAggregate _ a) = pretty a + pretty (HeadTheoryAtom _ _) = text "" -- TODO! + +rawHeadLiteral :: HeadLiteral (Symbol s) -> IO AstHeadLiteral +rawHeadLiteral (HeadLiteral l x) = AstHeadLiteral + <$> rawLocation l <*> (new =<< rawLiteral x) +rawHeadLiteral (HeadDisjunction l d) = AstHeadDisjunction + <$> rawLocation l <*> (new =<< rawDisjunction d) +rawHeadLiteral (HeadLitAggregate l d) = AstHeadLitAggregate + <$> rawLocation l <*> (new =<< rawAggregate d) +rawHeadLiteral (HeadHeadAggregate l d) = AstHeadHeadAggregate + <$> rawLocation l <*> (new =<< rawHeadAggregate d) +rawHeadLiteral (HeadTheoryAtom l d) = AstHeadTheoryAtom + <$> rawLocation l <*> (new =<< rawTheoryAtom d) + +freeHeadLiteral :: AstHeadLiteral -> IO () +freeHeadLiteral (AstHeadLiteral l x) = do + freeRawLocation l + freeIndirection x freeLiteral +freeHeadLiteral (AstHeadDisjunction l x) = do + freeRawLocation l + freeIndirection x freeDisjunction +freeHeadLiteral (AstHeadLitAggregate l x) = do + freeRawLocation l + freeIndirection x freeAggregate +freeHeadLiteral (AstHeadHeadAggregate l x) = do + freeRawLocation l + freeIndirection x freeHeadAggregate +freeHeadLiteral (AstHeadTheoryAtom l x) = do + freeRawLocation l + freeIndirection x freeTheoryAtom + +fromRawHeadLiteral :: AstHeadLiteral -> IO (HeadLiteral (Symbol s)) +fromRawHeadLiteral (AstHeadLiteral l x) = HeadLiteral + <$> fromRawLocation l <*> fromIndirect x fromRawLiteral +fromRawHeadLiteral (AstHeadDisjunction l x) = HeadDisjunction + <$> fromRawLocation l <*> fromIndirect x fromRawDisjunction +fromRawHeadLiteral (AstHeadLitAggregate l x) = HeadLitAggregate + <$> fromRawLocation l <*> fromIndirect x fromRawAggregate +fromRawHeadLiteral (AstHeadHeadAggregate l x) = HeadHeadAggregate + <$> fromRawLocation l <*> fromIndirect x fromRawHeadAggregate +fromRawHeadLiteral (AstHeadTheoryAtom l x) = HeadTheoryAtom + <$> fromRawLocation l <*> fromIndirect x fromRawTheoryAtom + +data BodyLiteral a + = BodyLiteral Location Sign (Literal a) + | BodyConditional Location (ConditionalLiteral a) + | BodyLitAggregate Location Sign (Aggregate a) + | BodyBodyAggregate Location Sign (BodyAggregate a) + | BodyTheoryAtom Location Sign (TheoryAtom a) + | BodyDisjoint Location Sign (Disjoint a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (BodyLiteral a) where + pretty (BodyLiteral _ s l) = pretty s <+> pretty l + pretty (BodyConditional _ c) = pretty c + pretty (BodyLitAggregate _ s a) = pretty s <+> pretty a + pretty (BodyBodyAggregate _ s a) = pretty s <+> pretty a + pretty (BodyTheoryAtom _ s _) = pretty s <+> text "" -- TODO + pretty (BodyDisjoint _ s _) = pretty s <+> text "" -- TODO + +rawBodyLiteral :: BodyLiteral (Symbol s) -> IO AstBodyLiteral +rawBodyLiteral (BodyLiteral l s x) = AstBodyLiteral + <$> rawLocation l <*> pure (rawSign s) + <*> (new =<< rawLiteral x) +rawBodyLiteral (BodyConditional l x) = AstBodyConditional + <$> rawLocation l + <*> (new =<< rawConditionalLiteral x) +rawBodyLiteral (BodyLitAggregate l s x) = AstBodyLitAggregate + <$> rawLocation l <*> pure (rawSign s) + <*> (new =<< rawAggregate x) +rawBodyLiteral (BodyBodyAggregate l s x) = AstBodyBodyAggregate + <$> rawLocation l <*> pure (rawSign s) + <*> (new =<< rawBodyAggregate x) +rawBodyLiteral (BodyTheoryAtom l s x) = AstBodyTheoryAtom + <$> rawLocation l <*> pure (rawSign s) + <*> (new =<< rawTheoryAtom x) +rawBodyLiteral (BodyDisjoint l s x) = AstBodyDisjoint + <$> rawLocation l <*> pure (rawSign s) + <*> (new =<< rawDisjoint x) + +freeBodyLiteral :: AstBodyLiteral -> IO () +freeBodyLiteral (AstBodyLiteral l _ x) = do + freeRawLocation l + freeIndirection x freeLiteral +freeBodyLiteral (AstBodyConditional l x) = do + freeRawLocation l + freeIndirection x freeConditionalLiteral +freeBodyLiteral (AstBodyLitAggregate l _ x) = do + freeRawLocation l + freeIndirection x freeAggregate +freeBodyLiteral (AstBodyBodyAggregate l _ x) = do + freeRawLocation l + freeIndirection x freeBodyAggregate +freeBodyLiteral (AstBodyTheoryAtom l _ x) = do + freeRawLocation l + freeIndirection x freeTheoryAtom +freeBodyLiteral (AstBodyDisjoint l _ x) = do + freeRawLocation l + freeIndirection x freeDisjoint + +fromRawBodyLiteral :: AstBodyLiteral -> IO (BodyLiteral (Symbol s)) +fromRawBodyLiteral (AstBodyLiteral l s x) = BodyLiteral + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect x fromRawLiteral +fromRawBodyLiteral (AstBodyConditional l x) = BodyConditional + <$> fromRawLocation l <*> fromIndirect x fromRawConditionalLiteral +fromRawBodyLiteral (AstBodyLitAggregate l s x) = BodyLitAggregate + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect x fromRawAggregate +fromRawBodyLiteral (AstBodyBodyAggregate l s x) = BodyBodyAggregate + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect x fromRawBodyAggregate +fromRawBodyLiteral (AstBodyTheoryAtom l s x) = BodyTheoryAtom + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect x fromRawTheoryAtom +fromRawBodyLiteral (AstBodyDisjoint l s x) = BodyDisjoint + <$> fromRawLocation l <*> pure (fromRawSign s) + <*> fromIndirect x fromRawDisjoint + +data TheoryOperatorDefinition = + TheoryOperatorDefinition Location Text Natural TheoryOperatorType + deriving (Eq, Show, Ord) + +rawTheoryOperatorDefinition :: TheoryOperatorDefinition + -> IO AstTheoryOperatorDefinition +rawTheoryOperatorDefinition (TheoryOperatorDefinition l s x t) = + AstTheoryOperatorDefinition + <$> rawLocation l + <*> newCString (unpack s) + <*> pure (fromIntegral x) + <*> pure (rawTheoryOperatorType t) + +freeTheoryOperatorDefinition :: AstTheoryOperatorDefinition -> IO () +freeTheoryOperatorDefinition (AstTheoryOperatorDefinition l s _ _) = + freeRawLocation l >> free s + +fromRawTheoryOperatorDefinition :: AstTheoryOperatorDefinition + -> IO TheoryOperatorDefinition +fromRawTheoryOperatorDefinition (AstTheoryOperatorDefinition l s i t) = + TheoryOperatorDefinition + <$> fromRawLocation l + <*> fmap pack (peekCString s) + <*> pure (fromIntegral i) + <*> pure (fromRawTheoryOperatorType t) + +data TheoryOperatorType = Unary | BinLeft | BinRight + deriving (Eq, Show, Ord) + +rawTheoryOperatorType :: TheoryOperatorType -> AstTheoryOperatorType +rawTheoryOperatorType t = case t of + Unary -> AstTheoryOperatorTypeUnary + BinLeft -> AstTheoryOperatorTypeBinaryLeft + BinRight -> AstTheoryOperatorTypeBinaryRight + +fromRawTheoryOperatorType :: AstTheoryOperatorType -> TheoryOperatorType +fromRawTheoryOperatorType t = case t of + AstTheoryOperatorTypeUnary -> Unary + AstTheoryOperatorTypeBinaryLeft -> BinLeft + AstTheoryOperatorTypeBinaryRight -> BinRight + _ -> error "Invalid clingo_ast_theory_operator_type_t" + +data TheoryTermDefinition = + TheoryTermDefinition Location Text [TheoryOperatorDefinition] + deriving (Eq, Show, Ord) + +rawTheoryTermDefinition :: TheoryTermDefinition -> IO AstTheoryTermDefinition +rawTheoryTermDefinition (TheoryTermDefinition l s xs) = AstTheoryTermDefinition + <$> rawLocation l + <*> newCString (unpack s) + <*> (newArray' =<< mapM rawTheoryOperatorDefinition xs) + <*> pure (fromIntegral . length $ xs) + +freeTheoryTermDefinition :: AstTheoryTermDefinition -> IO () +freeTheoryTermDefinition (AstTheoryTermDefinition l s xs n) = do + freeRawLocation l + free s + freeArray xs n freeTheoryOperatorDefinition + +fromRawTheoryTermDefinition :: AstTheoryTermDefinition + -> IO TheoryTermDefinition +fromRawTheoryTermDefinition (AstTheoryTermDefinition l s es n) = + TheoryTermDefinition + <$> fromRawLocation l + <*> fmap pack (peekCString s) + <*> (mapM fromRawTheoryOperatorDefinition =<< peekArray (fromIntegral n) es) + +data TheoryGuardDefinition = + TheoryGuardDefinition Text [Text] + deriving (Eq, Show, Ord) + +rawTheoryGuardDefinition :: TheoryGuardDefinition -> IO AstTheoryGuardDefinition +rawTheoryGuardDefinition (TheoryGuardDefinition t ts) = AstTheoryGuardDefinition + <$> newCString (unpack t) + <*> (newArray' =<< mapM (newCString . unpack) ts) + <*> pure (fromIntegral . length $ ts) + +freeTheoryGuardDefinition :: AstTheoryGuardDefinition -> IO () +freeTheoryGuardDefinition (AstTheoryGuardDefinition s ss n) = do + free s + freeArray ss n free + +fromRawTheoryGuardDefinition :: AstTheoryGuardDefinition + -> IO TheoryGuardDefinition +fromRawTheoryGuardDefinition (AstTheoryGuardDefinition t ts n) = + TheoryGuardDefinition + <$> fmap pack (peekCString t) + <*> (mapM (fmap pack . peekCString) =<< peekArray (fromIntegral n) ts) + +data TheoryAtomDefinition = + TheoryAtomDefinition Location TheoryAtomDefinitionType + Text Int Text TheoryGuardDefinition + deriving (Eq, Show, Ord) + +rawTheoryAtomDefinition :: TheoryAtomDefinition -> IO AstTheoryAtomDefinition +rawTheoryAtomDefinition (TheoryAtomDefinition l t a i b d) = + AstTheoryAtomDefinition + <$> rawLocation l + <*> pure (rawTheoryAtomDefinitionType t) + <*> newCString (unpack a) + <*> pure (fromIntegral i) + <*> newCString (unpack b) + <*> (new =<< rawTheoryGuardDefinition d) + +freeTheoryAtomDefinition :: AstTheoryAtomDefinition -> IO () +freeTheoryAtomDefinition (AstTheoryAtomDefinition l _ a _ b p) = do + freeRawLocation l + free a + free b + freeIndirection p freeTheoryGuardDefinition + +fromRawTheoryAtomDefinition :: AstTheoryAtomDefinition + -> IO TheoryAtomDefinition +fromRawTheoryAtomDefinition (AstTheoryAtomDefinition l t a i b g) = + TheoryAtomDefinition + <$> fromRawLocation l + <*> pure (fromRawTheoryAtomDefinitionType t) + <*> fmap pack (peekCString a) + <*> pure (fromIntegral i) + <*> fmap pack (peekCString b) + <*> fromIndirect g fromRawTheoryGuardDefinition + +data TheoryAtomDefinitionType = Head | Body | Any | Directive + deriving (Eq, Show, Ord) + +rawTheoryAtomDefinitionType :: TheoryAtomDefinitionType + -> AstTheoryAtomDefType +rawTheoryAtomDefinitionType t = case t of + Head -> AstTheoryAtomDefinitionTypeHead + Body -> AstTheoryAtomDefinitionTypeBody + Any -> AstTheoryAtomDefinitionTypeAny + Directive -> AstTheoryAtomDefinitionTypeDirective + +fromRawTheoryAtomDefinitionType :: AstTheoryAtomDefType + -> TheoryAtomDefinitionType +fromRawTheoryAtomDefinitionType t = case t of + AstTheoryAtomDefinitionTypeHead -> Head + AstTheoryAtomDefinitionTypeBody -> Body + AstTheoryAtomDefinitionTypeAny -> Any + AstTheoryAtomDefinitionTypeDirective -> Directive + _ -> error "Invalid clingo_ast_theory_atom_definition_type_t" + +data TheoryDefinition = + TheoryDefinition Text [TheoryTermDefinition] [TheoryAtomDefinition] + deriving (Eq, Show, Ord) + +rawTheoryDefinition :: TheoryDefinition -> IO AstTheoryDefinition +rawTheoryDefinition (TheoryDefinition t ts as) = AstTheoryDefinition + <$> newCString (unpack t) + <*> (newArray' =<< mapM rawTheoryTermDefinition ts) + <*> pure (fromIntegral . length $ ts) + <*> (newArray' =<< mapM rawTheoryAtomDefinition as) + <*> pure (fromIntegral . length $ as) + +freeTheoryDefinition :: AstTheoryDefinition -> IO () +freeTheoryDefinition (AstTheoryDefinition t ts nt as na) = do + free t + freeArray ts nt freeTheoryTermDefinition + freeArray as na freeTheoryAtomDefinition + +fromRawTheoryDefinition :: AstTheoryDefinition -> IO TheoryDefinition +fromRawTheoryDefinition (AstTheoryDefinition s ts nt as na) = TheoryDefinition + <$> fmap pack (peekCString s) + <*> (mapM fromRawTheoryTermDefinition =<< peekArray (fromIntegral nt) ts) + <*> (mapM fromRawTheoryAtomDefinition =<< peekArray (fromIntegral na) as) + +data Rule a = Rule (HeadLiteral a) [BodyLiteral a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Rule a) where + pretty (Rule h []) = pretty h + pretty (Rule h bs) = + pretty h <+> text ":-" + <+> align (sep (punctuate comma (map pretty bs))) + +rawRule :: Rule (Symbol s) -> IO AstRule +rawRule (Rule h bs) = AstRule + <$> rawHeadLiteral h <*> (newArray' =<< mapM rawBodyLiteral bs) + <*> pure (fromIntegral . length $ bs) + +freeRule :: AstRule -> IO () +freeRule (AstRule h bs n) = do + freeHeadLiteral h + freeArray bs n freeBodyLiteral + +fromRawRule :: AstRule -> IO (Rule (Symbol s)) +fromRawRule (AstRule h bs n) = Rule + <$> fromRawHeadLiteral h + <*> (mapM fromRawBodyLiteral =<< peekArray (fromIntegral n) bs) + +data Definition a = Definition Text (Term a) Bool + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawDefinition :: Definition (Symbol s) -> IO AstDefinition +rawDefinition (Definition s t b) = AstDefinition + <$> newCString (unpack s) + <*> rawTerm t + <*> pure (fromBool b) + +freeDefinition :: AstDefinition -> IO () +freeDefinition (AstDefinition s t _) = free s >> freeTerm t + +fromRawDefinition :: AstDefinition -> IO (Definition (Symbol s)) +fromRawDefinition (AstDefinition s t b) = Definition + <$> fmap pack (peekCString s) + <*> fromRawTerm t + <*> pure (toBool b) + +data ShowSignature b = ShowSignature b Bool + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawShowSignature :: ShowSignature (Signature b) -> IO AstShowSignature +rawShowSignature (ShowSignature s b) = AstShowSignature + <$> pure (rawSignature s) + <*> pure (fromBool b) + +freeShowSignature :: AstShowSignature -> IO () +freeShowSignature (AstShowSignature _ _) = return () + +fromRawShowSignature :: AstShowSignature -> IO (ShowSignature (Signature s)) +fromRawShowSignature (AstShowSignature s b) = ShowSignature + <$> pureSignature s + <*> pure (toBool b) + +data ShowTerm a = ShowTerm (Term a) [BodyLiteral a] Bool + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawShowTerm :: ShowTerm (Symbol s) -> IO AstShowTerm +rawShowTerm (ShowTerm t ls b) = AstShowTerm + <$> rawTerm t + <*> (newArray' =<< mapM rawBodyLiteral ls) + <*> pure (fromIntegral . length $ ls) + <*> pure (fromBool b) + +freeShowTerm :: AstShowTerm -> IO () +freeShowTerm (AstShowTerm t ls n _) = do + freeTerm t + freeArray ls n freeBodyLiteral + +fromRawShowTerm :: AstShowTerm -> IO (ShowTerm (Symbol s)) +fromRawShowTerm (AstShowTerm t ls n b) = ShowTerm + <$> fromRawTerm t + <*> (mapM fromRawBodyLiteral =<< peekArray (fromIntegral n) ls) + <*> pure (toBool b) + +data Minimize a = Minimize (Term a) (Term a) [Term a] [BodyLiteral a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawMinimize :: Minimize (Symbol s) -> IO AstMinimize +rawMinimize (Minimize a b ts ls) = AstMinimize + <$> rawTerm a + <*> rawTerm b + <*> (newArray' =<< mapM rawTerm ts) + <*> pure (fromIntegral . length $ ts) + <*> (newArray' =<< mapM rawBodyLiteral ls) + <*> pure (fromIntegral . length $ ls) + +freeMinimize :: AstMinimize -> IO () +freeMinimize (AstMinimize a b ts nt ls nl) = do + freeTerm a + freeTerm b + freeArray ts nt freeTerm + freeArray ls nl freeBodyLiteral + +fromRawMinimize :: AstMinimize -> IO (Minimize (Symbol s)) +fromRawMinimize (AstMinimize a b ts nt ls nl) = Minimize + <$> fromRawTerm a + <*> fromRawTerm b + <*> (mapM fromRawTerm =<< peekArray (fromIntegral nt) ts) + <*> (mapM fromRawBodyLiteral =<< peekArray (fromIntegral nl) ls) + +data Script = Script ScriptType Text + deriving (Eq, Show, Ord) + +rawScript :: Script -> IO AstScript +rawScript (Script t s) = AstScript + <$> pure (rawScriptType t) + <*> newCString (unpack s) + +freeScript :: AstScript -> IO () +freeScript (AstScript _ s) = free s + +fromRawScript :: AstScript -> IO Script +fromRawScript (AstScript t s) = Script + <$> pure (fromRawScriptType t) + <*> fmap pack (peekCString s) + +data ScriptType = Lua | Python + deriving (Eq, Show, Ord) + +rawScriptType :: ScriptType -> AstScriptType +rawScriptType t = case t of + Lua -> AstScriptTypeLua + Python -> AstScriptTypePython + +fromRawScriptType :: AstScriptType -> ScriptType +fromRawScriptType t = case t of + AstScriptTypeLua -> Lua + AstScriptTypePython -> Python + _ -> error "Invalid clingo_ast_script_type_t" + +data Program = Program Text [Identifier] + deriving (Eq, Show, Ord) + +instance Pretty Program where + pretty (Program n []) = + text "#program" <+> text (fromStrict n) + pretty (Program n is) = + text "#program" <+> text (fromStrict n) <> tupled (map pretty is) + +rawProgram :: Program -> IO AstProgram +rawProgram (Program n is) = AstProgram + <$> newCString (unpack n) + <*> (newArray' =<< mapM rawIdentifier is) + <*> pure (fromIntegral . length $ is) + +freeProgram :: AstProgram -> IO () +freeProgram (AstProgram s xs n) = free s >> freeArray xs n freeIdentifier + +fromRawProgram :: AstProgram -> IO Program +fromRawProgram (AstProgram s es n) = Program + <$> fmap pack (peekCString s) + <*> (mapM fromRawIdentifier =<< peekArray (fromIntegral n) es) + +data External a = External (Term a) [BodyLiteral a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (External a) where + pretty (External n []) = + text "#external" <+> pretty n + pretty (External n is) = + text "#external" <+> pretty n <> tupled (map pretty is) + +rawExternal :: External (Symbol s) -> IO AstExternal +rawExternal (External t ls) = AstExternal + <$> rawTerm t + <*> (newArray' =<< mapM rawBodyLiteral ls) + <*> pure (fromIntegral . length $ ls) + +freeExternal :: AstExternal -> IO () +freeExternal (AstExternal t ls n) = freeTerm t >> freeArray ls n freeBodyLiteral + +fromRawExternal :: AstExternal -> IO (External (Symbol s)) +fromRawExternal (AstExternal t ls n) = External + <$> fromRawTerm t + <*> (mapM fromRawBodyLiteral =<< peekArray (fromIntegral n) ls) + +data Edge a = Edge (Term a) (Term a) [BodyLiteral a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawEdge :: Edge (Symbol s) -> IO AstEdge +rawEdge (Edge a b ls) = AstEdge + <$> rawTerm a + <*> rawTerm b + <*> (newArray' =<< mapM rawBodyLiteral ls) + <*> pure (fromIntegral . length $ ls) + +freeEdge :: AstEdge -> IO () +freeEdge (AstEdge a b ls n) = do + freeTerm a + freeTerm b + freeArray ls n freeBodyLiteral + +fromRawEdge :: AstEdge -> IO (Edge (Symbol s)) +fromRawEdge (AstEdge a b ls n) = Edge + <$> fromRawTerm a + <*> fromRawTerm b + <*> (mapM fromRawBodyLiteral =<< peekArray (fromIntegral n) ls) + +data Heuristic a = Heuristic (Term a) [BodyLiteral a] (Term a) (Term a) (Term a) + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance Pretty a => Pretty (Heuristic a) where + pretty (Heuristic t1 [] t2 t3 t4) = + text "#heuristic" <+> pretty t1 + <> dot <+> char '[' <+> pretty t2 <> char '@' + <> pretty t3 <+> comma <+> pretty t4 <+> char ']' + pretty (Heuristic t1 cs t2 t3 t4) = + text "#heuristic" <+> pretty t1 <+> colon <+> list (map pretty cs) + <> dot <+> char '[' <+> pretty t2 <> char '@' + <> pretty t3 <+> comma <+> pretty t4 <+> char ']' + +rawHeuristic :: Heuristic (Symbol s) -> IO AstHeuristic +rawHeuristic (Heuristic a ls b c d) = AstHeuristic + <$> rawTerm a + <*> (newArray' =<< mapM rawBodyLiteral ls) + <*> pure (fromIntegral . length $ ls) + <*> rawTerm b + <*> rawTerm c + <*> rawTerm d + +freeHeuristic :: AstHeuristic -> IO () +freeHeuristic (AstHeuristic a ls n b c d) = do + freeTerm a + freeTerm b + freeTerm c + freeTerm d + freeArray ls n freeBodyLiteral + +fromRawHeuristic :: AstHeuristic -> IO (Heuristic (Symbol s)) +fromRawHeuristic (AstHeuristic t ls n a b c) = Heuristic + <$> fromRawTerm t + <*> (mapM fromRawBodyLiteral =<< peekArray (fromIntegral n) ls) + <*> fromRawTerm a + <*> fromRawTerm b + <*> fromRawTerm c + +data Project a = Project (Term a) [BodyLiteral a] + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +rawProject :: Project (Symbol s) -> IO AstProject +rawProject (Project t ls) = AstProject + <$> rawTerm t + <*> (newArray' =<< mapM rawBodyLiteral ls) + <*> pure (fromIntegral . length $ ls) + +freeProject :: AstProject -> IO () +freeProject (AstProject t ls n) = do + freeTerm t + freeArray ls n freeBodyLiteral + +fromRawProject :: AstProject -> IO (Project (Symbol s)) +fromRawProject (AstProject t ls n) = Project + <$> fromRawTerm t + <*> (mapM fromRawBodyLiteral =<< peekArray (fromIntegral n) ls) + +data Statement a b + = StmtRule Location (Rule a) + | StmtDefinition Location (Definition a) + | StmtShowSignature Location (ShowSignature b) + | StmtShowTerm Location (ShowTerm a) + | StmtMinimize Location (Minimize a) + | StmtScript Location Script + | StmtProgram Location Program + | StmtExternal Location (External a) + | StmtEdge Location (Edge a) + | StmtHeuristic Location (Heuristic a) + | StmtProject Location (Project a) + | StmtSignature Location b + | StmtTheoryDefinition Location TheoryDefinition + deriving (Eq, Show, Ord, Functor, Foldable, Traversable) + +instance (Pretty a, Pretty b) => Pretty (Statement a b) where + pretty (StmtRule _ r) = pretty r <> dot + pretty (StmtSignature _ s) = pretty s <> dot + pretty (StmtProgram _ p) = pretty p <> dot + pretty (StmtExternal _ p) = pretty p <> dot + pretty (StmtHeuristic _ p) = pretty p + pretty _ = text "" -- TODO + +instance Bifunctor Statement where + bimap f g s = case s of + StmtRule l x -> StmtRule l (fmap f x) + StmtDefinition l x -> StmtDefinition l (fmap f x) + StmtShowSignature l x -> StmtShowSignature l (fmap g x) + StmtShowTerm l x -> StmtShowTerm l (fmap f x) + StmtMinimize l x -> StmtMinimize l (fmap f x) + StmtScript l x -> StmtScript l x + StmtProgram l x -> StmtProgram l x + StmtExternal l x -> StmtExternal l (fmap f x) + StmtEdge l x -> StmtEdge l (fmap f x) + StmtHeuristic l x -> StmtHeuristic l (fmap f x) + StmtProject l x -> StmtProject l (fmap f x) + StmtSignature l x -> StmtSignature l (g x) + StmtTheoryDefinition l x -> StmtTheoryDefinition l x + +instance Bifoldable Statement where + bifoldr f g z s = case s of + StmtRule _ x -> foldr f z x + StmtDefinition _ x -> foldr f z x + StmtShowSignature _ x -> foldr g z x + StmtShowTerm _ x -> foldr f z x + StmtMinimize _ x -> foldr f z x + StmtScript _ _ -> z + StmtProgram _ _ -> z + StmtExternal _ x -> foldr f z x + StmtEdge _ x -> foldr f z x + StmtHeuristic _ x -> foldr f z x + StmtProject _ x -> foldr f z x + StmtSignature _ x -> g x z + StmtTheoryDefinition _ _ -> z + +instance Bitraversable Statement where + bitraverse f g s = case s of + StmtRule l x -> StmtRule l <$> traverse f x + StmtDefinition l x -> StmtDefinition l <$> traverse f x + StmtShowSignature l x -> StmtShowSignature l <$> traverse g x + StmtShowTerm l x -> StmtShowTerm l <$> traverse f x + StmtMinimize l x -> StmtMinimize l <$> traverse f x + StmtScript l x -> pure $ StmtScript l x + StmtProgram l x -> pure $ StmtProgram l x + StmtExternal l x -> StmtExternal l <$> traverse f x + StmtEdge l x -> StmtEdge l <$> traverse f x + StmtHeuristic l x -> StmtHeuristic l <$> traverse f x + StmtProject l x -> StmtProject l <$> traverse f x + StmtSignature l x -> StmtSignature l <$> g x + StmtTheoryDefinition l x -> pure $ StmtTheoryDefinition l x + +rawStatement :: Statement (Symbol s) (Signature s) -> IO AstStatement +rawStatement (StmtRule l x) = AstStmtRule + <$> rawLocation l <*> (new =<< rawRule x) +rawStatement (StmtDefinition l x) = AstStmtDefinition + <$> rawLocation l <*> (new =<< rawDefinition x) +rawStatement (StmtShowSignature l x) = AstStmtShowSignature + <$> rawLocation l <*> (new =<< rawShowSignature x) +rawStatement (StmtShowTerm l x) = AstStmtShowTerm + <$> rawLocation l <*> (new =<< rawShowTerm x) +rawStatement (StmtMinimize l x) = AstStmtMinimize + <$> rawLocation l <*> (new =<< rawMinimize x) +rawStatement (StmtScript l x) = AstStmtScript + <$> rawLocation l <*> (new =<< rawScript x) +rawStatement (StmtProgram l x) = AstStmtProgram + <$> rawLocation l <*> (new =<< rawProgram x) +rawStatement (StmtExternal l x) = AstStmtExternal + <$> rawLocation l <*> (new =<< rawExternal x) +rawStatement (StmtEdge l x) = AstStmtEdge + <$> rawLocation l <*> (new =<< rawEdge x) +rawStatement (StmtHeuristic l x) = AstStmtHeuristic + <$> rawLocation l <*> (new =<< rawHeuristic x) +rawStatement (StmtProject l x) = AstStmtProject + <$> rawLocation l <*> (new =<< rawProject x) +rawStatement (StmtSignature l x) = AstStmtSignature + <$> rawLocation l <*> pure (rawSignature x) +rawStatement (StmtTheoryDefinition l x) = AstStmtTheoryDefn + <$> rawLocation l <*> (new =<< rawTheoryDefinition x) + +freeStatement :: AstStatement -> IO () +freeStatement (AstStmtRule l x) = + freeRawLocation l >> freeIndirection x freeRule +freeStatement (AstStmtDefinition l x) = + freeRawLocation l >> freeIndirection x freeDefinition +freeStatement (AstStmtShowSignature l x) = + freeRawLocation l >> freeIndirection x freeShowSignature +freeStatement (AstStmtShowTerm l x) = + freeRawLocation l >> freeIndirection x freeShowTerm +freeStatement (AstStmtMinimize l x) = + freeRawLocation l >> freeIndirection x freeMinimize +freeStatement (AstStmtScript l x) = + freeRawLocation l >> freeIndirection x freeScript +freeStatement (AstStmtProgram l x) = + freeRawLocation l >> freeIndirection x freeProgram +freeStatement (AstStmtExternal l x) = + freeRawLocation l >> freeIndirection x freeExternal +freeStatement (AstStmtEdge l x) = + freeRawLocation l >> freeIndirection x freeEdge +freeStatement (AstStmtHeuristic l x) = + freeRawLocation l >> freeIndirection x freeHeuristic +freeStatement (AstStmtProject l x) = + freeRawLocation l >> freeIndirection x freeProject +freeStatement (AstStmtSignature l _) = freeRawLocation l +freeStatement (AstStmtTheoryDefn l x) = + freeRawLocation l >> freeIndirection x freeTheoryDefinition + +fromRawStatement :: AstStatement -> IO (Statement (Symbol s) (Signature s)) +fromRawStatement (AstStmtRule l x) = + StmtRule <$> fromRawLocation l <*> fromIndirect x fromRawRule +fromRawStatement (AstStmtDefinition l x) = + StmtDefinition <$> fromRawLocation l <*> fromIndirect x fromRawDefinition +fromRawStatement (AstStmtShowSignature l x) = + StmtShowSignature <$> fromRawLocation l + <*> fromIndirect x fromRawShowSignature +fromRawStatement (AstStmtShowTerm l x) = + StmtShowTerm <$> fromRawLocation l <*> fromIndirect x fromRawShowTerm +fromRawStatement (AstStmtMinimize l x) = + StmtMinimize <$> fromRawLocation l <*> fromIndirect x fromRawMinimize +fromRawStatement (AstStmtScript l x) = + StmtScript <$> fromRawLocation l <*> fromIndirect x fromRawScript +fromRawStatement (AstStmtProgram l x) = + StmtProgram <$> fromRawLocation l <*> fromIndirect x fromRawProgram +fromRawStatement (AstStmtExternal l x) = + StmtExternal <$> fromRawLocation l <*> fromIndirect x fromRawExternal +fromRawStatement (AstStmtEdge l x) = + StmtEdge <$> fromRawLocation l <*> fromIndirect x fromRawEdge +fromRawStatement (AstStmtHeuristic l x) = + StmtHeuristic <$> fromRawLocation l <*> fromIndirect x fromRawHeuristic +fromRawStatement (AstStmtProject l x) = + StmtProject <$> fromRawLocation l <*> fromIndirect x fromRawProject +fromRawStatement (AstStmtSignature l x) = + StmtSignature <$> fromRawLocation l <*> pureSignature x +fromRawStatement (AstStmtTheoryDefn l x) = + StmtTheoryDefinition <$> fromRawLocation l + <*> fromIndirect x fromRawTheoryDefinition diff --git a/src/Clingo/Internal/Configuration.hs b/src/Clingo/Internal/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Configuration.hs @@ -0,0 +1,125 @@ +-- | A module providing direct, but memory managed access to the Clingo +-- configuration interface. The preferred way to interface with configuration is +-- found in 'Clingo.Configuration'. This interface exists solely for users who +-- want to provide their own abstraction, without having to reimplement memory +-- management for the raw versions in 'Clingo.Raw.Configuration' +module Clingo.Internal.Configuration +( + Configuration, + ConfigurationType (..), + CKey, + configurationRoot, + configurationType, + configurationDescription, + + -- ** Array Access + configurationArraySize, + configurationArrayAt, + + -- ** Map Access + configurationMapSize, + configurationMapSubkeyName, + configurationMapAt, + + -- ** Value Access + configurationValueGet, + configurationValueIsAssigned, + configurationValueSet +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch +import Numeric.Natural +import Data.Word +import Data.Bits +import Data.Text (Text, pack, unpack) + +import Foreign +import Foreign.C + +import qualified Clingo.Raw as Raw +import Clingo.Internal.Types +import Clingo.Internal.Utils + +newtype CKey = CKey Word32 + deriving (Show, Eq, Ord) + +configurationRoot :: (MonadIO m, MonadThrow m) + => Configuration s -> m CKey +configurationRoot (Configuration c) = + CKey . fromIntegral <$> marshall1 (Raw.configurationRoot c) + +data ConfigurationType = CType + { hasValue :: Bool + , hasArray :: Bool + , hasMap :: Bool } + deriving (Show, Eq, Read, Ord) + +fromRawConfigurationType :: Raw.ConfigurationType -> ConfigurationType +fromRawConfigurationType t = CType v a m + where v = toBool $ t .&. Raw.ConfigValue + a = toBool $ t .&. Raw.ConfigArray + m = toBool $ t .&. Raw.ConfigMap + +configurationType :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> m ConfigurationType +configurationType (Configuration s) (CKey k) = + fromRawConfigurationType <$> + marshall1 (Raw.configurationType s (fromIntegral k)) + +configurationArraySize :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> m Natural +configurationArraySize (Configuration s) (CKey k) = + fromIntegral <$> marshall1 (Raw.configurationArraySize s (fromIntegral k)) + +configurationArrayAt :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> Natural -> m CKey +configurationArrayAt (Configuration s) (CKey k) offset = + CKey . fromIntegral <$> marshall1 + (Raw.configurationArrayAt s (fromIntegral k) (fromIntegral offset)) + +configurationMapSize :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> m Natural +configurationMapSize (Configuration s) (CKey k) = + fromIntegral <$> marshall1 (Raw.configurationMapSize s (fromIntegral k)) + +configurationMapSubkeyName :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> Natural -> m Text +configurationMapSubkeyName (Configuration s) (CKey k) offset = do + cstr <- marshall1 (Raw.configurationMapSubkeyName s (fromIntegral k) + (fromIntegral offset)) + pack <$> liftIO (peekCString cstr) + +configurationMapAt :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> Text -> m CKey +configurationMapAt (Configuration s) (CKey k) name = + CKey . fromIntegral <$> marshall1 go + where go = withCString (unpack name) . + flip (Raw.configurationMapAt s (fromIntegral k)) + +configurationValueGet :: (MonadIO m) + => Configuration s -> CKey -> m Text +configurationValueGet (Configuration s) (CKey k) = liftIO $ do + len <- marshall1 (Raw.configurationValueGetSize s (fromIntegral k)) + allocaArray (fromIntegral len) $ \arr -> do + marshall0 (Raw.configurationValueGet s (fromIntegral k) arr len) + as <- peekArray (fromIntegral len) arr + pure . pack . map castCCharToChar $ as + +configurationDescription :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> m Text +configurationDescription (Configuration c) (CKey k) = do + s <- marshall1 (Raw.configurationDescription c (fromIntegral k)) + pack <$> liftIO (peekCString s) + +configurationValueIsAssigned :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> m Bool +configurationValueIsAssigned (Configuration c) (CKey k) = + toBool <$> marshall1 (Raw.configurationValueIsAssigned c (fromIntegral k)) + +configurationValueSet :: (MonadIO m, MonadThrow m) + => Configuration s -> CKey -> Text -> m () +configurationValueSet (Configuration s) (CKey k) v = marshall0 go + where go = withCString (unpack v) $ \str -> + Raw.configurationValueSet s (fromIntegral k) str diff --git a/src/Clingo/Internal/Inspection/Symbolic.hs b/src/Clingo/Internal/Inspection/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Inspection/Symbolic.hs @@ -0,0 +1,102 @@ +-- | Module providing direct access to the C style iterator interface for +-- symbolic atom inspection. A version abstracting this into lists is provided +-- in 'Clingo.Inspection.Symbolic'. This module is exported for users who want +-- to build their own iterator abstraction. +module Clingo.Internal.Inspection.Symbolic +( + SymbolicAtoms, + SIterator, + symbolicAtomsSize, + symbolicAtomsBegin, + symbolicAtomsEnd, + symbolicAtomsNext, + symbolicAtomsIsValid, + symbolicAtomsFind, + symbolicAtomsIteratorEq, + symbolicAtomsSymbol, + symbolicAtomsIsFact, + symbolicAtomsIsExternal, + symbolicAtomsLiteral, + symbolicAtomsSignatures, +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch + +import Numeric.Natural +import Foreign + +import qualified Clingo.Raw as Raw +import Clingo.Internal.Types +import Clingo.Internal.Utils +import Clingo.Internal.Symbol + +newtype SIterator s = SIterator Raw.SymbolicAtomIterator + +symbolicAtomsSize :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> m Natural +symbolicAtomsSize (SymbolicAtoms s) = + fromIntegral <$> marshall1 (Raw.symbolicAtomsSize s) + +symbolicAtomsBegin :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> Maybe (Signature s) -> m (SIterator s) +symbolicAtomsBegin (SymbolicAtoms s) sig = SIterator <$> marshall1 go + where go x = case sig of + Nothing -> Raw.symbolicAtomsBegin s nullPtr x + Just y -> with (rawSignature y) $ \ptr -> + Raw.symbolicAtomsBegin s ptr x + +symbolicAtomsEnd :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> m (SIterator s) +symbolicAtomsEnd (SymbolicAtoms s) = SIterator <$> marshall1 go + where go = Raw.symbolicAtomsEnd s + +symbolicAtomsFind :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> Symbol s -> m (SIterator s) +symbolicAtomsFind (SymbolicAtoms s) sym = SIterator <$> marshall1 + (Raw.symbolicAtomsFind s (rawSymbol sym)) + +symbolicAtomsIteratorEq :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> SIterator s -> SIterator s + -> m Bool +symbolicAtomsIteratorEq (SymbolicAtoms s) (SIterator a) (SIterator b) = + toBool <$> marshall1 (Raw.symbolicAtomsIteratorIsEqualTo s a b) + +symbolicAtomsSymbol :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> SIterator s -> m (Symbol s) +symbolicAtomsSymbol (SymbolicAtoms s) (SIterator i) = + pureSymbol =<< marshall1 (Raw.symbolicAtomsSymbol s i) + +symbolicAtomsIsFact :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> SIterator s -> m Bool +symbolicAtomsIsFact (SymbolicAtoms s) (SIterator i) = + toBool <$> marshall1 (Raw.symbolicAtomsIsFact s i) + +symbolicAtomsIsExternal :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> SIterator s -> m Bool +symbolicAtomsIsExternal (SymbolicAtoms s) (SIterator i) = + toBool <$> marshall1 (Raw.symbolicAtomsIsExternal s i) + +symbolicAtomsLiteral :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> SIterator s -> m (AspifLiteral s) +symbolicAtomsLiteral (SymbolicAtoms s) (SIterator i) = + AspifLiteral <$> marshall1 (Raw.symbolicAtomsLiteral s i) + +symbolicAtomsSignatures :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> m [Signature s] +symbolicAtomsSignatures (SymbolicAtoms s) = do + len <- marshall1 (Raw.symbolicAtomsSignaturesSize s) + liftIO $ allocaArray (fromIntegral len) $ \arr -> do + marshall0 (Raw.symbolicAtomsSignatures s arr len) + mapM pureSignature =<< peekArray (fromIntegral len) arr + +symbolicAtomsNext :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> SIterator s -> m (SIterator s) +symbolicAtomsNext (SymbolicAtoms s) (SIterator i) = SIterator <$> + marshall1 (Raw.symbolicAtomsNext s i) + +symbolicAtomsIsValid :: (MonadIO m, MonadThrow m) + => SymbolicAtoms s -> SIterator s -> m Bool +symbolicAtomsIsValid (SymbolicAtoms s) (SIterator i) = toBool <$> + marshall1 (Raw.symbolicAtomsIsValid s i) diff --git a/src/Clingo/Internal/Inspection/Theory.hs b/src/Clingo/Internal/Inspection/Theory.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Inspection/Theory.hs @@ -0,0 +1,160 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Internal.Inspection.Theory +( + TheoryAtoms, + TermId, + ElementId, + AtomId, + TheoryTermType, + + pattern TheoryTuple, + pattern TheoryList, + pattern TheorySet, + pattern TheoryFunction, + pattern TheoryNumber, + pattern TheorySymbol, + + theoryAtomsSize, + theoryAtomsId, + theoryAtomsTermType, + theoryAtomsTermNumber, + theoryAtomsTermName, + theoryAtomsTermArguments, + theoryAtomsTermToString, + theoryAtomsElementTuple, + theoryAtomsElementCondition, + theoryAtomsElementConditionId, + theoryAtomsElementToString, + theoryAtomsAtomTerm, + theoryAtomsAtomElements, + theoryAtomsAtomHasGuard, + theoryAtomsAtomGuard, + theoryAtomsAtomLiteral, + theoryAtomsAtomToString +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch +import Data.Text (Text, pack) +import Data.Bifunctor + +import Numeric.Natural +import Foreign +import Foreign.C + +import qualified Clingo.Raw as Raw +import Clingo.Internal.Types +import Clingo.Internal.Utils + +newtype TermId = TermId Raw.Identifier +newtype ElementId = ElementId Raw.Identifier +newtype AtomId = AtomId Raw.Identifier + +newtype TheoryTermType = TheoryTermType Raw.TheoryTermType + +pattern TheoryTuple = TheoryTermType Raw.TheoryTuple +pattern TheoryList = TheoryTermType Raw.TheoryList +pattern TheorySet = TheoryTermType Raw.TheorySet +pattern TheoryFunction = TheoryTermType Raw.TheoryFunction +pattern TheoryNumber = TheoryTermType Raw.TheoryNumber +pattern TheorySymbol = TheoryTermType Raw.TheorySymbol + +theoryAtomsTermType :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> TermId -> m TheoryTermType +theoryAtomsTermType (TheoryAtoms h) (TermId k) = TheoryTermType <$> + marshall1 (Raw.theoryAtomsTermType h k) + +theoryAtomsTermNumber :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> TermId -> m Integer +theoryAtomsTermNumber (TheoryAtoms h) (TermId k) = fromIntegral <$> + marshall1 (Raw.theoryAtomsTermNumber h k) + +theoryAtomsTermName :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> TermId -> m Text +theoryAtomsTermName (TheoryAtoms h) (TermId k) = pack <$> + (liftIO . peekCString =<< marshall1 (Raw.theoryAtomsTermName h k)) + +theoryAtomsTermArguments :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> TermId -> m [TermId] +theoryAtomsTermArguments (TheoryAtoms h) (TermId k) = map TermId <$> marshall1A + (Raw.theoryAtomsTermArguments h k) + +theoryAtomsTermToString :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> TermId -> m Text +theoryAtomsTermToString (TheoryAtoms h) (TermId k) = do + len <- marshall1 (Raw.theoryAtomsTermToStringSize h k) + liftIO $ allocaArray (fromIntegral len) $ \arr -> do + marshall0 (Raw.theoryAtomsTermToString h k arr len) + pack <$> peekCStringLen (arr, fromIntegral len) + +theoryAtomsElementTuple :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> ElementId -> m [TermId] +theoryAtomsElementTuple (TheoryAtoms h) (ElementId k) = + map TermId <$> marshall1A (Raw.theoryAtomsElementTuple h k) + +theoryAtomsElementCondition :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> ElementId -> m [AspifLiteral s] +theoryAtomsElementCondition (TheoryAtoms h) (ElementId k) = + map AspifLiteral <$> marshall1A (Raw.theoryAtomsElementCondition h k) + +theoryAtomsElementConditionId :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> ElementId + -> m (AspifLiteral s) +theoryAtomsElementConditionId (TheoryAtoms h) (ElementId k) = AspifLiteral <$> + marshall1 (Raw.theoryAtomsElementConditionId h k) + +theoryAtomsElementToString :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> ElementId -> m Text +theoryAtomsElementToString (TheoryAtoms h) (ElementId k) = do + len <- marshall1 (Raw.theoryAtomsElementToStringSize h k) + liftIO $ allocaArray (fromIntegral len) $ \arr -> do + marshall0 (Raw.theoryAtomsElementToString h k arr len) + pack <$> peekCStringLen (arr, fromIntegral len) + +theoryAtomsSize :: (MonadIO m, MonadThrow m) => TheoryAtoms s -> m Natural +theoryAtomsSize (TheoryAtoms h) = + fromIntegral <$> marshall1 (Raw.theoryAtomsSize h) + +theoryAtomsId :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> Natural -> m (Maybe AtomId) +theoryAtomsId h x = do + lim <- theoryAtomsSize h + return $ if x < lim then Just (AtomId (fromIntegral x)) else Nothing + +theoryAtomsAtomTerm :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> AtomId -> m TermId +theoryAtomsAtomTerm (TheoryAtoms h) (AtomId k) = TermId <$> marshall1 + (Raw.theoryAtomsAtomTerm h k) + +theoryAtomsAtomElements :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> AtomId -> m [ElementId] +theoryAtomsAtomElements (TheoryAtoms h) (AtomId k) = + map ElementId <$> marshall1A (Raw.theoryAtomsAtomElements h k) + +theoryAtomsAtomHasGuard :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> AtomId -> m Bool +theoryAtomsAtomHasGuard (TheoryAtoms h) (AtomId k) = toBool <$> marshall1 + (Raw.theoryAtomsAtomHasGuard h k) + +theoryAtomsAtomGuard :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> AtomId -> m (Text, TermId) +theoryAtomsAtomGuard (TheoryAtoms h) (AtomId k) = bimap pack TermId <$> go + where go = do + (x,y) <- marshall2 $ Raw.theoryAtomsAtomGuard h k + x' <- liftIO $ peekCString x + return (x',y) + +theoryAtomsAtomLiteral :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> AtomId -> m (AspifLiteral s) +theoryAtomsAtomLiteral (TheoryAtoms h) (AtomId k) = AspifLiteral <$> marshall1 + (Raw.theoryAtomsAtomLiteral h k) + +theoryAtomsAtomToString :: (MonadIO m, MonadThrow m) + => TheoryAtoms s -> AtomId -> m Text +theoryAtomsAtomToString (TheoryAtoms h) (AtomId k) = do + len <- marshall1 (Raw.theoryAtomsAtomToStringSize h k) + liftIO $ allocaArray (fromIntegral len) $ \arr -> do + marshall0 (Raw.theoryAtomsAtomToString h k arr len) + pack <$> peekCStringLen (arr, fromIntegral len) diff --git a/src/Clingo/Internal/Propagation.hs b/src/Clingo/Internal/Propagation.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Propagation.hs @@ -0,0 +1,179 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Internal.Propagation +( + Assignment, + Literal, + + -- * Propagation Handles and Types + PropagateInit, + PropagateCtrl, + IOPropagator (..), + PropagationStop (..), + + -- * Truth values + TruthValue, + pattern TruthFree, + pattern TruthFalse, + pattern TruthTrue, + + -- * Assignment + decisionLevel, + hasConflict, + hasLiteral, + levelOf, + decision, + isFixed, + truthValue, + + -- * Clauses + Clause (..), + ClauseType (..), + + -- * Propagation + assignment, + addClause, + addLiteral, + addWatch, + hasWatch, + removeWatch, + propagate, + getThreadId, + + -- * Initialization + initAddWatch, + countThreads, + solverLiteral, + symbolicAtoms, + theoryAtoms +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch + +import Numeric.Natural + +import Foreign + +import qualified Clingo.Raw as Raw +import Clingo.Internal.Utils +import Clingo.Internal.Types + +newtype Assignment s = Assignment Raw.Assignment + +-- | Get the current decision level. +decisionLevel :: (MonadIO m) => Assignment s -> m Natural +decisionLevel (Assignment a) = fromIntegral <$> Raw.assignmentDecisionLevel a + +-- | Determine whether assignment has a conflict. +hasConflict :: (MonadIO m) => Assignment s -> m Bool +hasConflict (Assignment a) = toBool <$> Raw.assignmentHasConflict a + +-- | Determine whether a literal is part of an assignment. +hasLiteral :: (MonadIO m) => Assignment s -> Literal s -> m Bool +hasLiteral (Assignment a) lit = toBool <$> Raw.assignmentHasLiteral a + (rawLiteral lit) + +-- | Find the decision level of a given literal in an assignment. +levelOf :: (MonadIO m, MonadThrow m) => Assignment s -> Literal s -> m Natural +levelOf (Assignment a) lit = fromIntegral <$> marshall1 go + where go = Raw.assignmentLevel a (rawLiteral lit) + +-- | Determine the decision literal given a decision level. +decision :: (MonadIO m, MonadThrow m) + => Assignment s -> Natural -> m (Literal s) +decision (Assignment a) level = Literal <$> marshall1 go + where go = Raw.assignmentDecision a (fromIntegral level) + +-- | Check if a literal has a fixed truth value. +isFixed :: (MonadIO m, MonadThrow m) => Assignment s -> Literal s -> m Bool +isFixed (Assignment a) lit = toBool <$> marshall1 go + where go = Raw.assignmentIsFixed a (rawLiteral lit) + +-- | Obtain the truth value of a literal +truthValue :: (MonadIO m, MonadThrow m) + => Assignment s -> Literal s -> m TruthValue +truthValue (Assignment a) lit = TruthValue <$> marshall1 go + where go = Raw.assignmentTruthValue a (rawLiteral lit) + +data Clause s = Clause [Literal s] ClauseType + deriving (Show) + +data ClauseType = ClauseLearnt + | ClauseVolatile Bool -- ^ Bool determines static + | ClauseStatic + deriving (Eq, Show, Ord) + +rawClauseType :: ClauseType -> Raw.ClauseType +rawClauseType c = case c of + ClauseLearnt -> Raw.ClauseLearnt + ClauseStatic -> Raw.ClauseStatic + ClauseVolatile static -> if static then Raw.ClauseVolatileStatic + else Raw.ClauseVolatile + +data PropagationStop = Continue | Stop + deriving (Eq, Show, Ord, Read, Enum, Bounded) + +pstopFromBool :: Bool -> PropagationStop +pstopFromBool True = Continue +pstopFromBool False = Stop + +addClause :: (MonadIO m, MonadThrow m) + => PropagateCtrl s -> Clause s -> m PropagationStop +addClause (PropagateCtrl c) (Clause ls t) = pstopFromBool . toBool <$> + marshall1 go + where go x = withArrayLen (map rawLiteral ls) $ \len arr -> + Raw.propagateControlAddClause c arr (fromIntegral len) + (rawClauseType t) x + +addLiteral :: (MonadIO m, MonadThrow m) + => PropagateCtrl s -> m (Literal s) +addLiteral (PropagateCtrl c) = Literal <$> marshall1 + (Raw.propagateControlAddLiteral c) + +getThreadId :: MonadIO m => PropagateCtrl s -> m Integer +getThreadId (PropagateCtrl c) = fromIntegral <$> Raw.propagateControlThreadId c + +addWatch :: (MonadIO m, MonadThrow m) => PropagateCtrl s -> Literal s -> m () +addWatch (PropagateCtrl c) lit = + marshall0 (Raw.propagateControlAddWatch c (rawLiteral lit)) + +hasWatch :: (MonadIO m) => PropagateCtrl s -> Literal s -> m Bool +hasWatch (PropagateCtrl c) lit = + toBool <$> Raw.propagateControlHasWatch c (rawLiteral lit) + +removeWatch :: (MonadIO m) => PropagateCtrl s -> Literal s -> m () +removeWatch (PropagateCtrl c) lit = + Raw.propagateControlRemoveWatch c (rawLiteral lit) + +propagate :: (MonadIO m, MonadThrow m) => PropagateCtrl s -> m PropagationStop +propagate (PropagateCtrl c) = pstopFromBool . toBool <$> + marshall1 (Raw.propagateControlPropagate c) + +assignment :: (MonadIO m) => PropagateCtrl s -> m (Assignment s) +assignment (PropagateCtrl c) = Assignment <$> Raw.propagateControlAssignment c + +initAddWatch :: (MonadIO m, MonadThrow m) + => PropagateInit s -> Literal s -> m () +initAddWatch (PropagateInit c) lit = + marshall0 (Raw.propagateInitAddWatch c (rawLiteral lit)) + +countThreads :: MonadIO m => PropagateInit s -> m Integer +countThreads (PropagateInit c) = fromIntegral <$> + Raw.propagateInitNumberOfThreads c + +solverLiteral :: (MonadIO m, MonadThrow m) + => PropagateInit s -> AspifLiteral s -> m (Literal s) +solverLiteral (PropagateInit c) lit = Literal <$> marshall1 + (Raw.propagateInitSolverLiteral c (rawAspifLiteral lit)) + +symbolicAtoms :: (MonadIO m, MonadThrow m) + => PropagateInit s -> m (SymbolicAtoms s) +symbolicAtoms (PropagateInit c) = SymbolicAtoms <$> marshall1 + (Raw.propagateInitSymbolicAtoms c) + +theoryAtoms :: (MonadIO m, MonadThrow m) + => PropagateInit s -> m (TheoryAtoms s) +theoryAtoms (PropagateInit c) = TheoryAtoms <$> marshall1 + (Raw.propagateInitTheoryAtoms c) diff --git a/src/Clingo/Internal/Statistics.hs b/src/Clingo/Internal/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Statistics.hs @@ -0,0 +1,98 @@ +-- | A module providing direct, but memory managed and somewhat safe, access to +-- the Clingo statistics interface. The preferred way to interface with the +-- statistics is the tree based interface in 'Clingo.Statistics'. This interface +-- exists solely for users who want to provide their own abstraction, without +-- having to reimplement memory management for the raw versions in +-- 'Clingo.Raw.Statistics'. +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Internal.Statistics +( + Statistics, + StatisticsType, + pattern StatsEmpty, + pattern StatsValue, + pattern StatsArray, + pattern StatsMap, + SKey, + + statisticsRoot, + statisticsType, + + -- ** Array Access + statisticsArraySize, + statisticsArrayAt, + + -- ** Map Access + statisticsMapSize, + statisticsMapSubkeyName, + statisticsMapAt, + + -- ** Value Access + statisticsValueGet +) +where + +import Control.Monad.Catch +import Control.Monad.IO.Class +import Data.Text (Text, pack, unpack) + +import Numeric.Natural + +import Foreign +import Foreign.C + +import qualified Clingo.Raw as Raw +import Clingo.Internal.Types +import Clingo.Internal.Utils + +newtype SKey = SKey Word64 + deriving (Show, Eq, Ord) + +statisticsRoot :: (MonadIO m, MonadThrow m) => Statistics s -> m SKey +statisticsRoot (Statistics s) = + SKey <$> marshall1 (Raw.statisticsRoot s) + +newtype StatisticsType = StatisticsType Raw.StatisticsType + +pattern StatsEmpty = StatisticsType Raw.StatsEmpty +pattern StatsValue = StatisticsType Raw.StatsValue +pattern StatsArray = StatisticsType Raw.StatsArray +pattern StatsMap = StatisticsType Raw.StatsMap + +statisticsType :: (MonadIO m, MonadThrow m) + => Statistics s -> SKey -> m StatisticsType +statisticsType (Statistics s) (SKey k) = + StatisticsType <$> marshall1 (Raw.statisticsType s k) + +statisticsArraySize :: (MonadIO m, MonadThrow m) + => Statistics s -> SKey -> m Natural +statisticsArraySize (Statistics s) (SKey k) = + fromIntegral <$> marshall1 (Raw.statisticsArraySize s k) + +statisticsArrayAt :: (MonadIO m, MonadThrow m) + => Statistics s -> SKey -> Natural -> m SKey +statisticsArrayAt (Statistics s) (SKey k) offset = + SKey <$> marshall1 (Raw.statisticsArrayAt s k (fromIntegral offset)) + +statisticsMapSize :: (MonadIO m, MonadThrow m) + => Statistics s -> SKey -> m Natural +statisticsMapSize (Statistics s) (SKey k) = + fromIntegral <$> marshall1 (Raw.statisticsMapSize s k) + +statisticsMapSubkeyName :: (MonadIO m, MonadThrow m) + => Statistics s -> SKey -> Natural -> m Text +statisticsMapSubkeyName (Statistics s) (SKey k) offset = do + cstr <- marshall1 (Raw.statisticsMapSubkeyName s k (fromIntegral offset)) + pack <$> liftIO (peekCString cstr) + +statisticsMapAt :: (MonadIO m, MonadThrow m) + => Statistics s -> SKey -> Text -> m SKey +statisticsMapAt (Statistics s) (SKey k) name = + SKey <$> marshall1 go + where go = withCString (unpack name) . flip (Raw.statisticsMapAt s k) + +statisticsValueGet :: (MonadIO m, MonadThrow m) + => Statistics s -> SKey -> m Double +statisticsValueGet (Statistics s) (SKey k) = + realToFrac <$> marshall1 (Raw.statisticsValueGet s k) diff --git a/src/Clingo/Internal/Symbol.hs b/src/Clingo/Internal/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Symbol.hs @@ -0,0 +1,173 @@ +module Clingo.Internal.Symbol +( + pureSymbol, + symbolHash', + symbolNumber', + symbolName', + symbolString', + symbolArguments', + prettySymbol', + + pureSignature, + signatureArity', + signatureHash', + signatureName', + + createSignature', + createNumber', + createSupremum', + createInfimum', + createString', + createFunction', + + MonadSymbol (..), +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch + +import Data.Text (Text, pack, unpack) +import Numeric.Natural +import Foreign.C +import Foreign + +import Clingo.Internal.Types +import Clingo.Internal.Utils +import qualified Clingo.Raw as Raw + +pureSymbol :: (MonadIO m, MonadThrow m) => Raw.Symbol -> m (Symbol s) +pureSymbol s = Symbol + <$> pure s + <*> pure (Raw.symbolType s) + <*> pure (symbolHash' s) + <*> symbolNumber' s + <*> symbolName' s + <*> symbolString' s + <*> symbolArguments' s + <*> prettySymbol' s + +symbolHash' :: Raw.Symbol -> Integer +symbolHash' = fromIntegral . Raw.symbolHash + +symbolNumber' :: (MonadIO m) => Raw.Symbol -> m (Maybe Integer) +symbolNumber' s = case Raw.symbolType s of + Raw.SymNumber -> fmap fromIntegral <$> marshall1RT (Raw.symbolNumber s) + _ -> return Nothing + +symbolName' :: (MonadIO m) => Raw.Symbol -> m (Maybe Text) +symbolName' s = case Raw.symbolType s of + Raw.SymFunction -> do + x <- marshall1RT (Raw.symbolName s) + case x of + Nothing -> return Nothing + Just cstr -> liftIO $ (Just . pack) <$> peekCString cstr + _ -> return Nothing + +symbolString' :: (MonadIO m) => Raw.Symbol -> m (Maybe Text) +symbolString' s = case Raw.symbolType s of + Raw.SymString -> do + x <- marshall1RT (Raw.symbolString s) + case x of + Nothing -> return Nothing + Just cstr -> liftIO $ (Just . pack) <$> peekCString cstr + _ -> return Nothing + +symbolArguments' :: (MonadIO m, MonadThrow m) => Raw.Symbol -> m [Symbol s] +symbolArguments' s = case Raw.symbolType s of + Raw.SymFunction -> mapM pureSymbol =<< marshall1A (Raw.symbolArguments s) + _ -> return [] + +prettySymbol' :: (MonadIO m, MonadThrow m) => Raw.Symbol -> m Text +prettySymbol' s = do + len <- marshall1 (Raw.symbolToStringSize s) + str <- liftIO $ allocaArray (fromIntegral len) $ \ptr -> do + b <- Raw.symbolToString s ptr len + x <- peekCString ptr + checkAndThrow b + return x + return (pack str) + +pureSignature :: MonadIO m => Raw.Signature -> m (Signature s) +pureSignature s = Signature + <$> pure s + <*> pure (signatureArity' s) + <*> signatureName' s + <*> pure (signatureHash' s) + +signatureName' :: MonadIO m => Raw.Signature -> m Text +signatureName' s = liftIO $ + pack <$> (peekCString . Raw.signatureName $ s) + +signatureArity' :: Raw.Signature -> Natural +signatureArity' = fromIntegral . Raw.signatureArity + +signatureHash' :: Raw.Signature -> Integer +signatureHash' = fromIntegral . Raw.symbolHash + +createSignature' :: (MonadIO m, MonadThrow m) + => Text -- ^ Name + -> Natural -- ^ Arity + -> Bool -- ^ Positive + -> m (Signature s) +createSignature' name arity pos = pureSignature =<< marshall1 go + where go x = withCString (unpack name) $ \cstr -> + Raw.signatureCreate cstr (fromIntegral arity) + (fromBool pos) x + +createNumber' :: (MonadIO m, MonadThrow m, Integral a) => a -> m (Symbol s) +createNumber' a = pureSymbol =<< + marshall1V (Raw.symbolCreateNumber (fromIntegral a)) + +createSupremum' :: (MonadIO m, MonadThrow m) => m (Symbol s) +createSupremum' = pureSymbol =<< marshall1V Raw.symbolCreateSupremum + +createInfimum' :: (MonadIO m, MonadThrow m) => m (Symbol s) +createInfimum' = pureSymbol =<< marshall1V Raw.symbolCreateInfimum + +createString' :: (MonadIO m, MonadThrow m) => Text -> m (Symbol s) +createString' str = pureSymbol =<< marshall1 go + where go = withCString (unpack str) . flip Raw.symbolCreateString + +createFunction' :: (MonadIO m, MonadThrow m) + => Text -- ^ Function name + -> [Symbol s] -- ^ Arguments + -> Bool -- ^ Positive sign + -> m (Symbol s) +createFunction' name args pos = pureSymbol =<< marshall1 go + where go x = withCString (unpack name) $ \cstr -> + withArrayLen (map rawSymbol args) $ \len syms -> + Raw.symbolCreateFunction cstr syms + (fromIntegral len) (fromBool pos) x + +class MonadSymbol m where + -- | Create a new signature with the solver, taking a name, an arity and a + -- bool determining the sign. + createSignature :: Text -> Natural -> Bool -> m s (Signature s) + -- | Create a number symbol. + createNumber :: (Integral a) => a -> m s (Symbol s) + -- | Create a supremum symbol, @#sup@. + createSupremum :: m s (Symbol s) + -- | Create a infimum symbol, @#inf@. + createInfimum :: m s (Symbol s) + -- | Construct a symbol representing a string. + createString :: Text -> m s (Symbol s) + -- | Construct a symbol representing a function or tuple from a name, + -- arguments, and whether the sign is positive. + createFunction :: Text -> [Symbol s] -> Bool -> m s (Symbol s) + +instance MonadSymbol IOSym where + createSignature = createSignature' + createNumber = createNumber' + createSupremum = createSupremum' + createInfimum = createInfimum' + createString = createString' + createFunction = createFunction' + +instance MonadSymbol Clingo where + createSignature = createSignature' + createNumber = createNumber' + createSupremum = createSupremum' + createInfimum = createInfimum' + createString = createString' + createFunction = createFunction' diff --git a/src/Clingo/Internal/Types.hs b/src/Clingo/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Types.hs @@ -0,0 +1,416 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Internal.Types +( + IOSym (..), + Clingo (..), + runClingo, + askC, + Signed (..), + Symbol (..), + Signature (..), + SymbolicLiteral (..), + rawSymLit, + Literal (..), + WeightedLiteral (..), + rawWeightedLiteral, + fromRawWeightedLiteral, + ExternalType (..), + rawExtT, + fromRawExtT, + HeuristicType (..), + rawHeuT, + fromRawHeuT, + negateLiteral, + AspifLiteral (..), + Atom (..), + Model (..), + Location (..), + rawLocation, + freeRawLocation, + fromRawLocation, + SolveResult (..), + rawSolveResult, + fromRawSolveResult, + SolveMode (..), + fromRawSolveMode, + pattern SolveModeAsync, + pattern SolveModeYield, + Solver (..), + exhausted, + wrapCBLogger, + Statistics (..), + ProgramBuilder (..), + Configuration (..), + Backend (..), + SymbolicAtoms (..), + TheoryAtoms (..), + TruthValue (..), + pattern TruthFree, + pattern TruthFalse, + pattern TruthTrue, + negateTruth, + IOPropagator (..), + rawPropagator, + PropagateCtrl (..), + PropagateInit (..), + AMVTree (..) +) +where + +import Control.DeepSeq +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Catch +import Data.Text (Text, pack) +import Data.Bits +import Data.Hashable +import Foreign +import Foreign.C +import GHC.Generics +import qualified Clingo.Raw as Raw +import Clingo.Internal.Utils +import Numeric.Natural + +-- | A monad that serves as witness that data registered with a running solver +-- still exists and can be used. +newtype IOSym s a = IOSym { iosym :: IO a } + deriving (Functor, Applicative, Monad, MonadMask, MonadThrow + , MonadCatch, MonadIO, MonadFix, MonadPlus, Alternative ) + +-- | The 'Clingo' monad provides a base monad for computations utilizing the +-- clingo answer set solver. It uses an additional type parameter to ensure that +-- values that are managed by the solver can not leave scope. +newtype Clingo s a = Clingo { clingo :: ReaderT Raw.Control (IOSym s) a } + deriving (Functor, Applicative, Monad, MonadMask, MonadThrow + , MonadCatch, MonadIO, MonadFix, MonadPlus, Alternative) + +-- | Run a clingo computation from an explicit handle. The handle must be +-- cleaned up manually afterwards, or on failure! +runClingo :: Raw.Control -> Clingo s a -> IO a +runClingo ctrl a = iosym (runReaderT (clingo a) ctrl) + +-- | Get the control handle from the 'Clingo' monad. Arbitrarily unsafe things +-- can be done with this! +askC :: Clingo s Raw.Control +askC = Clingo ask + +data Symbol s = Symbol + { rawSymbol :: Raw.Symbol + , symType :: Raw.SymbolType + , symHash :: Integer + , symNum :: Maybe Integer + , symName :: Maybe Text + , symString :: Maybe Text + , symArgs :: [Symbol s] + , symPretty :: Text + } + deriving (Generic) + +instance NFData (Symbol s) + +instance Eq (Symbol s) where + a == b = toBool (Raw.symbolIsEqualTo (rawSymbol a) (rawSymbol b)) + +instance Ord (Symbol s) where + a <= b = toBool (Raw.symbolIsLessThan (rawSymbol a) (rawSymbol b)) + +instance Hashable (Symbol s) where + hashWithSalt s sym = hashWithSalt s (symHash sym) + +class Signed a where + positive :: a -> Bool + positive = not . negative + + negative :: a -> Bool + negative = not . positive + +instance Signed Bool where + positive x = x + +data SymbolicLiteral s + = SLPositive (Symbol s) + | SLNegative (Symbol s) + deriving (Generic, Eq, Ord) + +instance Hashable (SymbolicLiteral s) + +symLitSymbol :: SymbolicLiteral s -> Symbol s +symLitSymbol (SLPositive s) = s +symLitSymbol (SLNegative s) = s + +symLitPositive :: SymbolicLiteral s -> Bool +symLitPositive (SLPositive _) = True +symLitPositive _ = False + +instance Signed (SymbolicLiteral s) where + positive = symLitPositive + +rawSymLit :: SymbolicLiteral s -> Raw.SymbolicLiteral +rawSymLit sl = Raw.SymbolicLiteral + { Raw.slitSymbol = rawSymbol (symLitSymbol sl) + , Raw.slitPositive = fromBool (symLitPositive sl) } + +data Signature s = Signature + { rawSignature :: Raw.Signature + , sigArity :: Natural + , sigName :: Text + , sigHash :: Integer + } + +instance Eq (Signature s) where + a == b = toBool (Raw.signatureIsEqualTo (rawSignature a) (rawSignature b)) + +instance Ord (Signature s) where + a <= b = toBool (Raw.signatureIsLessThan (rawSignature a) (rawSignature b)) + +instance Signed (Signature s) where + positive = toBool . Raw.signatureIsPositive . rawSignature + negative = toBool . Raw.signatureIsNegative . rawSignature + +instance Hashable (Signature s) where + hashWithSalt s sig = hashWithSalt s (sigHash sig) + +newtype Literal s = Literal { rawLiteral :: Raw.Literal } + deriving (Ord, Show, Eq, NFData, Generic) + +instance Hashable (Literal s) + +instance Signed (Literal s) where + positive = (> 0) . rawLiteral + negative = (< 0) . rawLiteral + +data WeightedLiteral s = WeightedLiteral (Literal s) Integer + deriving (Eq, Show, Ord, Generic) + +instance Hashable (WeightedLiteral s) +instance NFData (WeightedLiteral s) + +rawWeightedLiteral :: WeightedLiteral s -> Raw.WeightedLiteral +rawWeightedLiteral (WeightedLiteral l w) = + Raw.WeightedLiteral (rawLiteral l) (fromIntegral w) + +fromRawWeightedLiteral :: Raw.WeightedLiteral -> WeightedLiteral s +fromRawWeightedLiteral (Raw.WeightedLiteral l w) = + WeightedLiteral (Literal l) (fromIntegral w) + +data ExternalType = ExtFree | ExtTrue | ExtFalse | ExtRelease + deriving (Show, Eq, Ord, Enum, Read, Generic) + +instance Hashable ExternalType + +rawExtT :: ExternalType -> Raw.ExternalType +rawExtT ExtFree = Raw.ExternalFree +rawExtT ExtTrue = Raw.ExternalTrue +rawExtT ExtFalse = Raw.ExternalFalse +rawExtT ExtRelease = Raw.ExternalRelease + +fromRawExtT :: Raw.ExternalType -> ExternalType +fromRawExtT Raw.ExternalFree = ExtFree +fromRawExtT Raw.ExternalTrue = ExtTrue +fromRawExtT Raw.ExternalFalse = ExtFalse +fromRawExtT Raw.ExternalRelease = ExtRelease +fromRawExtT _ = error "unknown external_type" + +data HeuristicType = HeuristicLevel | HeuristicSign | HeuristicFactor + | HeuristicInit | HeuristicTrue | HeuristicFalse + deriving (Show, Eq, Ord, Enum, Read, Generic) + +instance Hashable HeuristicType + +rawHeuT :: HeuristicType -> Raw.HeuristicType +rawHeuT HeuristicLevel = Raw.HeuristicLevel +rawHeuT HeuristicSign = Raw.HeuristicSign +rawHeuT HeuristicFactor = Raw.HeuristicFactor +rawHeuT HeuristicInit = Raw.HeuristicInit +rawHeuT HeuristicTrue = Raw.HeuristicTrue +rawHeuT HeuristicFalse = Raw.HeuristicFalse + +fromRawHeuT :: Raw.HeuristicType -> HeuristicType +fromRawHeuT Raw.HeuristicLevel = HeuristicLevel +fromRawHeuT Raw.HeuristicSign = HeuristicSign +fromRawHeuT Raw.HeuristicFactor = HeuristicFactor +fromRawHeuT Raw.HeuristicInit = HeuristicInit +fromRawHeuT Raw.HeuristicTrue = HeuristicTrue +fromRawHeuT Raw.HeuristicFalse = HeuristicFalse +fromRawHeuT _ = error "unknown heuristic_type" + +negateLiteral :: Literal s -> Literal s +negateLiteral (Literal a) = Literal (negate a) + +newtype AspifLiteral s = AspifLiteral { rawAspifLiteral :: Raw.Literal } + deriving (Ord, Show, Eq, NFData, Generic) + +instance Hashable (AspifLiteral s) + +instance Signed (AspifLiteral s) where + positive = (> 0) . rawAspifLiteral + negative = (< 0) . rawAspifLiteral + +newtype Atom s = Atom { rawAtom :: Raw.Atom } + deriving (Show, Ord, Eq, NFData, Generic) + +instance Hashable (Atom s) + +newtype Model s = Model Raw.Model + +data Location = Location + { locBeginFile :: FilePath + , locEndFile :: FilePath + , locBeginLine :: Natural + , locEndLine :: Natural + , locBeginCol :: Natural + , locEndCol :: Natural } + deriving (Eq, Show, Ord) + +rawLocation :: Location -> IO Raw.Location +rawLocation l = Raw.Location + <$> newCString (locBeginFile l) + <*> newCString (locEndFile l) + <*> pure (fromIntegral (locBeginLine l)) + <*> pure (fromIntegral (locEndLine l)) + <*> pure (fromIntegral (locBeginCol l)) + <*> pure (fromIntegral (locEndCol l)) + +freeRawLocation :: Raw.Location -> IO () +freeRawLocation l = do + free (Raw.locBeginFile l) + free (Raw.locEndFile l) + +fromRawLocation :: Raw.Location -> IO Location +fromRawLocation l = Location + <$> peekCString (Raw.locBeginFile l) + <*> peekCString (Raw.locEndFile l) + <*> pure (fromIntegral . Raw.locBeginLine $ l) + <*> pure (fromIntegral . Raw.locEndLine $ l) + <*> pure (fromIntegral . Raw.locBeginCol $ l) + <*> pure (fromIntegral . Raw.locEndCol $ l) + +data SolveResult = Satisfiable Bool | Unsatisfiable Bool | Interrupted + deriving (Eq, Show, Read, Generic) + +instance NFData SolveResult +instance Hashable SolveResult + +exhausted :: SolveResult -> Bool +exhausted (Satisfiable b) = b +exhausted (Unsatisfiable b) = b +exhausted _ = False + +rawSolveResult :: SolveResult -> Raw.SolveResult +rawSolveResult (Satisfiable e) = + Raw.ResultSatisfiable .|. if e then Raw.ResultExhausted else zeroBits +rawSolveResult (Unsatisfiable e) = + Raw.ResultUnsatisfiable .|. if e then Raw.ResultExhausted else zeroBits +rawSolveResult Interrupted = Raw.ResultInterrupted + +fromRawSolveResult :: Raw.SolveResult -> SolveResult +fromRawSolveResult r + | r == Raw.ResultSatisfiable .|. Raw.ResultExhausted = Satisfiable True + | r == Raw.ResultSatisfiable = Satisfiable False + | r == Raw.ResultUnsatisfiable .|. Raw.ResultExhausted = Unsatisfiable True + | r == Raw.ResultUnsatisfiable = Unsatisfiable False + | r == Raw.ResultInterrupted = Interrupted + | otherwise = error "Malformed clingo_solve_result_bitset_t" + +newtype SolveMode = SolveMode { rawSolveMode :: Raw.SolveMode } + deriving (Eq, Show, Read, Ord) + +fromRawSolveMode :: Raw.SolveMode -> SolveMode +fromRawSolveMode = SolveMode + +newtype Solver s = Solver Raw.SolveHandle + +pattern SolveModeAsync = SolveMode Raw.SolveModeAsync +pattern SolveModeYield = SolveMode Raw.SolveModeYield + +wrapCBLogger :: MonadIO m + => (ClingoWarning -> Text -> IO ()) + -> m (FunPtr (Raw.Logger ())) +wrapCBLogger f = liftIO $ Raw.mkCallbackLogger go + where go :: Raw.ClingoWarning -> CString -> Ptr () -> IO () + go w str _ = peekCString str >>= \cstr -> + f (ClingoWarning w) (pack cstr) + +newtype Statistics s = Statistics Raw.Statistics + +newtype ProgramBuilder s = ProgramBuilder Raw.ProgramBuilder + +newtype Configuration s = Configuration Raw.Configuration + +newtype Backend s = Backend Raw.Backend + +newtype SymbolicAtoms s = SymbolicAtoms Raw.SymbolicAtoms + +newtype TheoryAtoms s = TheoryAtoms Raw.TheoryAtoms + +newtype TruthValue = TruthValue { rawTruthValue :: Raw.TruthValue } + deriving (Eq, Show, Ord) + +pattern TruthFree = TruthValue Raw.TruthFree +pattern TruthFalse = TruthValue Raw.TruthFalse +pattern TruthTrue = TruthValue Raw.TruthTrue + +negateTruth :: TruthValue -> TruthValue +negateTruth TruthFree = TruthFree +negateTruth TruthTrue = TruthFalse +negateTruth TruthFalse = TruthTrue +negateTruth _ = error "negateTruth: Invalid TruthValue" + +data IOPropagator s = IOPropagator + { propagatorInit :: Maybe (PropagateInit s -> IO ()) + , propagatorPropagate :: Maybe (PropagateCtrl s -> [Literal s] -> IO ()) + , propagatorUndo :: Maybe (PropagateCtrl s -> [Literal s] -> IO ()) + , propagatorCheck :: Maybe (PropagateCtrl s -> IO ()) + } + +rawPropagator :: MonadIO m => IOPropagator s -> m (Raw.Propagator ()) +rawPropagator p = Raw.Propagator <$> wrapCBInit (propagatorInit p) + <*> wrapCBProp (propagatorPropagate p) + <*> wrapCBUndo (propagatorUndo p) + <*> wrapCBCheck (propagatorCheck p) + +wrapCBInit :: MonadIO m + => Maybe (PropagateInit s -> IO ()) + -> m (FunPtr (Raw.CallbackPropagatorInit ())) +wrapCBInit Nothing = pure nullFunPtr +wrapCBInit (Just f) = liftIO $ Raw.mkCallbackPropagatorInit go + where go :: Raw.PropagateInit -> Ptr () -> IO Raw.CBool + go c _ = reraiseIO $ f (PropagateInit c) + +wrapCBProp :: MonadIO m + => Maybe (PropagateCtrl s -> [Literal s] -> IO ()) + -> m (FunPtr (Raw.CallbackPropagatorPropagate ())) +wrapCBProp Nothing = pure nullFunPtr +wrapCBProp (Just f) = liftIO $ Raw.mkCallbackPropagatorPropagate go + where go :: Raw.PropagateControl -> Ptr Raw.Literal -> CSize -> Ptr () + -> IO Raw.CBool + go c lits len _ = + reraiseIO $ do + ls <- map Literal <$> peekArray (fromIntegral len) lits + f (PropagateCtrl c) ls + +wrapCBUndo :: MonadIO m + => Maybe (PropagateCtrl s -> [Literal s] -> IO ()) + -> m (FunPtr (Raw.CallbackPropagatorUndo ())) +wrapCBUndo = wrapCBProp + +wrapCBCheck :: MonadIO m + => Maybe (PropagateCtrl s -> IO ()) + -> m (FunPtr (Raw.CallbackPropagatorCheck ())) +wrapCBCheck Nothing = pure nullFunPtr +wrapCBCheck (Just f) = liftIO $ Raw.mkCallbackPropagatorCheck go + where go :: Raw.PropagateControl -> Ptr () -> IO Raw.CBool + go c _ = reraiseIO $ f (PropagateCtrl c) + +newtype PropagateCtrl s = PropagateCtrl Raw.PropagateControl + +newtype PropagateInit s = PropagateInit Raw.PropagateInit + +class AMVTree t where + atArray :: Int -> t v -> Maybe (t v) + atMap :: Text -> t v -> Maybe (t v) + value :: t v -> Maybe v diff --git a/src/Clingo/Internal/Utils.hs b/src/Clingo/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Internal/Utils.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE LambdaCase #-} +module Clingo.Internal.Utils +( + ClingoException, + getException, + ClingoWarning (..), + warningString, + + checkAndThrow, + marshall0, + marshall1, + marshall1V, + marshall1A, + marshall1RT, + marshall2, + marshall3V, + reraiseIO +) +where + +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Catch +import Data.Typeable +import Data.Text (Text, pack) + +import Foreign +import Foreign.C + +import qualified Clingo.Raw as Raw + +data ClingoException = ClingoException Raw.ClingoError String + deriving (Show, Typeable) + +instance Exception ClingoException + +newtype ClingoWarning = ClingoWarning Raw.ClingoWarning + deriving (Show, Typeable) + +instance Exception ClingoWarning + +getException :: MonadIO m => m ClingoException +getException = liftIO $ do + code <- Raw.errorCode + estr <- peekCString =<< Raw.errorString code + return $ ClingoException code estr +{-# INLINE getException #-} + +warningString :: MonadIO m => ClingoWarning -> m Text +warningString (ClingoWarning w) = liftIO $ + Raw.warningString w >>= fmap pack . peekCString + +checkAndThrow :: (MonadIO m, MonadThrow m) => Raw.CBool -> m () +checkAndThrow b = unless (toBool b) $ getException >>= throwM +{-# INLINE checkAndThrow #-} + +checkAndThrowRT :: (MonadIO m, MonadThrow m) + => m a -> Raw.CBool -> m (Maybe a) +checkAndThrowRT a b + | toBool b = Just <$> a + | otherwise = do + exc <- getException + case exc of + ClingoException Raw.ErrorRuntime _ -> return Nothing + _ -> throwM exc +{-# INLINE checkAndThrowRT #-} + +marshall0 :: (MonadIO m, MonadThrow m) => IO Raw.CBool -> m () +marshall0 action = liftIO action >>= checkAndThrow +{-# INLINE marshall0 #-} + +marshall1 :: (Storable a, MonadIO m, MonadThrow m) + => (Ptr a -> IO Raw.CBool) -> m a +marshall1 action = do + (res, a) <- liftIO $ alloca $ \ptr -> do + res <- action ptr + a <- peek ptr + return (res, a) + checkAndThrow res + return a +{-# INLINE marshall1 #-} + +marshall1V :: (Storable a, MonadIO m) + => (Ptr a -> IO ()) -> m a +marshall1V action = + liftIO $ alloca $ \ptr -> do + _ <- action ptr + peek ptr +{-# INLINE marshall1V #-} + +marshall1RT :: (Storable a, MonadIO m) + => (Ptr a -> IO Raw.CBool) -> m (Maybe a) +marshall1RT action = + liftIO $ alloca $ \ptr -> do + res <- action ptr + checkAndThrowRT (peek ptr) res +{-# INLINE marshall1RT #-} + +marshall2 :: (Storable a, Storable b, MonadIO m, MonadThrow m) + => (Ptr a -> Ptr b -> IO Raw.CBool) -> m (a,b) +marshall2 action = do + (res, (a,b)) <- liftIO $ alloca $ \ptr1 -> + alloca $ \ptr2 -> do + res <- action ptr1 ptr2 + a <- peek ptr1 + b <- peek ptr2 + return (res, (a,b)) + checkAndThrow res + return (a,b) +{-# INLINE marshall2 #-} + +marshall1A :: (Storable a, MonadIO m, MonadThrow m) + => (Ptr (Ptr a) -> Ptr CSize -> IO Raw.CBool) -> m [a] +marshall1A action = do + (res, as) <- liftIO $ alloca $ \ptr1 -> + alloca $ \ptr2 -> do + res <- action ptr1 ptr2 + len <- peek ptr2 + arrp <- peek ptr1 + arr <- peekArray (fromIntegral len) arrp + return (res, arr) + checkAndThrow res + return as +{-# INLINE marshall1A #-} + +marshall3V :: (Storable a, Storable b, Storable c, MonadIO m) + => (Ptr a -> Ptr b -> Ptr c -> IO ()) -> m (a,b,c) +marshall3V action = do + (a,b,c) <- liftIO $ alloca $ \ptr1 -> + alloca $ \ptr2 -> + alloca $ \ptr3 -> do + _ <- action ptr1 ptr2 ptr3 + a <- peek ptr1 + b <- peek ptr2 + c <- peek ptr3 + return (a,b,c) + return (a,b,c) +{-# INLINE marshall3V #-} + +reraiseIO :: IO a -> IO Raw.CBool +reraiseIO action = catch (action >> return (fromBool True)) $ + \(ClingoException e s) -> do + withCString s $ Raw.setError e + return (fromBool False) +{-# INLINE reraiseIO #-} diff --git a/src/Clingo/Model.hs b/src/Clingo/Model.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Model.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Model +( + Model, + SolveControl, + SymbolicLiteral, + SymbolSelection (..), + + ModelType, + pattern StableModel, + pattern BraveConsequences, + pattern CautiousConsequences, + + selectAll, + selectNone, + + MonadModel (..) +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch +import Data.Foldable +import Foreign + +import Numeric.Natural + +import qualified Clingo.Raw as Raw +import Clingo.Internal.Symbol +import Clingo.Internal.Types +import Clingo.Internal.Utils + +newtype SolveControl s = SolveControl Raw.SolveControl + +newtype ModelType = ModelType Raw.ModelType + +pattern StableModel = ModelType Raw.StableModel +pattern BraveConsequences = ModelType Raw.BraveConsequences +pattern CautiousConsequences = ModelType Raw.CautiousConsequences + +-- | Type for building symbol selections. +data SymbolSelection = SymbolSelection + { selectCSP :: Bool + , selectShown :: Bool + , selectAtoms :: Bool + , selectTerms :: Bool + , selectExtra :: Bool + , useComplement :: Bool } + deriving (Eq, Show, Read, Ord) + +selectAll :: SymbolSelection +selectAll = SymbolSelection True True True True True False + +rawSymbolSelection :: SymbolSelection -> Raw.ShowFlag +rawSymbolSelection s = foldr ((.|.) . fst) zeroBits . filter snd $ + [ (Raw.ShowCSP, selectCSP s) + , (Raw.ShowShown, selectShown s) + , (Raw.ShowAtoms, selectAtoms s) + , (Raw.ShowTerms, selectTerms s) + , (Raw.ShowExtra, selectExtra s) + , (Raw.ShowComplement, useComplement s) ] + +selectNone :: SymbolSelection +selectNone = SymbolSelection False False False False False False + +class MonadSymbol m => MonadModel m where + -- | Get the type of a Model. + modelType :: Model s -> m s ModelType + -- | Get the number of a Model. + modelNumber :: Model s -> m s Natural + -- | Get the selected symbols from a Model. + modelSymbols :: Model s -> SymbolSelection -> m s [Symbol s] + -- | Constant time lookup to test whether an atom is in a model. + contains :: Model s -> Symbol s -> m s Bool + -- | Get the cost vector of a Model + costVector :: Model s -> m s [Integer] + -- | Check whether optimality of a model has been proven. + optimalityProven :: Model s -> m s Bool + -- | Get the associated 'SolveControl' of a Model. + context :: Model s -> m s (SolveControl s) + -- | Add a clause from the model callback. + modelAddClause :: Foldable t + => SolveControl s -> t (SymbolicLiteral s) -> m s () + +instance MonadModel IOSym where + modelType = modelType' + modelNumber = modelNumber' + modelSymbols = modelSymbols' + contains = contains' + costVector = costVector' + optimalityProven = optimalityProven' + context = context' + modelAddClause = modelAddClause' + +instance MonadModel Clingo where + modelType = modelType' + modelNumber = modelNumber' + modelSymbols = modelSymbols' + contains = contains' + costVector = costVector' + optimalityProven = optimalityProven' + context = context' + modelAddClause = modelAddClause' + +modelType' :: (MonadIO m, MonadThrow m) => Model s -> m ModelType +modelType' (Model m) = ModelType <$> marshall1 (Raw.modelType m) + +modelNumber' :: (MonadIO m, MonadThrow m) => Model s -> m Natural +modelNumber' (Model m) = fromIntegral <$> marshall1 (Raw.modelNumber m) + +modelSymbols' :: (MonadIO m) => Model s -> SymbolSelection -> m [Symbol s] +modelSymbols' (Model m) selection = liftIO $ do + let flags = rawSymbolSelection selection + len <- marshall1 (Raw.modelSymbolsSize m flags) + allocaArray (fromIntegral len) $ \arr -> do + marshall0 (Raw.modelSymbols m flags arr len) + as <- peekArray (fromIntegral len) arr + mapM pureSymbol as + +contains' :: (MonadIO m, MonadThrow m) => Model s -> Symbol s -> m Bool +contains' (Model m) s = toBool <$> marshall1 (Raw.modelContains m (rawSymbol s)) + +costVector' :: (MonadIO m) => Model s -> m [Integer] +costVector' (Model m) = liftIO $ do + len <- marshall1 (Raw.modelCostSize m) + allocaArray (fromIntegral len) $ \arr -> do + marshall0 (Raw.modelCost m arr len) + as <- peekArray (fromIntegral len) arr + return $ fmap fromIntegral as + +optimalityProven' :: (MonadIO m, MonadThrow m) => Model s -> m Bool +optimalityProven' (Model m) = toBool <$> marshall1 (Raw.modelOptimalityProven m) + +context' :: (MonadIO m, MonadThrow m) => Model s -> m (SolveControl s) +context' (Model m) = SolveControl <$> marshall1 (Raw.modelContext m) + +modelAddClause' :: (MonadIO m, MonadThrow m, Foldable t) + => SolveControl s -> t (SymbolicLiteral s) -> m () +modelAddClause' (SolveControl s) lits = marshall0 $ + withArrayLen (map rawSymLit . toList $ lits) $ \len arr -> + Raw.solveControlAddClause s arr (fromIntegral len) diff --git a/src/Clingo/ProgramBuilding.hs b/src/Clingo/ProgramBuilding.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/ProgramBuilding.hs @@ -0,0 +1,171 @@ +-- | A module providing program building capabilities for both ground and +-- non-ground programs. +{-# LANGUAGE RankNTypes #-} +module Clingo.ProgramBuilding +( + Backend, + ProgramBuilder, + Node (..), + Literal, + Atom, + ExternalType (..), + HeuristicType (..), + + assume, + + -- * Ground Programs + GroundStatement, + addGroundStatements, + acycEdge, + atom, + atomAspifLiteral, + negateAspifLiteral, + external, + heuristic, + minimize, + rule, + weightedRule, + project, + + -- * Non-Ground Programs + -- + -- | See 'Clingo.AST' for the abstract syntax tree to build 'Statement's. + addStatements +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch +import Data.Foldable + +import Foreign +import Numeric.Natural + +import qualified Clingo.Raw as Raw + +import Clingo.AST (Statement) +import Clingo.Internal.AST (rawStatement, freeStatement) +import Clingo.Internal.Types +import Clingo.Internal.Utils + +newtype Node = Node { unNode :: Int } + + +-- | A 'GroundStatement' is a statement built from ground atoms. Because the +-- atoms are only valid within the context of clingo, they may not leave this +-- context. They can be added to the current program using the +-- 'addGroundStatements' function. +newtype GroundStatement s = + GStmt { addGStmt :: forall m. (MonadIO m, MonadThrow m) + => Backend s -> m () } + +-- | Build an edge directive. +acycEdge :: Foldable t + => Node -> Node -> t (Literal s) -> GroundStatement s +acycEdge a b lits = GStmt $ \(Backend h) -> marshall0 $ + withArrayLen (map rawLiteral . toList $ lits) $ \len arr -> + Raw.backendAcycEdge h (fromIntegral $ unNode a) + (fromIntegral $ unNode b) arr (fromIntegral len) + +-- | Obtain a fresh atom to be used in aspif directives. +atom :: (MonadIO m, MonadThrow m) + => Backend s -> m (Atom s) +atom (Backend h) = Atom <$> marshall1 (Raw.backendAddAtom h) + +-- | Use an Atom as a positive AspifLiteral +atomAspifLiteral :: Atom s -> AspifLiteral s +atomAspifLiteral (Atom x) = AspifLiteral (fromIntegral x) + +negateAspifLiteral :: AspifLiteral s -> AspifLiteral s +negateAspifLiteral (AspifLiteral x) = AspifLiteral (negate x) + +-- | Add an assumption directive. +assume :: Foldable t + => t (AspifLiteral s) -> GroundStatement s +assume lits = GStmt $ \(Backend h) -> marshall0 $ + withArrayLen (map rawAspifLiteral . toList $ lits) $ \len arr -> + Raw.backendAssume h arr (fromIntegral len) + +-- | Build an external statement. +external :: Atom s -> ExternalType -> GroundStatement s +external a t = GStmt $ \(Backend h) -> marshall0 $ + Raw.backendExternal h (rawAtom a) (rawExtT t) + +-- | Build a heuristic directive. +heuristic :: (Foldable t) + => Atom s + -> HeuristicType + -> Int -- ^ Bias + -> Natural -- ^ Priority + -> t (AspifLiteral s) -- ^ Condition + -> GroundStatement s +heuristic a t bias pri cs = GStmt $ \(Backend h) -> marshall0 $ + withArrayLen (map rawAspifLiteral . toList $ cs) $ \len arr -> + Raw.backendHeuristic h (rawAtom a) (rawHeuT t) + (fromIntegral bias) (fromIntegral pri) arr (fromIntegral len) + +-- | Build a minimize constraint (or weak constraint). +minimize :: Foldable t + => Integer -- ^ Priority + -> t (WeightedLiteral s) -- ^ Literals to minimize + -> GroundStatement s +minimize priority lits = GStmt $ \(Backend h) -> marshall0 $ + withArrayLen (map rawWeightedLiteral . toList $ lits) $ \len arr -> + Raw.backendMinimize h (fromIntegral priority) arr (fromIntegral len) + +-- | Build a rule. +rule :: Foldable t + => Bool -- ^ Is a choice rule? + -> t (Atom s) -- ^ Head + -> t (AspifLiteral s) -- ^ Body + -> GroundStatement s +rule choice hd bd = GStmt $ \(Backend h) -> marshall0 $ + withArrayLen (map rawAtom . toList $ hd) $ \hlen harr -> + withArrayLen (map rawAspifLiteral . toList $ bd) $ \blen barr -> + Raw.backendRule h (fromBool choice) harr (fromIntegral hlen) + barr (fromIntegral blen) + +-- | Build a weighted rule. +weightedRule :: Foldable t + => Bool -- ^ Is a choice rule? + -> t (Atom s) -- ^ Head + -> Natural -- ^ Lower Bound + -> t (WeightedLiteral s) -- ^ Body + -> GroundStatement s +weightedRule choice hd weight bd = GStmt $ \(Backend h) -> marshall0 $ + withArrayLen (map rawAtom . toList $ hd) $ \hlen harr -> + withArrayLen (map rawWeightedLiteral . toList $ bd) $ \blen barr -> + Raw.backendWeightRule h (fromBool choice) harr (fromIntegral hlen) + (fromIntegral weight) + barr (fromIntegral blen) + +-- | Build a projection directive +project :: Foldable t + => t (Atom s) -> GroundStatement s +project atoms = GStmt $ \(Backend h) -> marshall0 $ + withArrayLen (map rawAtom . toList $ atoms) $ \len arr -> + Raw.backendProject h arr (fromIntegral len) + +-- | Add a collection of 'GroundStatement' to the program via a 'Backend' +-- handle. +addGroundStatements :: Foldable t + => Backend s + -> t (GroundStatement s) + -> Clingo s () +addGroundStatements b xs = mapM_ (`addGStmt` b) (toList xs) + +-- | Add a collection of non-ground statements to the solver. +addStatements :: Traversable t + => ProgramBuilder s + -> t (Statement (Symbol s) (Signature s)) + -> Clingo s () +addStatements (ProgramBuilder b) stmts = do + marshall0 (Raw.programBuilderBegin b) + mapM_ go stmts `finally` marshall0 (Raw.programBuilderEnd b) + + where go stmt = do + stmt' <- liftIO (rawStatement stmt) + marshall0 $ + with stmt' $ \ptr -> + Raw.programBuilderAdd b ptr + liftIO (freeStatement stmt') diff --git a/src/Clingo/Propagation.hs b/src/Clingo/Propagation.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Propagation.hs @@ -0,0 +1,248 @@ +-- | High level API for writing propagators. +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE PatternSynonyms #-} +module Clingo.Propagation +( + Propagation, + PropagationPhase (..), + Assignment, + Literal, + Signed (..), + negateLiteral, + + -- | A propagator is defined by four functions. The first is executed during + -- the initialization phase. The remaining three are called during solving, + -- depending on how the propagator is initialized. + -- + -- + -- Initialization: This function is called once before each solving step. + -- It is used to map relevant program literals to solver literals, add + -- watches for solver literals, and initialize the data structures used + -- during propagation. This is the last point to access symbolic and theory + -- atoms. Once the search has started, they are no longer accessible. + -- + -- Propagation: Can be used to add conflicts in order to propagate solver + -- literals. + -- + -- Undo: Is called on backjumping and can be used to synchronize internal + -- data structures of the propagator. + -- + -- Check: Can be used to check whether an assignment is valid. + Propagator (..), + emptyPropagator, + propagatorToIO, + + addWatch, + + -- * Initialization + countThreads, + solverLiteral, + propSymbolicAtoms, + propTheoryAtoms, + + -- * Actions During Solving + P.Clause (..), + P.ClauseType (..), + addClause, + propagate, + hasWatch, + removeWatch, + getThreadId, + newLiteral, + assignment, + + -- * Assignment + decisionLevel, + hasConflict, + hasLiteral, + levelOf, + decision, + isFixed, + truthValue, + + -- * Truth Values + TruthValue, + pattern TruthFree, + pattern TruthFalse, + pattern TruthTrue, + negateTruth +) +where + +import Control.Applicative +import Control.Monad.IO.Class +import Control.Monad.Catch +import Control.Monad.Reader +import Control.Monad.Trans.Maybe + +import Numeric.Natural + +import Clingo.Internal.Types +import Clingo.Internal.Symbol +import qualified Clingo.Internal.Propagation as P +import Clingo.Internal.Propagation (Assignment, Clause) + +-- | Propagators can be in one of two phases, initialization and solving. +data PropagationPhase = Init | Solving + +type family PhaseHandle (k :: PropagationPhase) s where + PhaseHandle 'Init s = PropagateInit s + PhaseHandle 'Solving s = PropagateCtrl s + +-- | A concrete monad for propagators, which observes the invariants +-- stipulated by clingo. +newtype Propagation (phase :: PropagationPhase) s a + = Propagation { runPropagator :: MaybeT + (ReaderT (PhaseHandle phase s) IO) a } + deriving ( Functor, Monad, Applicative + , MonadIO, MonadThrow ) + +getIOAction :: Propagation phase s () -> PhaseHandle phase s -> IO () +getIOAction = (void .) . runReaderT . runMaybeT . runPropagator + +instance MonadReader (PropagateInit s) (Propagation 'Init s) where + ask = Propagation ask + local f (Propagation x) = Propagation (local f x) + reader = Propagation . reader + +instance MonadReader (PropagateCtrl s) (Propagation 'Solving s) where + ask = Propagation ask + local f (Propagation x) = Propagation (local f x) + reader = Propagation . reader + +instance MonadSymbol (Propagation phase) where + createSignature = createSignature' + createNumber = createNumber' + createSupremum = createSupremum' + createInfimum = createInfimum' + createString = createString' + createFunction = createFunction' + +handleStop :: P.PropagationStop -> Propagation phase s () +handleStop P.Continue = return () +handleStop P.Stop = Propagation empty + +-- Propagator and wrapping +-- ----------------------- + +-- | A propagator is defined by four functions. No function is mandatory. +data Propagator s = Propagator + { propInit :: Maybe (Propagation 'Init s ()) + , propPropagate :: Maybe ([Literal s] -> Propagation 'Solving s ()) + , propUndo :: Maybe ([Literal s] -> Propagation 'Solving s ()) + , propCheck :: Maybe (Propagation 'Solving s ()) + } + +-- | The empty propagator for convenience. +emptyPropagator :: Propagator s +emptyPropagator = Propagator Nothing Nothing Nothing Nothing + +propagatorToIO :: Propagator s -> IOPropagator s +propagatorToIO prop = IOPropagator + { propagatorInit = getIOAction <$> propInit prop + , propagatorPropagate = runLitSolv <$> propPropagate prop + , propagatorUndo = runLitSolv <$> propUndo prop + , propagatorCheck = getIOAction <$> propCheck prop + } + where runLitSolv = flip . (getIOAction .) + +-- Operations that are always available +-- ------------------------------------ +class CanAddWatch (phase :: PropagationPhase) where + mAddWatch :: Literal s -> Propagation phase s () + +instance CanAddWatch 'Init where + mAddWatch l = ask >>= flip P.initAddWatch l + +instance CanAddWatch 'Solving where + mAddWatch l = ask >>= flip P.addWatch l + +-- | Watches can be added in any phase of the propagation. The propagate and +-- undo functions will only be called on changes to watched literals! +addWatch :: CanAddWatch phase => Literal s -> Propagation phase s () +addWatch = mAddWatch + +-- Actions during initialization +-- ----------------------------- + +-- | Obtain the number of solver threads. +countThreads :: Propagation 'Init s Integer +countThreads = ask >>= P.countThreads + +-- | Convert an 'AspifLiteral' to a solver 'Literal'. +solverLiteral :: AspifLiteral s -> Propagation 'Init s (Literal s) +solverLiteral l = ask >>= flip P.solverLiteral l + +-- | Obtain a handle to the symbolic atoms, see 'Clingo.Inspection.Symbolic' +propSymbolicAtoms :: Propagation 'Init s (SymbolicAtoms s) +propSymbolicAtoms = ask >>= P.symbolicAtoms + +-- | Obtain a handle to the theory atoms, see 'Clingo.Inspection.Theory' +propTheoryAtoms :: Propagation 'Init s (TheoryAtoms s) +propTheoryAtoms = ask >>= P.theoryAtoms + +-- Actions during Solving +-- ---------------------- + +-- | Check whether a 'Literal' is watched. +hasWatch :: Literal s -> Propagation 'Solving s Bool +hasWatch l = ask >>= flip P.hasWatch l + +-- | Stop watching a literal. +removeWatch :: Literal s -> Propagation 'Solving s () +removeWatch l = ask >>= flip P.removeWatch l + +-- | Get the thread id of the calling solver thread. +getThreadId :: Propagation 'Solving s Integer +getThreadId = ask >>= P.getThreadId + +-- | Introduce a new literal to the solver. +newLiteral :: Propagation 'Solving s (Literal s) +newLiteral = ask >>= P.addLiteral + +-- | Add a clause. This call might result in termination of the propagation +-- function, when backjumping is necessary. +addClause :: Clause s -> Propagation 'Solving s () +addClause c = ask >>= flip P.addClause c >>= handleStop + +-- | Propagate implied literals from added clauses. Might result in backjumping +-- and hence termination of the propagation. +propagate :: Propagation 'Solving s () +propagate = ask >>= P.propagate >>= handleStop + +-- | Obtain the current (partial) assignment. +assignment :: Propagation 'Solving s (Assignment s) +assignment = ask >>= P.assignment + +-- | Get the current decision level. +decisionLevel :: Assignment s -> Propagation 'Solving s Natural +decisionLevel = P.decisionLevel + +-- | Determine whether assignment has a conflict. +hasConflict :: Assignment s -> Propagation 'Solving s Bool +hasConflict = P.hasConflict + +-- | Determine whether a literal is part of an assignment. +hasLiteral :: Assignment s -> Literal s -> Propagation 'Solving s Bool +hasLiteral = P.hasLiteral + +-- | Find the decision level of a given literal in an assignment. +levelOf :: Assignment s -> Literal s -> Propagation 'Solving s Natural +levelOf = P.levelOf + +-- | Determine the decision literal given a decision level. +decision :: Assignment s -> Natural -> Propagation 'Solving s (Literal s) +decision = P.decision + +-- | Check if a literal has a fixed truth value. +isFixed :: Assignment s -> Literal s -> Propagation 'Solving s Bool +isFixed = P.isFixed + +-- | Obtain the truth value of a literal +truthValue :: Assignment s -> Literal s -> Propagation 'Solving s TruthValue +truthValue = P.truthValue diff --git a/src/Clingo/Raw.hs b/src/Clingo/Raw.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw.hs @@ -0,0 +1,31 @@ +-- | Raw bindings to the clingo C API. The functions provided here are +-- equivalent to the functions provided by the C API. In almost all cases you +-- want to use the high level bindings instead. The raw modules are exported for +-- users who want to build their own abstraction, or need an unsafe interface +-- for optimization reasons. +-- +-- For documentation, please refer to the C documentation at +-- https://potassco.org/clingo/c-api/current/ +-- +-- When importing both the Raw module and the high level wrappers, please +-- consider using qualified imports, because they share multiple names. +module Clingo.Raw +( + module X +) +where + +import Clingo.Raw.AST as X +import Clingo.Raw.Basic as X +import Clingo.Raw.Configuration as X +import Clingo.Raw.Control as X +import Clingo.Raw.Enums as X +import Clingo.Raw.Inspection.Symbolic as X +import Clingo.Raw.Inspection.Theory as X +import Clingo.Raw.Model as X +import Clingo.Raw.ProgramBuilding as X +import Clingo.Raw.Propagation as X +import Clingo.Raw.Solving as X +import Clingo.Raw.Statistics as X +import Clingo.Raw.Symbol as X +import Clingo.Raw.Types as X diff --git a/src/Clingo/Raw/AST.hsc b/src/Clingo/Raw/AST.hsc new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/AST.hsc @@ -0,0 +1,1462 @@ +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Clingo.Raw.AST +( + -- * Enumerations + AstComparisonOperator, + + pattern AstComparisonOperatorGreaterThan, + pattern AstComparisonOperatorLessThan, + pattern AstComparisonOperatorLessEqual, + pattern AstComparisonOperatorGreaterEqual, + pattern AstComparisonOperatorNotEqual, + pattern AstComparisonOperatorEqual, + + AstSign, + + pattern AstSignNone, + pattern AstSignNegation, + pattern AstSignDoubleNegation, + + AstTermType, + + pattern AstTermTypeSymbol, + pattern AstTermTypeVariable, + pattern AstTermTypeUnaryOperation, + pattern AstTermTypeBinaryOperation, + pattern AstTermTypeInterval, + pattern AstTermTypeFunction, + pattern AstTermTypeExternalFunction, + pattern AstTermTypePool, + + AstUnaryOperator, + + pattern AstUnaryOperatorMinus, + pattern AstUnaryOperatorNegation, + pattern AstUnaryOperatorAbsolute, + + AstBinaryOperator, + + pattern AstBinaryOperatorXor, + pattern AstBinaryOperatorOr, + pattern AstBinaryOperatorAnd, + pattern AstBinaryOperatorPlus, + pattern AstBinaryOperatorMinus, + pattern AstBinaryOperatorMultiplication, + pattern AstBinaryOperatorDivision, + pattern AstBinaryOperatorModulo, + + AstLiteralType, + + pattern AstLiteralTypeBoolean, + pattern AstLiteralTypeSymbolic, + pattern AstLiteralTypeComparison, + pattern AstLiteralTypeCsp, + + AstAggregateFunction, + + pattern AstAggregateFunctionCount, + pattern AstAggregateFunctionSum, + pattern AstAggregateFunctionSump, + pattern AstAggregateFunctionMin, + pattern AstAggregateFunctionMax, + + AstTheoryTermType, + + pattern AstTheoryTermTypeSymbol, + pattern AstTheoryTermTypeVariable, + pattern AstTheoryTermTypeTuple, + pattern AstTheoryTermTypeList, + pattern AstTheoryTermTypeSet, + pattern AstTheoryTermTypeFunction, + pattern AstTheoryTermTypeUnparsedTerm, + + AstHeadLiteralType, + + pattern AstHeadLiteralTypeLiteral, + pattern AstHeadLiteralTypeDisjunction, + pattern AstHeadLiteralTypeAggregate, + pattern AstHeadLiteralTypeHeadAggregate, + pattern AstHeadLiteralTypeTheoryAtom, + + AstBodyLiteralType, + + pattern AstBodyLiteralTypeLiteral, + pattern AstBodyLiteralTypeConditional, + pattern AstBodyLiteralTypeAggregate, + pattern AstBodyLiteralTypeBodyAggregate, + pattern AstBodyLiteralTypeTheoryAtom, + pattern AstBodyLiteralTypeDisjoint, + + AstTheoryOperatorType, + + pattern AstTheoryOperatorTypeUnary, + pattern AstTheoryOperatorTypeBinaryLeft, + pattern AstTheoryOperatorTypeBinaryRight, + + AstTheoryAtomDefType, + + pattern AstTheoryAtomDefinitionTypeHead, + pattern AstTheoryAtomDefinitionTypeBody, + pattern AstTheoryAtomDefinitionTypeAny, + pattern AstTheoryAtomDefinitionTypeDirective, + + AstScriptType, + + pattern AstScriptTypeLua, + pattern AstScriptTypePython, + + AstStatementType, + + pattern AstStatementTypeRule, + pattern AstStatementTypeConst, + pattern AstStatementTypeShowSignature, + pattern AstStatementTypeShowTerm, + pattern AstStatementTypeMinimize, + pattern AstStatementTypeScript, + pattern AstStatementTypeProgram, + pattern AstStatementTypeExternal, + pattern AstStatementTypeEdge, + pattern AstStatementTypeHeuristic, + pattern AstStatementTypeProjectAtom, + pattern AstStatementTypeProjectAtomSignature, + pattern AstStatementTypeTheoryDefinition, + + -- * Syntax Tree Definitions + AstUnaryOperation (..), + AstBinaryOperation (..), + AstInterval (..), + AstFunction (..), + AstPool (..), + AstTerm (..), + AstCspProductTerm (..), + AstCspSumTerm (..), + AstCspGuard (..), + AstCspLiteral (..), + AstId (..), + AstComparison (..), + AstLiteral (..), + AstAggregateGuard (..), + AstConditionalLiteral (..), + AstAggregate (..), + AstBodyAggregateElement (..), + AstBodyAggregate (..), + AstHeadAggregateElement (..), + AstHeadAggregate (..), + AstDisjunction (..), + AstDisjointElement (..), + AstDisjoint (..), + AstTheoryTermArray (..), + AstTheoryFunction (..), + AstTheoryUnparsedTermElement (..), + AstTheoryUnparsedTerm (..), + AstTheoryTerm (..), + AstTheoryAtomElement (..), + AstTheoryGuard (..), + AstTheoryAtom (..), + AstHeadLiteral (..), + AstBodyLiteral (..), + AstTheoryOperatorDefinition (..), + AstTheoryTermDefinition (..), + AstTheoryGuardDefinition (..), + AstTheoryAtomDefinition (..), + AstTheoryDefinition (..), + AstRule (..), + AstDefinition (..), + AstShowSignature (..), + AstShowTerm (..), + AstMinimize (..), + AstScript (..), + AstProgram (..), + AstExternal (..), + AstEdge (..), + AstHeuristic (..), + AstProject (..), + AstStatement (..), + + -- * Functions + CallbackAST, + mkCallbackAst, + parseProgram, +) +where + +import Control.Monad.IO.Class + +import Foreign +import Foreign.C + +import Clingo.Raw.Types + +#include + +type AstComparisonOperator = #type clingo_ast_comparison_operator_t + +pattern AstComparisonOperatorGreaterThan = #{const clingo_ast_comparison_operator_greater_than} +pattern AstComparisonOperatorLessThan = #{const clingo_ast_comparison_operator_less_than} +pattern AstComparisonOperatorLessEqual = #{const clingo_ast_comparison_operator_less_equal} +pattern AstComparisonOperatorGreaterEqual = #{const clingo_ast_comparison_operator_greater_equal} +pattern AstComparisonOperatorNotEqual = #{const clingo_ast_comparison_operator_not_equal} +pattern AstComparisonOperatorEqual = #{const clingo_ast_comparison_operator_equal} + +type AstSign = #type clingo_ast_sign_t + +pattern AstSignNone = #{const clingo_ast_sign_none} +pattern AstSignNegation = #{const clingo_ast_sign_negation} +pattern AstSignDoubleNegation = #{const clingo_ast_sign_double_negation} + +type AstTermType = #type clingo_ast_term_type_t + +pattern AstTermTypeSymbol = #{const clingo_ast_term_type_symbol} +pattern AstTermTypeVariable = #{const clingo_ast_term_type_variable} +pattern AstTermTypeUnaryOperation = #{const clingo_ast_term_type_unary_operation} +pattern AstTermTypeBinaryOperation = #{const clingo_ast_term_type_binary_operation} +pattern AstTermTypeInterval = #{const clingo_ast_term_type_interval} +pattern AstTermTypeFunction = #{const clingo_ast_term_type_function} +pattern AstTermTypeExternalFunction = #{const clingo_ast_term_type_external_function} +pattern AstTermTypePool = #{const clingo_ast_term_type_pool} + +type AstUnaryOperator = #type clingo_ast_unary_operator_t + +pattern AstUnaryOperatorMinus = #{const clingo_ast_unary_operator_minus} +pattern AstUnaryOperatorNegation = #{const clingo_ast_unary_operator_negation} +pattern AstUnaryOperatorAbsolute = #{const clingo_ast_unary_operator_absolute} + +type AstBinaryOperator = #type clingo_ast_binary_operator_t + +pattern AstBinaryOperatorXor = #{const clingo_ast_binary_operator_xor} +pattern AstBinaryOperatorOr = #{const clingo_ast_binary_operator_or} +pattern AstBinaryOperatorAnd = #{const clingo_ast_binary_operator_and} +pattern AstBinaryOperatorPlus = #{const clingo_ast_binary_operator_plus} +pattern AstBinaryOperatorMinus = #{const clingo_ast_binary_operator_minus} +pattern AstBinaryOperatorMultiplication = #{const clingo_ast_binary_operator_multiplication} +pattern AstBinaryOperatorDivision = #{const clingo_ast_binary_operator_division} +pattern AstBinaryOperatorModulo = #{const clingo_ast_binary_operator_modulo} + +type AstLiteralType = #type clingo_ast_literal_type_t + +pattern AstLiteralTypeBoolean = #{const clingo_ast_literal_type_boolean} +pattern AstLiteralTypeSymbolic = #{const clingo_ast_literal_type_symbolic} +pattern AstLiteralTypeComparison = #{const clingo_ast_literal_type_comparison} +pattern AstLiteralTypeCsp = #{const clingo_ast_literal_type_csp} + +type AstAggregateFunction = #type clingo_ast_aggregate_function_t + +pattern AstAggregateFunctionCount = #{const clingo_ast_aggregate_function_count} +pattern AstAggregateFunctionSum = #{const clingo_ast_aggregate_function_sum} +pattern AstAggregateFunctionSump = #{const clingo_ast_aggregate_function_sump} +pattern AstAggregateFunctionMin = #{const clingo_ast_aggregate_function_min} +pattern AstAggregateFunctionMax = #{const clingo_ast_aggregate_function_max} + +type AstTheoryTermType = #type clingo_ast_theory_term_type_t + +pattern AstTheoryTermTypeSymbol = #{const clingo_ast_theory_term_type_symbol} +pattern AstTheoryTermTypeVariable = #{const clingo_ast_theory_term_type_variable} +pattern AstTheoryTermTypeTuple = #{const clingo_ast_theory_term_type_tuple} +pattern AstTheoryTermTypeList = #{const clingo_ast_theory_term_type_list} +pattern AstTheoryTermTypeSet = #{const clingo_ast_theory_term_type_set} +pattern AstTheoryTermTypeFunction = #{const clingo_ast_theory_term_type_function} +pattern AstTheoryTermTypeUnparsedTerm = #{const clingo_ast_theory_term_type_unparsed_term} + +type AstHeadLiteralType = #type clingo_ast_head_literal_type_t + +pattern AstHeadLiteralTypeLiteral = #{const clingo_ast_head_literal_type_literal} +pattern AstHeadLiteralTypeDisjunction = #{const clingo_ast_head_literal_type_disjunction} +pattern AstHeadLiteralTypeAggregate = #{const clingo_ast_head_literal_type_aggregate} +pattern AstHeadLiteralTypeHeadAggregate = #{const clingo_ast_head_literal_type_head_aggregate} +pattern AstHeadLiteralTypeTheoryAtom = #{const clingo_ast_head_literal_type_theory_atom} + +type AstBodyLiteralType = #type clingo_ast_body_literal_type_t + +pattern AstBodyLiteralTypeLiteral = #{const clingo_ast_body_literal_type_literal} +pattern AstBodyLiteralTypeConditional = #{const clingo_ast_body_literal_type_conditional} +pattern AstBodyLiteralTypeAggregate = #{const clingo_ast_body_literal_type_aggregate} +pattern AstBodyLiteralTypeBodyAggregate = #{const clingo_ast_body_literal_type_body_aggregate} +pattern AstBodyLiteralTypeTheoryAtom = #{const clingo_ast_body_literal_type_theory_atom} +pattern AstBodyLiteralTypeDisjoint = #{const clingo_ast_body_literal_type_disjoint} + +type AstTheoryOperatorType = #type clingo_ast_theory_operator_type_t + +pattern AstTheoryOperatorTypeUnary = #{const clingo_ast_theory_operator_type_unary} +pattern AstTheoryOperatorTypeBinaryLeft = #{const clingo_ast_theory_operator_type_binary_left} +pattern AstTheoryOperatorTypeBinaryRight = #{const clingo_ast_theory_operator_type_binary_right} + +type AstTheoryAtomDefType = #type clingo_ast_theory_atom_definition_type_t + +pattern AstTheoryAtomDefinitionTypeHead = #{const clingo_ast_theory_atom_definition_type_head} +pattern AstTheoryAtomDefinitionTypeBody = #{const clingo_ast_theory_atom_definition_type_body} +pattern AstTheoryAtomDefinitionTypeAny = #{const clingo_ast_theory_atom_definition_type_any} +pattern AstTheoryAtomDefinitionTypeDirective = #{const clingo_ast_theory_atom_definition_type_directive} + +type AstScriptType = #type clingo_ast_script_type_t + +pattern AstScriptTypeLua = #{const clingo_ast_script_type_lua} +pattern AstScriptTypePython = #{const clingo_ast_script_type_python} + +type AstStatementType = #type clingo_ast_statement_type_t + +pattern AstStatementTypeRule = #{const clingo_ast_statement_type_rule} +pattern AstStatementTypeConst = #{const clingo_ast_statement_type_const} +pattern AstStatementTypeShowSignature = #{const clingo_ast_statement_type_show_signature} +pattern AstStatementTypeShowTerm = #{const clingo_ast_statement_type_show_term} +pattern AstStatementTypeMinimize = #{const clingo_ast_statement_type_minimize} +pattern AstStatementTypeScript = #{const clingo_ast_statement_type_script} +pattern AstStatementTypeProgram = #{const clingo_ast_statement_type_program} +pattern AstStatementTypeExternal = #{const clingo_ast_statement_type_external} +pattern AstStatementTypeEdge = #{const clingo_ast_statement_type_edge} +pattern AstStatementTypeHeuristic = #{const clingo_ast_statement_type_heuristic} +pattern AstStatementTypeProjectAtom = #{const clingo_ast_statement_type_project_atom} +pattern AstStatementTypeProjectAtomSignature = #{const clingo_ast_statement_type_project_atom_signature} +pattern AstStatementTypeTheoryDefinition = #{const clingo_ast_statement_type_theory_definition} + +type CallbackAST a = Ptr AstStatement -> Ptr a -> IO CBool + +foreign import ccall "wrapper" mkCallbackAst :: + CallbackAST a -> IO (FunPtr (CallbackAST a)) + +data AstUnaryOperation = AstUnaryOperation AstUnaryOperator AstTerm + deriving (Eq, Show) + +instance Storable AstUnaryOperation where + sizeOf _ = #{size clingo_ast_unary_operation_t} + alignment = sizeOf + peek p = AstUnaryOperation + <$> (#{peek clingo_ast_unary_operation_t, unary_operator} p) + <*> (#{peek clingo_ast_unary_operation_t, argument} p) + poke p (AstUnaryOperation a b) = do + (#poke clingo_ast_unary_operation_t, unary_operator) p a + (#poke clingo_ast_unary_operation_t, argument) p b + +data AstBinaryOperation = AstBinaryOperation AstBinaryOperator AstTerm AstTerm + deriving (Eq, Show) + +instance Storable AstBinaryOperation where + sizeOf _ = #{size clingo_ast_binary_operation_t} + alignment = sizeOf + peek p = AstBinaryOperation + <$> (#{peek clingo_ast_binary_operation_t, binary_operator} p) + <*> (#{peek clingo_ast_binary_operation_t, left} p) + <*> (#{peek clingo_ast_binary_operation_t, right} p) + poke p (AstBinaryOperation a b c) = do + (#poke clingo_ast_binary_operation_t, binary_operator) p a + (#poke clingo_ast_binary_operation_t, left) p b + (#poke clingo_ast_binary_operation_t, right) p c + +data AstInterval = AstInterval AstTerm AstTerm + deriving (Eq, Show) + +instance Storable AstInterval where + sizeOf _ = #{size clingo_ast_interval_t} + alignment = sizeOf + peek p = AstInterval + <$> (#{peek clingo_ast_interval_t, left} p) + <*> (#{peek clingo_ast_interval_t, right} p) + poke p (AstInterval a b) = do + (#poke clingo_ast_interval_t, left) p a + (#poke clingo_ast_interval_t, right) p b + +data AstFunction = AstFunction CString (Ptr AstTerm) CSize + deriving (Eq, Show) + +instance Storable AstFunction where + sizeOf _ = #{size clingo_ast_function_t} + alignment = sizeOf + peek p = AstFunction + <$> (#{peek clingo_ast_function_t, name} p) + <*> (#{peek clingo_ast_function_t, arguments} p) + <*> (#{peek clingo_ast_function_t, size} p) + poke p (AstFunction a b c) = do + (#poke clingo_ast_function_t, name) p a + (#poke clingo_ast_function_t, arguments) p b + (#poke clingo_ast_function_t, size) p c + +data AstPool = AstPool (Ptr AstTerm) CSize + deriving (Eq, Show) + +instance Storable AstPool where + sizeOf _ = #{size clingo_ast_pool_t} + alignment = sizeOf + peek p = AstPool + <$> (#{peek clingo_ast_pool_t, arguments} p) + <*> (#{peek clingo_ast_pool_t, size} p) + poke p (AstPool a b) = do + (#poke clingo_ast_pool_t, arguments) p a + (#poke clingo_ast_pool_t, size) p b + +data AstTerm = AstTermSymbol Location Symbol + | AstTermVariable Location CString + | AstTermUOp Location (Ptr AstUnaryOperation) + | AstTermBOp Location (Ptr AstBinaryOperation) + | AstTermInterval Location (Ptr AstInterval) + | AstTermFunction Location (Ptr AstFunction) + | AstTermExtFunction Location (Ptr AstFunction) + | AstTermPool Location (Ptr AstPool) + deriving (Eq, Show) + +instance Storable AstTerm where + sizeOf _ = #{size clingo_ast_term_t} + alignment = sizeOf + peek p = do + loc <- (#{peek clingo_ast_term_t, location} p) + typ :: AstTermType <- (#{peek clingo_ast_term_t, type} p) + case typ of + AstTermTypeSymbol -> do + payload <- (#{peek clingo_ast_term_t, symbol} p) + pure $! AstTermSymbol loc payload + AstTermTypeVariable -> do + payload <- (#{peek clingo_ast_term_t, variable} p) + pure $! AstTermVariable loc payload + AstTermTypeUnaryOperation -> do + payload <- (#{peek clingo_ast_term_t, unary_operation} p) + pure $! AstTermUOp loc payload + AstTermTypeBinaryOperation -> do + payload <- (#{peek clingo_ast_term_t, binary_operation} p) + pure $! AstTermBOp loc payload + AstTermTypeInterval -> do + payload <- (#{peek clingo_ast_term_t, interval} p) + pure $! AstTermInterval loc payload + AstTermTypeFunction -> do + payload <- (#{peek clingo_ast_term_t, function} p) + pure $! AstTermFunction loc payload + AstTermTypeExternalFunction -> do + payload <- (#{peek clingo_ast_term_t, external_function} p) + pure $! AstTermExtFunction loc payload + AstTermTypePool -> do + payload <- (#{peek clingo_ast_term_t, pool} p) + pure $! AstTermPool loc payload + _ -> error "Malformed struct clingo_ast_term_t" + poke p d = case d of + AstTermSymbol l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypeSymbol :: AstTermType) + (#poke clingo_ast_term_t, symbol) p x + AstTermVariable l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypeVariable :: AstTermType) + (#poke clingo_ast_term_t, variable) p x + AstTermUOp l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypeUnaryOperation :: AstTermType) + (#poke clingo_ast_term_t, unary_operation) p x + AstTermBOp l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypeBinaryOperation :: AstTermType) + (#poke clingo_ast_term_t, binary_operation) p x + AstTermInterval l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypeInterval :: AstTermType) + (#poke clingo_ast_term_t, interval) p x + AstTermFunction l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypeFunction :: AstTermType) + (#poke clingo_ast_term_t, function) p x + AstTermExtFunction l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypeExternalFunction :: AstTermType) + (#poke clingo_ast_term_t, external_function) p x + AstTermPool l x -> do + (#poke clingo_ast_term_t, location) p l + (#poke clingo_ast_term_t, type) p (AstTermTypePool :: AstTermType) + (#poke clingo_ast_term_t, pool) p x + +data AstCspProductTerm = AstCspProductTerm Location AstTerm (Ptr AstTerm) + deriving (Eq, Show) + +instance Storable AstCspProductTerm where + sizeOf _ = #{size clingo_ast_csp_product_term_t} + alignment = sizeOf + peek p = AstCspProductTerm + <$> (#{peek clingo_ast_csp_product_term_t, location} p) + <*> (#{peek clingo_ast_csp_product_term_t, coefficient} p) + <*> (#{peek clingo_ast_csp_product_term_t, variable} p) + poke p (AstCspProductTerm a b c) = do + (#poke clingo_ast_csp_product_term_t, location) p a + (#poke clingo_ast_csp_product_term_t, coefficient) p b + (#poke clingo_ast_csp_product_term_t, variable) p c + +data AstCspSumTerm = AstCspSumTerm Location (Ptr AstCspProductTerm) CSize + deriving (Eq, Show) + +instance Storable AstCspSumTerm where + sizeOf _ = #{size clingo_ast_csp_sum_term_t} + alignment = sizeOf + peek p = AstCspSumTerm + <$> (#{peek clingo_ast_csp_sum_term_t, location} p) + <*> (#{peek clingo_ast_csp_sum_term_t, terms} p) + <*> (#{peek clingo_ast_csp_sum_term_t, size} p) + poke p (AstCspSumTerm a b c) = do + (#poke clingo_ast_csp_sum_term_t, location) p a + (#poke clingo_ast_csp_sum_term_t, terms) p b + (#poke clingo_ast_csp_sum_term_t, size) p c + +data AstCspGuard = AstCspGuard AstComparisonOperator AstCspSumTerm + deriving (Eq, Show) + +instance Storable AstCspGuard where + sizeOf _ = #{size clingo_ast_csp_guard_t} + alignment = sizeOf + peek p = AstCspGuard + <$> (#{peek clingo_ast_csp_guard_t, comparison} p) + <*> (#{peek clingo_ast_csp_guard_t, term} p) + poke p (AstCspGuard a b) = do + (#poke clingo_ast_csp_guard_t, comparison) p a + (#poke clingo_ast_csp_guard_t, term) p b + +data AstCspLiteral = AstCspLiteral AstCspSumTerm (Ptr AstCspGuard) CSize + deriving (Eq, Show) + +instance Storable AstCspLiteral where + sizeOf _ = #{size clingo_ast_csp_literal_t} + alignment = sizeOf + peek p = AstCspLiteral + <$> (#{peek clingo_ast_csp_literal_t, term} p) + <*> (#{peek clingo_ast_csp_literal_t, guards} p) + <*> (#{peek clingo_ast_csp_literal_t, size} p) + poke p (AstCspLiteral a b c) = do + (#poke clingo_ast_csp_literal_t, term) p a + (#poke clingo_ast_csp_literal_t, guards) p b + (#poke clingo_ast_csp_literal_t, size) p c + +data AstId = AstId Location CString + deriving (Eq, Show) + +instance Storable AstId where + sizeOf _ = #{size clingo_ast_id_t} + alignment = sizeOf + peek p = AstId + <$> (#{peek clingo_ast_id_t, location} p) + <*> (#{peek clingo_ast_id_t, id} p) + poke p (AstId a b) = do + (#poke clingo_ast_id_t, location) p a + (#poke clingo_ast_id_t, id) p b + +data AstComparison = AstComparison AstComparisonOperator AstTerm AstTerm + deriving (Eq, Show) + +instance Storable AstComparison where + sizeOf _ = #{size clingo_ast_comparison_t} + alignment = sizeOf + peek p = AstComparison + <$> (#{peek clingo_ast_comparison_t, comparison} p) + <*> (#{peek clingo_ast_comparison_t, left} p) + <*> (#{peek clingo_ast_comparison_t, right} p) + poke p (AstComparison a b c) = do + (#poke clingo_ast_comparison_t, comparison) p a + (#poke clingo_ast_comparison_t, left) p b + (#poke clingo_ast_comparison_t, right) p c + +data AstLiteral = AstLiteralBool Location AstSign CBool + | AstLiteralTerm Location AstSign (Ptr AstTerm) + | AstLiteralComp Location AstSign (Ptr AstComparison) + | AstLiteralCSPL Location AstSign (Ptr AstCspLiteral) + deriving (Eq, Show) + +instance Storable AstLiteral where + sizeOf _ = #{size clingo_ast_literal_t} + alignment = sizeOf + peek p = do + loc <- (#{peek clingo_ast_literal_t, location} p) + sign <- (#{peek clingo_ast_literal_t, sign} p) + typ :: AstLiteralType <- (#{peek clingo_ast_literal_t, type} p) + case typ of + AstLiteralTypeBoolean -> do + payload <- (#{peek clingo_ast_literal_t, boolean} p) + pure $! AstLiteralBool loc sign payload + AstLiteralTypeSymbolic -> do + payload <- (#{peek clingo_ast_literal_t, symbol} p) + pure $! AstLiteralTerm loc sign payload + AstLiteralTypeComparison -> do + payload <- (#{peek clingo_ast_literal_t, comparison} p) + pure $! AstLiteralComp loc sign payload + AstLiteralTypeCsp -> do + payload <- (#{peek clingo_ast_literal_t, csp_literal} p) + pure $! AstLiteralCSPL loc sign payload + _ -> error "Malformed struct clingo_ast_literal_t" + poke p d = case d of + AstLiteralBool l s x -> do + (#poke clingo_ast_literal_t, location) p l + (#poke clingo_ast_literal_t, sign) p s + (#poke clingo_ast_literal_t, type) p (AstLiteralTypeBoolean :: AstLiteralType) + (#poke clingo_ast_literal_t, boolean) p x + AstLiteralTerm l s x -> do + (#poke clingo_ast_literal_t, location) p l + (#poke clingo_ast_literal_t, sign) p s + (#poke clingo_ast_literal_t, type) p (AstLiteralTypeSymbolic :: AstLiteralType) + (#poke clingo_ast_literal_t, symbol) p x + AstLiteralComp l s x -> do + (#poke clingo_ast_literal_t, location) p l + (#poke clingo_ast_literal_t, sign) p s + (#poke clingo_ast_literal_t, type) p (AstLiteralTypeComparison:: AstLiteralType) + (#poke clingo_ast_literal_t, comparison) p x + AstLiteralCSPL l s x -> do + (#poke clingo_ast_literal_t, location) p l + (#poke clingo_ast_literal_t, sign) p s + (#poke clingo_ast_literal_t, type) p (AstLiteralTypeCsp :: AstLiteralType) + (#poke clingo_ast_literal_t, csp_literal) p x + +data AstAggregateGuard = AstAggregateGuard AstComparisonOperator AstTerm + deriving (Eq, Show) + +instance Storable AstAggregateGuard where + sizeOf _ = #{size clingo_ast_aggregate_guard_t} + alignment = sizeOf + peek p = AstAggregateGuard + <$> (#{peek clingo_ast_aggregate_guard_t, comparison} p) + <*> (#{peek clingo_ast_aggregate_guard_t, term} p) + poke p (AstAggregateGuard a b) = do + (#poke clingo_ast_aggregate_guard_t, comparison) p a + (#poke clingo_ast_aggregate_guard_t, term) p b + +data AstConditionalLiteral = AstConditionalLiteral AstLiteral + (Ptr AstLiteral) CSize + deriving (Eq, Show) + +instance Storable AstConditionalLiteral where + sizeOf _ = #{size clingo_ast_conditional_literal_t} + alignment = sizeOf + peek p = AstConditionalLiteral + <$> (#{peek clingo_ast_conditional_literal_t, literal} p) + <*> (#{peek clingo_ast_conditional_literal_t, condition} p) + <*> (#{peek clingo_ast_conditional_literal_t, size} p) + poke p (AstConditionalLiteral a b c) = do + (#poke clingo_ast_conditional_literal_t, literal) p a + (#poke clingo_ast_conditional_literal_t, condition) p b + (#poke clingo_ast_conditional_literal_t, size) p c + +data AstAggregate = AstAggregate (Ptr AstConditionalLiteral) CSize + (Ptr AstAggregateGuard) (Ptr AstAggregateGuard) + deriving (Eq, Show) + +instance Storable AstAggregate where + sizeOf _ = #{size clingo_ast_aggregate_t} + alignment = sizeOf + peek p = AstAggregate + <$> (#{peek clingo_ast_aggregate_t, elements} p) + <*> (#{peek clingo_ast_aggregate_t, size} p) + <*> (#{peek clingo_ast_aggregate_t, left_guard} p) + <*> (#{peek clingo_ast_aggregate_t, right_guard} p) + poke p (AstAggregate a b c d) = do + (#poke clingo_ast_aggregate_t, elements) p a + (#poke clingo_ast_aggregate_t, size) p b + (#poke clingo_ast_aggregate_t, left_guard) p c + (#poke clingo_ast_aggregate_t, right_guard) p d + +data AstBodyAggregateElement = AstBodyAggregateElement (Ptr AstTerm) CSize + (Ptr AstLiteral) CSize + deriving (Eq, Show) + +instance Storable AstBodyAggregateElement where + sizeOf _ = #{size clingo_ast_body_aggregate_element_t} + alignment = sizeOf + peek p = AstBodyAggregateElement + <$> (#{peek clingo_ast_body_aggregate_element_t, tuple} p) + <*> (#{peek clingo_ast_body_aggregate_element_t, tuple_size} p) + <*> (#{peek clingo_ast_body_aggregate_element_t, condition} p) + <*> (#{peek clingo_ast_body_aggregate_element_t, condition_size} p) + poke p (AstBodyAggregateElement a b c d) = do + (#poke clingo_ast_body_aggregate_element_t, tuple) p a + (#poke clingo_ast_body_aggregate_element_t, tuple_size) p b + (#poke clingo_ast_body_aggregate_element_t, condition) p c + (#poke clingo_ast_body_aggregate_element_t, condition_size) p d + +data AstBodyAggregate = AstBodyAggregate AstAggregateFunction + (Ptr AstBodyAggregateElement) CSize + (Ptr AstAggregateGuard) (Ptr AstAggregateGuard) + deriving (Eq, Show) + +instance Storable AstBodyAggregate where + sizeOf _ = #{size clingo_ast_body_aggregate_t} + alignment = sizeOf + peek p = AstBodyAggregate + <$> (#{peek clingo_ast_body_aggregate_t, function} p) + <*> (#{peek clingo_ast_body_aggregate_t, elements} p) + <*> (#{peek clingo_ast_body_aggregate_t, size} p) + <*> (#{peek clingo_ast_body_aggregate_t, left_guard} p) + <*> (#{peek clingo_ast_body_aggregate_t, right_guard} p) + poke p (AstBodyAggregate a b c d e) = do + (#poke clingo_ast_body_aggregate_t, function) p a + (#poke clingo_ast_body_aggregate_t, elements) p b + (#poke clingo_ast_body_aggregate_t, size) p c + (#poke clingo_ast_body_aggregate_t, left_guard) p d + (#poke clingo_ast_body_aggregate_t, right_guard) p e + +data AstHeadAggregateElement = AstHeadAggregateElement (Ptr AstTerm) CSize + AstConditionalLiteral + deriving (Eq, Show) + +instance Storable AstHeadAggregateElement where + sizeOf _ = #{size clingo_ast_head_aggregate_element_t} + alignment = sizeOf + peek p = AstHeadAggregateElement + <$> (#{peek clingo_ast_head_aggregate_element_t, tuple} p) + <*> (#{peek clingo_ast_head_aggregate_element_t, tuple_size} p) + <*> (#{peek clingo_ast_head_aggregate_element_t, conditional_literal} p) + poke p (AstHeadAggregateElement a b c) = do + (#poke clingo_ast_head_aggregate_element_t, tuple) p a + (#poke clingo_ast_head_aggregate_element_t, tuple_size) p b + (#poke clingo_ast_head_aggregate_element_t, conditional_literal) p c + +data AstHeadAggregate = AstHeadAggregate AstAggregateFunction + (Ptr AstHeadAggregateElement) CSize + (Ptr AstAggregateGuard) (Ptr AstAggregateGuard) + deriving (Eq, Show) + +instance Storable AstHeadAggregate where + sizeOf _ = #{size clingo_ast_aggregate_t} + alignment = sizeOf + peek p = AstHeadAggregate + <$> (#{peek clingo_ast_head_aggregate_t, function} p) + <*> (#{peek clingo_ast_head_aggregate_t, elements} p) + <*> (#{peek clingo_ast_head_aggregate_t, size} p) + <*> (#{peek clingo_ast_head_aggregate_t, left_guard} p) + <*> (#{peek clingo_ast_head_aggregate_t, right_guard} p) + poke p (AstHeadAggregate a b c d e) = do + (#poke clingo_ast_head_aggregate_t, function) p a + (#poke clingo_ast_head_aggregate_t, elements) p b + (#poke clingo_ast_head_aggregate_t, size) p c + (#poke clingo_ast_head_aggregate_t, left_guard) p d + (#poke clingo_ast_head_aggregate_t, right_guard) p e + +data AstDisjunction = AstDisjunction (Ptr AstConditionalLiteral) CSize + deriving (Eq, Show) + +instance Storable AstDisjunction where + sizeOf _ = #{size clingo_ast_disjunction_t} + alignment = sizeOf + peek p = AstDisjunction + <$> (#{peek clingo_ast_disjunction_t, elements} p) + <*> (#{peek clingo_ast_disjunction_t, size} p) + poke p (AstDisjunction a b) = do + (#poke clingo_ast_disjunction_t, elements) p a + (#poke clingo_ast_disjunction_t, size) p b + +data AstDisjointElement = AstDisjointElement Location (Ptr AstTerm) CSize + AstCspSumTerm (Ptr AstLiteral) CSize + deriving (Eq, Show) + +instance Storable AstDisjointElement where + sizeOf _ = #{size clingo_ast_disjoint_element_t} + alignment = sizeOf + peek p = AstDisjointElement + <$> (#{peek clingo_ast_disjoint_element_t, location} p) + <*> (#{peek clingo_ast_disjoint_element_t, tuple} p) + <*> (#{peek clingo_ast_disjoint_element_t, tuple_size} p) + <*> (#{peek clingo_ast_disjoint_element_t, term} p) + <*> (#{peek clingo_ast_disjoint_element_t, condition} p) + <*> (#{peek clingo_ast_disjoint_element_t, condition_size} p) + poke p (AstDisjointElement a b c d e f) = do + (#poke clingo_ast_disjoint_element_t, location) p a + (#poke clingo_ast_disjoint_element_t, tuple) p b + (#poke clingo_ast_disjoint_element_t, tuple_size) p c + (#poke clingo_ast_disjoint_element_t, term) p d + (#poke clingo_ast_disjoint_element_t, condition) p e + (#poke clingo_ast_disjoint_element_t, condition_size) p f + +data AstDisjoint = AstDisjoint (Ptr AstDisjointElement) CSize + deriving (Eq, Show) + +instance Storable AstDisjoint where + sizeOf _ = #{size clingo_ast_disjoint_t} + alignment = sizeOf + peek p = AstDisjoint + <$> (#{peek clingo_ast_disjoint_t, elements} p) + <*> (#{peek clingo_ast_disjoint_t, size} p) + poke p (AstDisjoint a b) = do + (#poke clingo_ast_disjoint_t, elements) p a + (#poke clingo_ast_disjoint_t, size) p b + +data AstTheoryTermArray = AstTheoryTermArray (Ptr AstTheoryTerm) CSize + deriving (Eq, Show) + +instance Storable AstTheoryTermArray where + sizeOf _ = #{size clingo_ast_theory_term_array_t} + alignment = sizeOf + peek p = AstTheoryTermArray + <$> (#{peek clingo_ast_theory_term_array_t, terms} p) + <*> (#{peek clingo_ast_theory_term_array_t, size} p) + poke p (AstTheoryTermArray a b) = do + (#poke clingo_ast_theory_term_array_t, terms) p a + (#poke clingo_ast_theory_term_array_t, size) p b + +data AstTheoryFunction = AstTheoryFunction CString (Ptr AstTheoryTerm) CSize + deriving (Eq, Show) + +instance Storable AstTheoryFunction where + sizeOf _ = #{size clingo_ast_theory_function_t} + alignment = sizeOf + peek p = AstTheoryFunction + <$> (#{peek clingo_ast_theory_function_t, name} p) + <*> (#{peek clingo_ast_theory_function_t, arguments} p) + <*> (#{peek clingo_ast_theory_function_t, size} p) + poke p (AstTheoryFunction a b c) = do + (#poke clingo_ast_theory_function_t, name) p a + (#poke clingo_ast_theory_function_t, arguments) p b + (#poke clingo_ast_theory_function_t, size) p c + +data AstTheoryUnparsedTermElement = AstTheoryUnparsedTermElement + (Ptr CString) CSize AstTheoryTerm + deriving (Eq, Show) + +instance Storable AstTheoryUnparsedTermElement where + sizeOf _ = #{size clingo_ast_theory_unparsed_term_element_t} + alignment = sizeOf + peek p = AstTheoryUnparsedTermElement + <$> (#{peek clingo_ast_theory_unparsed_term_element_t, operators} p) + <*> (#{peek clingo_ast_theory_unparsed_term_element_t, size} p) + <*> (#{peek clingo_ast_theory_unparsed_term_element_t, term} p) + poke p (AstTheoryUnparsedTermElement a b c) = do + (#poke clingo_ast_theory_unparsed_term_element_t, operators) p a + (#poke clingo_ast_theory_unparsed_term_element_t, size) p b + (#poke clingo_ast_theory_unparsed_term_element_t, term) p c + +data AstTheoryUnparsedTerm = AstTheoryUnparsedTerm + (Ptr AstTheoryUnparsedTermElement) CSize + deriving (Eq, Show) + +instance Storable AstTheoryUnparsedTerm where + sizeOf _ = #{size clingo_ast_theory_unparsed_term_t} + alignment = sizeOf + peek p = AstTheoryUnparsedTerm + <$> (#{peek clingo_ast_theory_unparsed_term_t, elements} p) + <*> (#{peek clingo_ast_theory_unparsed_term_t, size} p) + poke p (AstTheoryUnparsedTerm a b) = do + (#poke clingo_ast_theory_unparsed_term_t, elements) p a + (#poke clingo_ast_theory_unparsed_term_t, size) p b + +data AstTheoryTerm = AstTheoryTermSymbol Location Symbol + | AstTheoryTermVariable Location CString + | AstTheoryTermTuple Location (Ptr AstTheoryTermArray) + | AstTheoryTermList Location (Ptr AstTheoryTermArray) + | AstTheoryTermSet Location (Ptr AstTheoryTermArray) + | AstTheoryTermFunction Location (Ptr AstTheoryFunction) + | AstTheoryTermUnparsed Location (Ptr AstTheoryUnparsedTerm) + deriving (Eq, Show) + +instance Storable AstTheoryTerm where + sizeOf _ = #{size clingo_ast_theory_term_t} + alignment = sizeOf + peek p = do + loc <- (#{peek clingo_ast_theory_term_t, location} p) + typ :: AstTheoryTermType <- (#{peek clingo_ast_theory_term_t, type} p) + case typ of + AstTheoryTermTypeSymbol -> do + payload <- (#{peek clingo_ast_theory_term_t, symbol} p) + pure $! AstTheoryTermSymbol loc payload + AstTheoryTermTypeVariable -> do + payload <- (#{peek clingo_ast_theory_term_t, variable} p) + pure $! AstTheoryTermVariable loc payload + AstTheoryTermTypeTuple -> do + payload <- (#{peek clingo_ast_theory_term_t, tuple} p) + pure $! AstTheoryTermTuple loc payload + AstTheoryTermTypeList -> do + payload <- (#{peek clingo_ast_theory_term_t, list} p) + pure $! AstTheoryTermList loc payload + AstTheoryTermTypeSet -> do + payload <- (#{peek clingo_ast_theory_term_t, set} p) + pure $! AstTheoryTermSet loc payload + AstTheoryTermTypeFunction -> do + payload <- (#{peek clingo_ast_theory_term_t, function} p) + pure $! AstTheoryTermFunction loc payload + AstTheoryTermTypeUnparsedTerm -> do + payload <- (#{peek clingo_ast_theory_term_t, unparsed_term} p) + pure $! AstTheoryTermUnparsed loc payload + _ -> error "Malformed struct clingo_ast_theory_term_t" + poke p d = case d of + AstTheoryTermSymbol l x -> do + (#poke clingo_ast_theory_term_t, location) p l + (#poke clingo_ast_theory_term_t, type) p (AstTheoryTermTypeSymbol :: AstTheoryTermType) + (#poke clingo_ast_theory_term_t, symbol) p x + AstTheoryTermVariable l x -> do + (#poke clingo_ast_theory_term_t, location) p l + (#poke clingo_ast_theory_term_t, type) p (AstTheoryTermTypeVariable :: AstTheoryTermType) + (#poke clingo_ast_theory_term_t, variable) p x + AstTheoryTermTuple l x -> do + (#poke clingo_ast_theory_term_t, location) p l + (#poke clingo_ast_theory_term_t, type) p (AstTheoryTermTypeTuple :: AstTheoryTermType) + (#poke clingo_ast_theory_term_t, tuple) p x + AstTheoryTermList l x -> do + (#poke clingo_ast_theory_term_t, location) p l + (#poke clingo_ast_theory_term_t, type) p (AstTheoryTermTypeList :: AstTheoryTermType) + (#poke clingo_ast_theory_term_t, list) p x + AstTheoryTermSet l x -> do + (#poke clingo_ast_theory_term_t, location) p l + (#poke clingo_ast_theory_term_t, type) p (AstTheoryTermTypeSet :: AstTheoryTermType) + (#poke clingo_ast_theory_term_t, set) p x + AstTheoryTermFunction l x -> do + (#poke clingo_ast_theory_term_t, location) p l + (#poke clingo_ast_theory_term_t, type) p (AstTheoryTermTypeFunction :: AstTheoryTermType) + (#poke clingo_ast_theory_term_t, function) p x + AstTheoryTermUnparsed l x -> do + (#poke clingo_ast_theory_term_t, location) p l + (#poke clingo_ast_theory_term_t, type) p (AstTheoryTermTypeUnparsedTerm :: AstTheoryTermType) + (#poke clingo_ast_theory_term_t, unparsed_term) p x + +data AstTheoryAtomElement = AstTheoryAtomElement (Ptr AstTheoryTerm) CSize + (Ptr AstLiteral) CSize + deriving (Eq, Show) + +instance Storable AstTheoryAtomElement where + sizeOf _ = #{size clingo_ast_theory_atom_element_t} + alignment = sizeOf + peek p = AstTheoryAtomElement + <$> (#{peek clingo_ast_theory_atom_element_t, tuple} p) + <*> (#{peek clingo_ast_theory_atom_element_t, tuple_size} p) + <*> (#{peek clingo_ast_theory_atom_element_t, condition} p) + <*> (#{peek clingo_ast_theory_atom_element_t, condition_size} p) + poke p (AstTheoryAtomElement a b c d) = do + (#poke clingo_ast_theory_atom_element_t, tuple) p a + (#poke clingo_ast_theory_atom_element_t, tuple_size) p b + (#poke clingo_ast_theory_atom_element_t, condition) p c + (#poke clingo_ast_theory_atom_element_t, condition_size) p d + +data AstTheoryGuard = AstTheoryGuard CString AstTheoryTerm + deriving (Eq, Show) + +instance Storable AstTheoryGuard where + sizeOf _ = #{size clingo_ast_theory_guard_t} + alignment = sizeOf + peek p = AstTheoryGuard + <$> (#{peek clingo_ast_theory_guard_t, operator_name} p) + <*> (#{peek clingo_ast_theory_guard_t, term} p) + poke p (AstTheoryGuard a b) = do + (#poke clingo_ast_theory_guard_t, operator_name) p a + (#poke clingo_ast_theory_guard_t, term) p b + +data AstTheoryAtom = AstTheoryAtom AstTerm (Ptr AstTheoryAtomElement) CSize + AstTheoryGuard + deriving (Eq, Show) + +instance Storable AstTheoryAtom where + sizeOf _ = #{size clingo_ast_theory_atom_t} + alignment = sizeOf + peek p = AstTheoryAtom + <$> (#{peek clingo_ast_theory_atom_t, term} p) + <*> (#{peek clingo_ast_theory_atom_t, elements} p) + <*> (#{peek clingo_ast_theory_atom_t, size} p) + <*> (#{peek clingo_ast_theory_atom_t, guard} p) + poke p (AstTheoryAtom a b c d) = do + (#poke clingo_ast_theory_atom_t, term) p a + (#poke clingo_ast_theory_atom_t, elements) p b + (#poke clingo_ast_theory_atom_t, size) p c + (#poke clingo_ast_theory_atom_t, guard) p d + +data AstHeadLiteral = AstHeadLiteral Location (Ptr AstLiteral) + | AstHeadDisjunction Location (Ptr AstDisjunction) + | AstHeadLitAggregate Location (Ptr AstAggregate) + | AstHeadHeadAggregate Location (Ptr AstHeadAggregate) + | AstHeadTheoryAtom Location (Ptr AstTheoryAtom) + deriving (Eq, Show) + +instance Storable AstHeadLiteral where + sizeOf _ = #{size clingo_ast_head_literal_t} + alignment = sizeOf + peek p = do + loc <- (#{peek clingo_ast_head_literal_t, location} p) + typ :: AstHeadLiteralType <- (#{peek clingo_ast_head_literal_t, type} p) + case typ of + AstHeadLiteralTypeLiteral -> do + payload <- (#{peek clingo_ast_head_literal_t, literal} p) + pure $! AstHeadLiteral loc payload + AstHeadLiteralTypeDisjunction -> do + payload <- (#{peek clingo_ast_head_literal_t, disjunction} p) + pure $! AstHeadDisjunction loc payload + AstHeadLiteralTypeAggregate -> do + payload <- (#{peek clingo_ast_head_literal_t, aggregate} p) + pure $! AstHeadLitAggregate loc payload + AstHeadLiteralTypeHeadAggregate -> do + payload <- (#{peek clingo_ast_head_literal_t, head_aggregate} p) + pure $! AstHeadHeadAggregate loc payload + AstHeadLiteralTypeTheoryAtom -> do + payload <- (#{peek clingo_ast_head_literal_t, theory_atom} p) + pure $! AstHeadTheoryAtom loc payload + _ -> error "Malformed struct clingo_ast_head_literal_t" + poke p d = case d of + AstHeadLiteral l x -> do + (#{poke clingo_ast_head_literal_t, location}) p l + (#{poke clingo_ast_head_literal_t, type}) p (AstHeadLiteralTypeLiteral :: AstHeadLiteralType) + (#{poke clingo_ast_head_literal_t, literal}) p x + AstHeadDisjunction l x -> do + (#{poke clingo_ast_head_literal_t, location}) p l + (#{poke clingo_ast_head_literal_t, type}) p (AstHeadLiteralTypeDisjunction :: AstHeadLiteralType) + (#{poke clingo_ast_head_literal_t, disjunction}) p x + AstHeadLitAggregate l x -> do + (#{poke clingo_ast_head_literal_t, location}) p l + (#{poke clingo_ast_head_literal_t, type}) p (AstHeadLiteralTypeAggregate :: AstHeadLiteralType) + (#{poke clingo_ast_head_literal_t, aggregate}) p x + AstHeadHeadAggregate l x -> do + (#{poke clingo_ast_head_literal_t, location}) p l + (#{poke clingo_ast_head_literal_t, type}) p (AstHeadLiteralTypeHeadAggregate :: AstHeadLiteralType) + (#{poke clingo_ast_head_literal_t, head_aggregate}) p x + AstHeadTheoryAtom l x -> do + (#{poke clingo_ast_head_literal_t, location}) p l + (#{poke clingo_ast_head_literal_t, type}) p (AstHeadLiteralTypeTheoryAtom :: AstHeadLiteralType) + (#{poke clingo_ast_head_literal_t, theory_atom}) p x + +data AstBodyLiteral + = AstBodyLiteral Location AstSign (Ptr AstLiteral) + | AstBodyConditional Location (Ptr AstConditionalLiteral) + | AstBodyLitAggregate Location AstSign (Ptr AstAggregate) + | AstBodyBodyAggregate Location AstSign (Ptr AstBodyAggregate) + | AstBodyTheoryAtom Location AstSign (Ptr AstTheoryAtom) + | AstBodyDisjoint Location AstSign (Ptr AstDisjoint) + deriving (Eq, Show) + +instance Storable AstBodyLiteral where + sizeOf _ = #{size clingo_ast_body_literal_t} + alignment = sizeOf + peek p = do + loc <- (#{peek clingo_ast_body_literal_t, location} p) + sign <- (#{peek clingo_ast_body_literal_t, sign} p) + typ :: AstBodyLiteralType <- (#{peek clingo_ast_body_literal_t, type} p) + case typ of + AstBodyLiteralTypeLiteral -> do + payload <- (#{peek clingo_ast_body_literal_t, literal} p) + pure $! AstBodyLiteral loc sign payload + AstBodyLiteralTypeConditional -> do + payload <- (#{peek clingo_ast_body_literal_t, conditional} p) + pure $! AstBodyConditional loc payload + AstBodyLiteralTypeAggregate -> do + payload <- (#{peek clingo_ast_body_literal_t, aggregate} p) + pure $! AstBodyLitAggregate loc sign payload + AstBodyLiteralTypeBodyAggregate -> do + payload <- (#{peek clingo_ast_body_literal_t, body_aggregate} p) + pure $! AstBodyBodyAggregate loc sign payload + AstBodyLiteralTypeTheoryAtom -> do + payload <- (#{peek clingo_ast_body_literal_t, theory_atom} p) + pure $! AstBodyTheoryAtom loc sign payload + AstBodyLiteralTypeDisjoint -> do + payload <- (#{peek clingo_ast_body_literal_t, disjoint} p) + pure $! AstBodyDisjoint loc sign payload + _ -> error "Malformed struct clingo_ast_body_literal_t" + poke p d = case d of + AstBodyLiteral l s x -> do + (#poke clingo_ast_body_literal_t, location) p l + (#poke clingo_ast_body_literal_t, sign) p s + (#poke clingo_ast_body_literal_t, type) p (AstBodyLiteralTypeLiteral :: AstBodyLiteralType) + (#poke clingo_ast_body_literal_t, literal) p x + AstBodyConditional l x -> do + (#poke clingo_ast_body_literal_t, location) p l + (#poke clingo_ast_body_literal_t, type) p (AstBodyLiteralTypeConditional :: AstBodyLiteralType) + (#poke clingo_ast_body_literal_t, conditional) p x + AstBodyLitAggregate l s x -> do + (#poke clingo_ast_body_literal_t, location) p l + (#poke clingo_ast_body_literal_t, sign) p s + (#poke clingo_ast_body_literal_t, type) p (AstBodyLiteralTypeAggregate :: AstBodyLiteralType) + (#poke clingo_ast_body_literal_t, aggregate) p x + AstBodyBodyAggregate l s x -> do + (#poke clingo_ast_body_literal_t, location) p l + (#poke clingo_ast_body_literal_t, sign) p s + (#poke clingo_ast_body_literal_t, type) p (AstBodyLiteralTypeBodyAggregate :: AstBodyLiteralType) + (#poke clingo_ast_body_literal_t, body_aggregate) p x + AstBodyTheoryAtom l s x -> do + (#poke clingo_ast_body_literal_t, location) p l + (#poke clingo_ast_body_literal_t, sign) p s + (#poke clingo_ast_body_literal_t, type) p (AstBodyLiteralTypeTheoryAtom :: AstBodyLiteralType) + (#poke clingo_ast_body_literal_t, theory_atom) p x + AstBodyDisjoint l s x -> do + (#poke clingo_ast_body_literal_t, location) p l + (#poke clingo_ast_body_literal_t, sign) p s + (#poke clingo_ast_body_literal_t, type) p (AstBodyLiteralTypeDisjoint :: AstBodyLiteralType) + (#poke clingo_ast_body_literal_t, disjoint) p x + +data AstTheoryOperatorDefinition = AstTheoryOperatorDefinition Location + CString CUInt AstTheoryOperatorType + deriving (Eq, Show) + +instance Storable AstTheoryOperatorDefinition where + sizeOf _ = #{size clingo_ast_theory_operator_definition_t} + alignment = sizeOf + peek p = AstTheoryOperatorDefinition + <$> (#{peek clingo_ast_theory_operator_definition_t, location} p) + <*> (#{peek clingo_ast_theory_operator_definition_t, name} p) + <*> (#{peek clingo_ast_theory_operator_definition_t, priority} p) + <*> (#{peek clingo_ast_theory_operator_definition_t, type} p) + poke p (AstTheoryOperatorDefinition a b c d) = do + (#poke clingo_ast_theory_operator_definition_t, location) p a + (#poke clingo_ast_theory_operator_definition_t, name) p b + (#poke clingo_ast_theory_operator_definition_t, priority) p c + (#poke clingo_ast_theory_operator_definition_t, type) p d + +data AstTheoryTermDefinition = AstTheoryTermDefinition Location CString + (Ptr AstTheoryOperatorDefinition) CSize + deriving (Eq, Show) + +instance Storable AstTheoryTermDefinition where + sizeOf _ = #{size clingo_ast_theory_term_definition_t} + alignment = sizeOf + peek p = AstTheoryTermDefinition + <$> (#{peek clingo_ast_theory_term_definition_t, location} p) + <*> (#{peek clingo_ast_theory_term_definition_t, name} p) + <*> (#{peek clingo_ast_theory_term_definition_t, operators} p) + <*> (#{peek clingo_ast_theory_term_definition_t, size} p) + poke p (AstTheoryTermDefinition a b c d) = do + (#poke clingo_ast_theory_term_definition_t, location) p a + (#poke clingo_ast_theory_term_definition_t, name) p b + (#poke clingo_ast_theory_term_definition_t, operators) p c + (#poke clingo_ast_theory_term_definition_t, size) p d + +data AstTheoryGuardDefinition = AstTheoryGuardDefinition CString (Ptr CString) + CSize + deriving (Eq, Show) + +instance Storable AstTheoryGuardDefinition where + sizeOf _ = #{size clingo_ast_theory_guard_definition_t} + alignment = sizeOf + peek p = AstTheoryGuardDefinition + <$> (#{peek clingo_ast_theory_guard_definition_t, term} p) + <*> (#{peek clingo_ast_theory_guard_definition_t, operators} p) + <*> (#{peek clingo_ast_theory_guard_definition_t, size} p) + poke p (AstTheoryGuardDefinition a b c) = do + (#poke clingo_ast_theory_guard_definition_t, term) p a + (#poke clingo_ast_theory_guard_definition_t, operators) p b + (#poke clingo_ast_theory_guard_definition_t, size) p c + +data AstTheoryAtomDefinition = AstTheoryAtomDefinition Location + AstTheoryAtomDefType CString CUInt CString + (Ptr AstTheoryGuardDefinition) + deriving (Eq, Show) + +instance Storable AstTheoryAtomDefinition where + sizeOf _ = #{size clingo_ast_theory_atom_definition_t} + alignment = sizeOf + peek p = AstTheoryAtomDefinition + <$> (#{peek clingo_ast_theory_atom_definition_t, location} p) + <*> (#{peek clingo_ast_theory_atom_definition_t, type} p) + <*> (#{peek clingo_ast_theory_atom_definition_t, name} p) + <*> (#{peek clingo_ast_theory_atom_definition_t, arity} p) + <*> (#{peek clingo_ast_theory_atom_definition_t, elements} p) + <*> (#{peek clingo_ast_theory_atom_definition_t, guard} p) + poke p (AstTheoryAtomDefinition a b c d e f) = do + (#poke clingo_ast_theory_atom_definition_t, location) p a + (#poke clingo_ast_theory_atom_definition_t, type) p b + (#poke clingo_ast_theory_atom_definition_t, name) p c + (#poke clingo_ast_theory_atom_definition_t, arity) p d + (#poke clingo_ast_theory_atom_definition_t, elements) p e + (#poke clingo_ast_theory_atom_definition_t, guard) p f + +data AstTheoryDefinition = AstTheoryDefinition CString + (Ptr AstTheoryTermDefinition) CSize + (Ptr AstTheoryAtomDefinition) CSize + deriving (Eq, Show) + +instance Storable AstTheoryDefinition where + sizeOf _ = #{size clingo_ast_theory_definition_t} + alignment = sizeOf + peek p = AstTheoryDefinition + <$> (#{peek clingo_ast_theory_definition_t, name} p) + <*> (#{peek clingo_ast_theory_definition_t, terms} p) + <*> (#{peek clingo_ast_theory_definition_t, terms_size} p) + <*> (#{peek clingo_ast_theory_definition_t, atoms} p) + <*> (#{peek clingo_ast_theory_definition_t, atoms_size} p) + poke p (AstTheoryDefinition a b c d e) = do + (#poke clingo_ast_theory_definition_t, name) p a + (#poke clingo_ast_theory_definition_t, terms) p b + (#poke clingo_ast_theory_definition_t, terms_size) p c + (#poke clingo_ast_theory_definition_t, atoms) p d + (#poke clingo_ast_theory_definition_t, atoms_size) p e + +data AstRule = AstRule AstHeadLiteral (Ptr AstBodyLiteral) CSize + deriving (Eq, Show) + +instance Storable AstRule where + sizeOf _ = #{size clingo_ast_rule_t} + alignment = sizeOf + peek p = AstRule + <$> (#{peek clingo_ast_rule_t, head} p) + <*> (#{peek clingo_ast_rule_t, body} p) + <*> (#{peek clingo_ast_rule_t, size} p) + poke p (AstRule a b c) = do + (#poke clingo_ast_rule_t, head) p a + (#poke clingo_ast_rule_t, body) p b + (#poke clingo_ast_rule_t, size) p c + +data AstDefinition = AstDefinition CString AstTerm CBool + deriving (Eq, Show) + +instance Storable AstDefinition where + sizeOf _ = #{size clingo_ast_definition_t} + alignment = sizeOf + peek p = AstDefinition + <$> (#{peek clingo_ast_definition_t, name} p) + <*> (#{peek clingo_ast_definition_t, value} p) + <*> (#{peek clingo_ast_definition_t, is_default} p) + poke p (AstDefinition a b c) = do + (#poke clingo_ast_definition_t, name) p a + (#poke clingo_ast_definition_t, value) p b + (#poke clingo_ast_definition_t, is_default) p c + +data AstShowSignature = AstShowSignature Signature CBool + deriving (Eq, Show) + +instance Storable AstShowSignature where + sizeOf _ = #{size clingo_ast_show_signature_t} + alignment = sizeOf + peek p = AstShowSignature + <$> (#{peek clingo_ast_show_signature_t, signature} p) + <*> (#{peek clingo_ast_show_signature_t, csp} p) + poke p (AstShowSignature a b) = do + (#poke clingo_ast_show_signature_t, signature) p a + (#poke clingo_ast_show_signature_t, csp) p b + +data AstShowTerm = AstShowTerm AstTerm (Ptr AstBodyLiteral) CSize CBool + deriving (Eq, Show) + +instance Storable AstShowTerm where + sizeOf _ = #{size clingo_ast_show_term_t} + alignment = sizeOf + peek p = AstShowTerm + <$> (#{peek clingo_ast_show_term_t, term} p) + <*> (#{peek clingo_ast_show_term_t, body} p) + <*> (#{peek clingo_ast_show_term_t, size} p) + <*> (#{peek clingo_ast_show_term_t, csp} p) + poke p (AstShowTerm a b c d) = do + (#poke clingo_ast_show_term_t, term) p a + (#poke clingo_ast_show_term_t, body) p b + (#poke clingo_ast_show_term_t, size) p c + (#poke clingo_ast_show_term_t, csp) p d + +data AstMinimize = AstMinimize AstTerm AstTerm (Ptr AstTerm) CSize + (Ptr AstBodyLiteral) CSize + deriving (Eq, Show) + +instance Storable AstMinimize where + sizeOf _ = #{size clingo_ast_minimize_t} + alignment = sizeOf + peek p = AstMinimize + <$> (#{peek clingo_ast_minimize_t, weight} p) + <*> (#{peek clingo_ast_minimize_t, priority} p) + <*> (#{peek clingo_ast_minimize_t, tuple} p) + <*> (#{peek clingo_ast_minimize_t, tuple_size} p) + <*> (#{peek clingo_ast_minimize_t, body} p) + <*> (#{peek clingo_ast_minimize_t, body_size} p) + poke p (AstMinimize a b c d e f) = do + (#poke clingo_ast_minimize_t, weight) p a + (#poke clingo_ast_minimize_t, priority) p b + (#poke clingo_ast_minimize_t, tuple) p c + (#poke clingo_ast_minimize_t, tuple_size) p d + (#poke clingo_ast_minimize_t, body) p e + (#poke clingo_ast_minimize_t, body_size) p f + +data AstScript = AstScript AstScriptType CString + deriving (Eq, Show) + +instance Storable AstScript where + sizeOf _ = #{size clingo_ast_script_t} + alignment = sizeOf + peek p = AstScript + <$> (#{peek clingo_ast_script_t, type} p) + <*> (#{peek clingo_ast_script_t, code} p) + poke p (AstScript a b) = do + (#poke clingo_ast_script_t, type) p a + (#poke clingo_ast_script_t, code) p b + +data AstProgram = AstProgram CString (Ptr AstId) CSize + deriving (Eq, Show) + +instance Storable AstProgram where + sizeOf _ = #{size clingo_ast_program_t} + alignment = sizeOf + peek p = AstProgram + <$> (#{peek clingo_ast_program_t, name} p) + <*> (#{peek clingo_ast_program_t, parameters} p) + <*> (#{peek clingo_ast_program_t, size} p) + poke p (AstProgram a b c) = do + (#poke clingo_ast_program_t, name) p a + (#poke clingo_ast_program_t, parameters) p b + (#poke clingo_ast_program_t, size) p c + +data AstExternal = AstExternal AstTerm (Ptr AstBodyLiteral) CSize + deriving (Eq, Show) + +instance Storable AstExternal where + sizeOf _ = #{size clingo_ast_external_t} + alignment = sizeOf + peek p = AstExternal + <$> (#{peek clingo_ast_external_t, atom} p) + <*> (#{peek clingo_ast_external_t, body} p) + <*> (#{peek clingo_ast_external_t, size} p) + poke p (AstExternal a b c) = do + (#poke clingo_ast_external_t, atom) p a + (#poke clingo_ast_external_t, body) p b + (#poke clingo_ast_external_t, size) p c + +data AstEdge = AstEdge AstTerm AstTerm (Ptr AstBodyLiteral) CSize + deriving (Eq, Show) + +instance Storable AstEdge where + sizeOf _ = #{size clingo_ast_edge_t} + alignment = sizeOf + peek p = AstEdge + <$> (#{peek clingo_ast_edge_t, u} p) + <*> (#{peek clingo_ast_edge_t, v} p) + <*> (#{peek clingo_ast_edge_t, body} p) + <*> (#{peek clingo_ast_edge_t, size} p) + poke p (AstEdge a b c d) = do + (#poke clingo_ast_edge_t, u) p a + (#poke clingo_ast_edge_t, v) p b + (#poke clingo_ast_edge_t, body) p c + (#poke clingo_ast_edge_t, size) p d + +data AstHeuristic = AstHeuristic AstTerm (Ptr AstBodyLiteral) CSize + AstTerm AstTerm AstTerm + deriving (Eq, Show) + +instance Storable AstHeuristic where + sizeOf _ = #{size clingo_ast_heuristic_t} + alignment = sizeOf + peek p = AstHeuristic + <$> (#{peek clingo_ast_heuristic_t, atom} p) + <*> (#{peek clingo_ast_heuristic_t, body} p) + <*> (#{peek clingo_ast_heuristic_t, size} p) + <*> (#{peek clingo_ast_heuristic_t, bias} p) + <*> (#{peek clingo_ast_heuristic_t, priority} p) + <*> (#{peek clingo_ast_heuristic_t, modifier} p) + poke p (AstHeuristic a b c d e f) = do + (#poke clingo_ast_heuristic_t, atom) p a + (#poke clingo_ast_heuristic_t, body) p b + (#poke clingo_ast_heuristic_t, size) p c + (#poke clingo_ast_heuristic_t, bias) p d + (#poke clingo_ast_heuristic_t, priority) p e + (#poke clingo_ast_heuristic_t, modifier) p f + +data AstProject = AstProject AstTerm (Ptr AstBodyLiteral) CSize + deriving (Eq, Show) + +instance Storable AstProject where + sizeOf _ = #{size clingo_ast_project_t} + alignment = sizeOf + peek p = AstProject + <$> (#{peek clingo_ast_project_t, atom} p) + <*> (#{peek clingo_ast_project_t, body} p) + <*> (#{peek clingo_ast_project_t, size} p) + poke p (AstProject a b c) = do + (#poke clingo_ast_project_t, atom) p a + (#poke clingo_ast_project_t, body) p b + (#poke clingo_ast_project_t, size) p c + +data AstStatement = AstStmtRule Location (Ptr AstRule) + | AstStmtDefinition Location (Ptr AstDefinition) + | AstStmtShowSignature Location (Ptr AstShowSignature) + | AstStmtShowTerm Location (Ptr AstShowTerm) + | AstStmtMinimize Location (Ptr AstMinimize) + | AstStmtScript Location (Ptr AstScript) + | AstStmtProgram Location (Ptr AstProgram) + | AstStmtExternal Location (Ptr AstExternal) + | AstStmtEdge Location (Ptr AstEdge) + | AstStmtHeuristic Location (Ptr AstHeuristic) + | AstStmtProject Location (Ptr AstProject) + | AstStmtSignature Location Signature + | AstStmtTheoryDefn Location (Ptr AstTheoryDefinition) + deriving (Eq, Show) + +instance Storable AstStatement where + sizeOf _ = #{size clingo_ast_unary_operation_t} + alignment = sizeOf + peek p = do + loc <- (#{peek clingo_ast_statement_t, location} p) + typ :: AstStatementType <- (#{peek clingo_ast_statement_t, type} p) + case typ of + AstStatementTypeRule -> do + payload <- (#{peek clingo_ast_statement_t, rule} p) + pure $! AstStmtRule loc payload + AstStatementTypeConst -> do + payload <- (#{peek clingo_ast_statement_t, definition} p) + pure $! AstStmtDefinition loc payload + AstStatementTypeShowSignature -> do + payload <- (#{peek clingo_ast_statement_t, show_signature} p) + pure $! AstStmtShowSignature loc payload + AstStatementTypeShowTerm -> do + payload <- (#{peek clingo_ast_statement_t, show_term} p) + pure $! AstStmtShowTerm loc payload + AstStatementTypeMinimize -> do + payload <- (#{peek clingo_ast_statement_t, minimize} p) + pure $! AstStmtMinimize loc payload + AstStatementTypeScript -> do + payload <- (#{peek clingo_ast_statement_t, script} p) + pure $! AstStmtScript loc payload + AstStatementTypeProgram -> do + payload <- (#{peek clingo_ast_statement_t, program} p) + pure $! AstStmtProgram loc payload + AstStatementTypeExternal -> do + payload <- (#{peek clingo_ast_statement_t, external} p) + pure $! AstStmtExternal loc payload + AstStatementTypeEdge -> do + payload <- (#{peek clingo_ast_statement_t, edge} p) + pure $! AstStmtEdge loc payload + AstStatementTypeHeuristic -> do + payload <- (#{peek clingo_ast_statement_t, heuristic} p) + pure $! AstStmtHeuristic loc payload + AstStatementTypeProjectAtom -> do + payload <- (#{peek clingo_ast_statement_t, project_atom} p) + pure $! AstStmtProject loc payload + AstStatementTypeProjectAtomSignature -> do + payload <- (#{peek clingo_ast_statement_t, project_signature} p) + pure $! AstStmtSignature loc payload + AstStatementTypeTheoryDefinition -> do + payload <- (#{peek clingo_ast_statement_t, theory_definition} p) + pure $! AstStmtTheoryDefn loc payload + _ -> error "Malformed struct clingo_ast_statement_t" + poke p d = case d of + AstStmtRule l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeRule :: AstStatementType) + (#poke clingo_ast_statement_t, rule) p x + AstStmtDefinition l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeConst :: AstStatementType) + (#poke clingo_ast_statement_t, definition) p x + AstStmtShowSignature l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeShowSignature :: AstStatementType) + (#poke clingo_ast_statement_t, show_signature) p x + AstStmtShowTerm l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeShowTerm :: AstStatementType) + (#poke clingo_ast_statement_t, show_term) p x + AstStmtMinimize l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeMinimize :: AstStatementType) + (#poke clingo_ast_statement_t, minimize) p x + AstStmtScript l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeScript :: AstStatementType) + (#poke clingo_ast_statement_t, script) p x + AstStmtProgram l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeProgram :: AstStatementType) + (#poke clingo_ast_statement_t, program) p x + AstStmtExternal l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeExternal :: AstStatementType) + (#poke clingo_ast_statement_t, external) p x + AstStmtEdge l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeEdge :: AstStatementType) + (#poke clingo_ast_statement_t, edge) p x + AstStmtHeuristic l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeHeuristic :: AstStatementType) + (#poke clingo_ast_statement_t, heuristic) p x + AstStmtProject l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeProjectAtom :: AstStatementType) + (#poke clingo_ast_statement_t, project_atom) p x + AstStmtSignature l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeProjectAtomSignature :: AstStatementType) + (#poke clingo_ast_statement_t, project_signature) p x + AstStmtTheoryDefn l x -> do + (#poke clingo_ast_statement_t, location) p l + (#poke clingo_ast_statement_t, type) p (AstStatementTypeTheoryDefinition :: AstStatementType) + (#poke clingo_ast_statement_t, theory_definition) p x + +foreign import ccall "clingo.h clingo_parse_program" parseProgramFFI :: + CString -> FunPtr (CallbackAST a) -> Ptr a -> FunPtr (Logger b) -> Ptr b + -> CUInt -> IO CBool + +parseProgram :: MonadIO m + => CString -> FunPtr (CallbackAST a) -> Ptr a -> FunPtr (Logger b) + -> Ptr b -> CUInt -> m CBool +parseProgram a b c d e f = liftIO $ parseProgramFFI a b c d e f diff --git a/src/Clingo/Raw/Basic.hs b/src/Clingo/Raw/Basic.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Basic.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Basic +( + errorString, + errorCode, + errorMessage, + setError, + warningString, + version +) +where + +import Foreign +import Foreign.C +import Control.Monad.IO.Class +import Clingo.Raw.Enums + +foreign import ccall "clingo.h clingo_error_string" errorStringFFI :: + ClingoError -> IO CString +foreign import ccall "clingo.h clingo_error_code" errorCodeFFI :: + IO ClingoError +foreign import ccall "clingo.h clingo_error_message" errorMessageFFI :: + IO CString +foreign import ccall "clingo.h clingo_set_error" setErrorFFI :: + ClingoError -> CString -> IO () +foreign import ccall "clingo.h clingo_warning_string" warningStringFFI :: + ClingoWarning -> IO CString +foreign import ccall "clingo.h clingo_version" versionFFI :: + Ptr CInt -> Ptr CInt -> Ptr CInt -> IO () + +errorString :: MonadIO m => ClingoError -> m CString +errorString = liftIO . errorStringFFI + +errorCode :: MonadIO m => m ClingoError +errorCode = liftIO errorCodeFFI + +errorMessage :: MonadIO m => m CString +errorMessage = liftIO errorMessageFFI + +setError :: MonadIO m => ClingoError -> CString -> m () +setError a b = liftIO $ setErrorFFI a b + +warningString :: MonadIO m => ClingoWarning -> m CString +warningString = liftIO . warningStringFFI + +version :: MonadIO m => Ptr CInt -> Ptr CInt -> Ptr CInt -> m () +version a b c = liftIO $ versionFFI a b c diff --git a/src/Clingo/Raw/Configuration.hs b/src/Clingo/Raw/Configuration.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Configuration.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Configuration +( + configurationRoot, + configurationType, + configurationDescription, + + -- * Functions to access arrays + configurationArraySize, + configurationArrayAt, + + -- * Functions to access maps + configurationMapSize, + configurationMapSubkeyName, + configurationMapAt, + + -- * Functions to access values + configurationValueIsAssigned, + configurationValueGetSize, + configurationValueGet, + configurationValueSet +) +where + +import Control.Monad.IO.Class + +import Foreign +import Foreign.C + +import Clingo.Raw.Enums +import Clingo.Raw.Types + +foreign import ccall "clingo.h clingo_configuration_root" configurationRootFFI :: + Configuration -> Ptr Identifier -> IO CBool +foreign import ccall "clingo.h clingo_configuration_type" configurationTypeFFI :: + Configuration -> Identifier -> Ptr ConfigurationType -> IO CBool +foreign import ccall "clingo.h clingo_configuration_description" configurationDescriptionFFI :: + Configuration -> Identifier -> Ptr CString -> IO CBool +foreign import ccall "clingo.h clingo_configuration_array_size" configurationArraySizeFFI :: + Configuration -> Word64 -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_configuration_array_at" configurationArrayAtFFI :: + Configuration -> Identifier -> CSize -> Ptr Identifier -> IO CBool +foreign import ccall "clingo.h clingo_configuration_map_size" configurationMapSizeFFI :: + Configuration -> Identifier -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_configuration_map_subkey_name" configurationMapSubkeyNameFFI :: + Configuration -> Identifier -> CSize -> Ptr CString -> IO CBool +foreign import ccall "clingo.h clingo_configuration_map_at" configurationMapAtFFI :: + Configuration -> Identifier -> CString -> Ptr Identifier -> IO CBool +foreign import ccall "clingo.h clingo_configuration_value_is_assigned" configurationValueIsAssignedFFI :: + Configuration -> Identifier -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_configuration_value_get_size" configurationValueGetSizeFFI :: + Configuration -> Identifier -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_configuration_value_get" configurationValueGetFFI :: + Configuration -> Identifier -> CString -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_configuration_value_set" configurationValueSetFFI :: + Configuration -> Identifier -> CString -> IO CBool + +configurationRoot :: MonadIO m => Configuration -> Ptr Identifier -> m CBool +configurationRoot a b = liftIO $ configurationRootFFI a b + +configurationType :: MonadIO m => Configuration -> Identifier -> Ptr ConfigurationType -> m CBool +configurationType a b c = liftIO $ configurationTypeFFI a b c + +configurationDescription :: MonadIO m => Configuration -> Identifier -> Ptr CString -> m CBool +configurationDescription a b c = liftIO $ configurationDescriptionFFI a b c + +configurationArraySize :: MonadIO m => Configuration -> Word64 -> Ptr CSize -> m CBool +configurationArraySize a b c = liftIO $ configurationArraySizeFFI a b c + +configurationArrayAt :: MonadIO m => Configuration -> Identifier -> CSize -> Ptr Identifier -> m CBool +configurationArrayAt a b c d = liftIO $ configurationArrayAtFFI a b c d + +configurationMapSize :: MonadIO m => Configuration -> Identifier -> Ptr CSize -> m CBool +configurationMapSize a b c = liftIO $ configurationMapSizeFFI a b c + +configurationMapSubkeyName :: MonadIO m => Configuration -> Identifier -> CSize -> Ptr CString -> m CBool +configurationMapSubkeyName a b c d = liftIO $ configurationMapSubkeyNameFFI a b c d + +configurationMapAt :: MonadIO m => Configuration -> Identifier -> CString -> Ptr Identifier -> m CBool +configurationMapAt a b c d = liftIO $ configurationMapAtFFI a b c d + +configurationValueIsAssigned :: MonadIO m => Configuration -> Identifier -> Ptr CBool -> m CBool +configurationValueIsAssigned a b c = liftIO $ configurationValueIsAssignedFFI a b c + +configurationValueGetSize :: MonadIO m => Configuration -> Identifier -> Ptr CSize -> m CBool +configurationValueGetSize a b c = liftIO $ configurationValueGetSizeFFI a b c + +configurationValueGet :: MonadIO m => Configuration -> Identifier -> CString -> CSize -> m CBool +configurationValueGet a b c d = liftIO $ configurationValueGetFFI a b c d + +configurationValueSet :: MonadIO m => Configuration -> Identifier -> CString -> m CBool +configurationValueSet a b c = liftIO $ configurationValueSetFFI a b c diff --git a/src/Clingo/Raw/Control.hs b/src/Clingo/Raw/Control.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Control.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Control +( + controlNew, + controlFree, + + -- * Grounding + controlLoad, + controlAdd, + controlGround, + + -- * Solving + controlSolve, + controlCleanup, + controlAssignExternal, + controlReleaseExternal, + controlRegisterPropagator, + controlStatistics, + controlInterrupt, + controlClaspFacade, + + -- * Configuration + controlConfiguration, + controlUseEnumAssumption, + + -- * Program Inspection + controlGetConst, + controlHasConst, + controlSymbolicAtoms, + controlTheoryAtoms, + controlRegisterObserver, + + -- * Program Modification + controlBackend, + controlProgramBuilder, +) +where + +import Control.Monad.IO.Class + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +import Clingo.Raw.Types +import Clingo.Raw.Enums + +foreign import ccall "clingo.h clingo_control_new" + controlNewFFI :: + Ptr CString -> CSize -> FunPtr (Logger a) -> Ptr a -> CUInt + -> Ptr Control -> IO CBool +foreign import ccall "clingo.h clingo_control_free" + controlFreeFFI :: + Control -> IO () +foreign import ccall "clingo.h clingo_control_load" + controlLoadFFI :: + Control -> CString -> IO CBool +foreign import ccall "clingo.h clingo_control_add" + controlAddFFI :: + Control -> CString -> Ptr CString -> CSize -> CString -> IO CBool +foreign import ccall "clingo.h clingo_control_ground" + controlGroundFFI :: + Control -> Ptr Part -> CSize -> FunPtr (CallbackGround a) -> Ptr a + -> IO CBool +foreign import ccall "clingo.h clingo_control_solve" + controlSolveFFI :: + Control -> SolveMode + -> Ptr SymbolicLiteral -> CSize + -> FunPtr (CallbackEvent a) -> Ptr a + -> Ptr SolveHandle -> IO CBool +foreign import ccall "clingo.h clingo_control_cleanup" + controlCleanupFFI :: + Control -> IO CBool +foreign import ccall "clingo.h clingo_control_assign_external" + controlAssignExternalFFI :: + Control -> Symbol -> TruthValue -> IO CBool +foreign import ccall "clingo.h clingo_control_release_external" + controlReleaseExternalFFI :: + Control -> Symbol -> IO CBool +foreign import ccall "clingo.h clingo_control_register_propagator" + controlRegisterPropagatorFFI :: + Control -> Ptr (Propagator a) -> Ptr a -> CBool -> IO CBool +foreign import ccall "clingo.h clingo_control_statistics" + controlStatisticsFFI :: + Control -> Ptr Statistics -> IO CBool +foreign import ccall "clingo.h clingo_control_interrupt" + controlInterruptFFI :: + Control -> IO () +foreign import ccall "clingo.h clingo_control_clasp_facade" + controlClaspFacadeFFI :: + Control -> Ptr (Ptr ()) -> IO CBool +foreign import ccall "clingo.h clingo_control_configuration" + controlConfigurationFFI :: + Control -> Ptr Configuration -> IO CBool +foreign import ccall "clingo.h clingo_control_use_enumeration_assumption" + controlUseEnumAssumptionFFI :: + Control -> CBool -> IO CBool +foreign import ccall "clingo.h clingo_control_get_const" + controlGetConstFFI :: + Control -> CString -> Ptr Symbol -> IO CBool +foreign import ccall "clingo.h clingo_control_has_const" + controlHasConstFFI :: + Control -> CString -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_control_symbolic_atoms" + controlSymbolicAtomsFFI :: + Control -> Ptr SymbolicAtoms -> IO CBool +foreign import ccall "clingo.h clingo_control_theory_atoms" + controlTheoryAtomsFFI :: + Control -> Ptr TheoryAtoms -> IO CBool +foreign import ccall "clingo.h clingo_control_register_observer" + controlRegisterObserverFFI :: + Control -> Ptr (GroundProgramObserver a) -> Ptr a -> IO CBool +foreign import ccall "clingo.h clingo_control_backend" + controlBackendFFI :: + Control -> Ptr Backend -> IO CBool +foreign import ccall "clingo.h clingo_control_program_builder" + controlProgramBuilderFFI :: + Control -> Ptr ProgramBuilder -> IO CBool + + +controlNew :: MonadIO m => Ptr CString -> CSize -> FunPtr (Logger a) + -> Ptr a -> CUInt -> Ptr Control -> m CBool +controlNew a b c d e f = liftIO $ controlNewFFI a b c d e f + +controlFree :: MonadIO m => Control -> m () +controlFree a = liftIO $ controlFreeFFI a + +controlLoad :: MonadIO m => Control -> CString -> m CBool +controlLoad a b = liftIO $ controlLoadFFI a b + +controlAdd :: MonadIO m => Control -> CString -> Ptr CString -> CSize + -> CString -> m CBool +controlAdd a b c d e = liftIO $ controlAddFFI a b c d e + +controlGround :: MonadIO m => Control -> Ptr Part -> CSize + -> FunPtr (CallbackGround a) -> Ptr a -> m CBool +controlGround a b c d e = liftIO $ controlGroundFFI a b c d e + +controlSolve :: MonadIO m + => Control -> SolveMode + -> Ptr SymbolicLiteral -> CSize + -> FunPtr (CallbackEvent a) -> Ptr a + -> Ptr SolveHandle -> m CBool +controlSolve a b c d e f g = liftIO $ controlSolveFFI a b c d e f g + +controlCleanup :: MonadIO m => Control -> m CBool +controlCleanup a = liftIO $ controlCleanupFFI a + +controlAssignExternal :: MonadIO m => Control -> Symbol -> TruthValue + -> m CBool +controlAssignExternal a b c = liftIO $ controlAssignExternalFFI a b c + +controlReleaseExternal :: MonadIO m => Control -> Symbol -> m CBool +controlReleaseExternal a b = liftIO $ controlReleaseExternalFFI a b + +controlRegisterPropagator :: MonadIO m => Control -> Ptr (Propagator a) + -> Ptr a -> CBool -> m CBool +controlRegisterPropagator a b c d = + liftIO $ controlRegisterPropagatorFFI a b c d + +controlStatistics :: MonadIO m => Control -> Ptr Statistics -> m CBool +controlStatistics a b = liftIO $ controlStatisticsFFI a b + +controlInterrupt :: MonadIO m => Control -> m () +controlInterrupt a = liftIO $ controlInterruptFFI a + +controlClaspFacade :: MonadIO m => Control -> Ptr (Ptr ()) -> m CBool +controlClaspFacade a b = liftIO $ controlClaspFacadeFFI a b + +controlConfiguration :: MonadIO m => Control -> Ptr Configuration + -> m CBool +controlConfiguration a b = liftIO $ controlConfigurationFFI a b + +controlUseEnumAssumption :: MonadIO m => Control -> CBool -> m CBool +controlUseEnumAssumption a b = liftIO $ controlUseEnumAssumptionFFI a b + +controlGetConst :: MonadIO m => Control -> CString -> Ptr Symbol -> m CBool +controlGetConst a b c = liftIO $ controlGetConstFFI a b c + +controlHasConst :: MonadIO m => Control -> CString -> Ptr CBool -> m CBool +controlHasConst a b c = liftIO $ controlHasConstFFI a b c + +controlSymbolicAtoms :: MonadIO m => Control -> Ptr SymbolicAtoms + -> m CBool +controlSymbolicAtoms a b = liftIO $ controlSymbolicAtomsFFI a b + +controlTheoryAtoms :: MonadIO m => Control -> Ptr TheoryAtoms + -> m CBool +controlTheoryAtoms a b = liftIO $ controlTheoryAtomsFFI a b + +controlRegisterObserver :: MonadIO m => Control + -> Ptr (GroundProgramObserver a) -> Ptr a + -> m CBool +controlRegisterObserver a b c = liftIO $ controlRegisterObserverFFI a b c + +controlBackend :: MonadIO m => Control -> Ptr Backend -> m CBool +controlBackend a b = liftIO $ controlBackendFFI a b + +controlProgramBuilder :: MonadIO m => Control -> Ptr ProgramBuilder + -> m CBool +controlProgramBuilder a b = liftIO $ controlProgramBuilderFFI a b diff --git a/src/Clingo/Raw/Enums.hsc b/src/Clingo/Raw/Enums.hsc new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Enums.hsc @@ -0,0 +1,217 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Raw.Enums +( + ClingoError, + pattern ErrorSuccess, + pattern ErrorRuntime, + pattern ErrorLogic, + pattern ErrorBadAlloc, + pattern ErrorUnknown, + + ClingoWarning, + pattern WarnOpUndefined, + pattern WarnRTError, + pattern WarnAtomUndefined, + pattern WarnFileIncluded, + pattern WarnVariableUnbounded, + pattern WarnGlobalVariable, + pattern WarnOther, + + TruthValue, + pattern TruthFree, + pattern TruthFalse, + pattern TruthTrue, + + SymbolType, + pattern SymInfimum, + pattern SymNumber, + pattern SymString, + pattern SymFunction, + pattern SymSupremum, + + ModelType, + pattern StableModel, + pattern BraveConsequences, + pattern CautiousConsequences, + + ShowFlag, + pattern ShowCSP, + pattern ShowShown, + pattern ShowAtoms, + pattern ShowTerms, + pattern ShowExtra, + pattern ShowAll, + pattern ShowComplement, + + SolveResult, + pattern ResultSatisfiable, + pattern ResultUnsatisfiable, + pattern ResultExhausted, + pattern ResultInterrupted, + + SolveMode, + pattern SolveModeAsync, + pattern SolveModeYield, + + SolveEvent, + pattern SolveEventModel, + pattern SolveEventFinish, + + TheoryTermType, + pattern TheoryTuple, + pattern TheoryList, + pattern TheorySet, + pattern TheoryFunction, + pattern TheoryNumber, + pattern TheorySymbol, + + ClauseType, + pattern ClauseLearnt, + pattern ClauseStatic, + pattern ClauseVolatile, + pattern ClauseVolatileStatic, + + HeuristicType, + pattern HeuristicLevel, + pattern HeuristicSign, + pattern HeuristicFactor, + pattern HeuristicInit, + pattern HeuristicTrue, + pattern HeuristicFalse, + + ExternalType, + pattern ExternalFree, + pattern ExternalTrue, + pattern ExternalFalse, + pattern ExternalRelease, + + ConfigurationType, + pattern ConfigValue, + pattern ConfigArray, + pattern ConfigMap, + + StatisticsType, + pattern StatsEmpty, + pattern StatsValue, + pattern StatsArray, + pattern StatsMap +) +where + +import Data.Int +import Data.Word + +#include + +type ClingoError = (#type clingo_error_t) + +pattern ErrorSuccess = #{const clingo_error_success} +pattern ErrorRuntime = #{const clingo_error_runtime} +pattern ErrorLogic = #{const clingo_error_logic} +pattern ErrorBadAlloc = #{const clingo_error_bad_alloc} +pattern ErrorUnknown = #{const clingo_error_unknown} + +type ClingoWarning = (#type clingo_warning_t) + +pattern WarnOpUndefined = #{const clingo_warning_operation_undefined} +pattern WarnRTError = #{const clingo_warning_runtime_error} +pattern WarnAtomUndefined = #{const clingo_warning_atom_undefined} +pattern WarnFileIncluded = #{const clingo_warning_file_included} +pattern WarnVariableUnbounded = #{const clingo_warning_variable_unbounded} +pattern WarnGlobalVariable = #{const clingo_warning_global_variable} +pattern WarnOther = #{const clingo_warning_other} + +type TruthValue = (#type clingo_truth_value_t) + +pattern TruthFree = #{const clingo_truth_value_free} +pattern TruthFalse = #{const clingo_truth_value_false} +pattern TruthTrue = #{const clingo_truth_value_true} + +type SymbolType = (#type clingo_symbol_type_t) + +pattern SymInfimum = #{const clingo_symbol_type_infimum} +pattern SymNumber = #{const clingo_symbol_type_number} +pattern SymString = #{const clingo_symbol_type_string} +pattern SymFunction = #{const clingo_symbol_type_function} +pattern SymSupremum = #{const clingo_symbol_type_supremum} + +type ModelType = (#type clingo_model_type_t) + +pattern StableModel = #{const clingo_model_type_stable_model} +pattern BraveConsequences = #{const clingo_model_type_brave_consequences} +pattern CautiousConsequences = #{const clingo_model_type_cautious_consequences} + +type ShowFlag = (#type clingo_show_type_bitset_t) + +pattern ShowCSP = #{const clingo_show_type_csp} +pattern ShowShown = #{const clingo_show_type_shown} +pattern ShowAtoms = #{const clingo_show_type_atoms} +pattern ShowTerms = #{const clingo_show_type_terms} +pattern ShowExtra = #{const clingo_show_type_extra} +pattern ShowAll = #{const clingo_show_type_all} +pattern ShowComplement = #{const clingo_show_type_complement} + +type SolveResult = (#type clingo_solve_result_bitset_t) + +pattern ResultSatisfiable = #{const clingo_solve_result_satisfiable} +pattern ResultUnsatisfiable = #{const clingo_solve_result_unsatisfiable} +pattern ResultExhausted = #{const clingo_solve_result_exhausted} +pattern ResultInterrupted = #{const clingo_solve_result_interrupted} + +type SolveMode = (#type clingo_solve_mode_bitset_t) + +pattern SolveModeAsync = #{const clingo_solve_mode_async} +pattern SolveModeYield = #{const clingo_solve_mode_yield} + +type SolveEvent = (#type clingo_solve_event_type_t) +pattern SolveEventModel = #{const clingo_solve_event_type_model} +pattern SolveEventFinish = #{const clingo_solve_event_type_finish} + +type TheoryTermType = (#type clingo_theory_term_type_t) + +pattern TheoryTuple = #{const clingo_theory_term_type_tuple} +pattern TheoryList = #{const clingo_theory_term_type_list} +pattern TheorySet = #{const clingo_theory_term_type_set} +pattern TheoryFunction = #{const clingo_theory_term_type_function} +pattern TheoryNumber = #{const clingo_theory_term_type_number} +pattern TheorySymbol = #{const clingo_theory_term_type_symbol} + +type ClauseType = (#type clingo_clause_type_t) + +pattern ClauseLearnt = #{const clingo_clause_type_learnt} +pattern ClauseStatic = #{const clingo_clause_type_static} +pattern ClauseVolatile = #{const clingo_clause_type_volatile} +pattern ClauseVolatileStatic = #{const clingo_clause_type_volatile_static} + +type HeuristicType = (#type clingo_heuristic_type_t) + +pattern HeuristicLevel = #{const clingo_heuristic_type_level} +pattern HeuristicSign = #{const clingo_heuristic_type_sign} +pattern HeuristicFactor = #{const clingo_heuristic_type_factor} +pattern HeuristicInit = #{const clingo_heuristic_type_init} +pattern HeuristicTrue = #{const clingo_heuristic_type_true} +pattern HeuristicFalse = #{const clingo_heuristic_type_false} + +type ExternalType = (#type clingo_external_type_t) + +pattern ExternalFree = #{const clingo_external_type_free} +pattern ExternalTrue = #{const clingo_external_type_true} +pattern ExternalFalse = #{const clingo_external_type_false} +pattern ExternalRelease = #{const clingo_external_type_release} + +type ConfigurationType = (#type clingo_configuration_type_bitset_t) + +pattern ConfigValue = #{const clingo_configuration_type_value} +pattern ConfigArray = #{const clingo_configuration_type_array} +pattern ConfigMap = #{const clingo_configuration_type_map} + +type StatisticsType = (#type clingo_statistics_type_t) + +pattern StatsEmpty = #{const clingo_statistics_type_empty} +pattern StatsValue = #{const clingo_statistics_type_value} +pattern StatsArray = #{const clingo_statistics_type_array} +pattern StatsMap = #{const clingo_statistics_type_map} diff --git a/src/Clingo/Raw/Inspection/Symbolic.hs b/src/Clingo/Raw/Inspection/Symbolic.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Inspection/Symbolic.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Inspection.Symbolic +( + symbolicAtomsSize, + symbolicAtomsBegin, + symbolicAtomsEnd, + symbolicAtomsFind, + symbolicAtomsIteratorIsEqualTo, + symbolicAtomsSymbol, + symbolicAtomsIsFact, + symbolicAtomsIsExternal, + symbolicAtomsLiteral, + symbolicAtomsSignaturesSize, + symbolicAtomsSignatures, + symbolicAtomsNext, + symbolicAtomsIsValid +) +where + +import Control.Monad.IO.Class +import Foreign +import Foreign.C +import Clingo.Raw.Types + +foreign import ccall "clingo.h clingo_symbolic_atoms_size" symbolicAtomsSizeFFI :: + SymbolicAtoms -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_begin" symbolicAtomsBeginFFI :: + SymbolicAtoms -> Ptr Signature -> Ptr SymbolicAtomIterator -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_end" symbolicAtomsEndFFI :: + SymbolicAtoms -> Ptr SymbolicAtomIterator -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_find" symbolicAtomsFindFFI :: + SymbolicAtoms -> Symbol -> Ptr SymbolicAtomIterator -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_iterator_is_equal_to" symbolicAtomsIteratorIsEqualToFFI :: + SymbolicAtoms -> SymbolicAtomIterator -> SymbolicAtomIterator -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_symbol" symbolicAtomsSymbolFFI :: + SymbolicAtoms -> SymbolicAtomIterator -> Ptr Symbol -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_is_fact" symbolicAtomsIsFactFFI :: + SymbolicAtoms -> SymbolicAtomIterator -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_is_external" symbolicAtomsIsExternalFFI :: + SymbolicAtoms -> SymbolicAtomIterator -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_literal" symbolicAtomsLiteralFFI :: + SymbolicAtoms -> SymbolicAtomIterator -> Ptr Literal -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_signatures_size" symbolicAtomsSignaturesSizeFFI :: + SymbolicAtoms -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_signatures" symbolicAtomsSignaturesFFI :: + SymbolicAtoms -> Ptr Signature -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_next" symbolicAtomsNextFFI :: + SymbolicAtoms -> SymbolicAtomIterator -> Ptr SymbolicAtomIterator -> IO CBool +foreign import ccall "clingo.h clingo_symbolic_atoms_is_valid" symbolicAtomsIsValidFFI :: + SymbolicAtoms -> SymbolicAtomIterator -> Ptr CBool -> IO CBool + +symbolicAtomsSize :: MonadIO m => SymbolicAtoms -> Ptr CSize -> m CBool +symbolicAtomsSize a b = liftIO $ symbolicAtomsSizeFFI a b + +symbolicAtomsBegin :: MonadIO m => SymbolicAtoms -> Ptr Signature -> Ptr SymbolicAtomIterator -> m CBool +symbolicAtomsBegin a b c = liftIO $ symbolicAtomsBeginFFI a b c + +symbolicAtomsEnd :: MonadIO m => SymbolicAtoms -> Ptr SymbolicAtomIterator -> m CBool +symbolicAtomsEnd a b = liftIO $ symbolicAtomsEndFFI a b + +symbolicAtomsFind :: MonadIO m => SymbolicAtoms -> Symbol -> Ptr SymbolicAtomIterator -> m CBool +symbolicAtomsFind a b c = liftIO $ symbolicAtomsFindFFI a b c + +symbolicAtomsIteratorIsEqualTo :: MonadIO m => SymbolicAtoms -> SymbolicAtomIterator -> SymbolicAtomIterator -> Ptr CBool -> m CBool +symbolicAtomsIteratorIsEqualTo a b c d = liftIO $ symbolicAtomsIteratorIsEqualToFFI a b c d + +symbolicAtomsSymbol :: MonadIO m => SymbolicAtoms -> SymbolicAtomIterator -> Ptr Symbol -> m CBool +symbolicAtomsSymbol a b c = liftIO $ symbolicAtomsSymbolFFI a b c + +symbolicAtomsIsFact :: MonadIO m => SymbolicAtoms -> SymbolicAtomIterator -> Ptr CBool -> m CBool +symbolicAtomsIsFact a b c = liftIO $ symbolicAtomsIsFactFFI a b c + +symbolicAtomsIsExternal :: MonadIO m => SymbolicAtoms -> SymbolicAtomIterator -> Ptr CBool -> m CBool +symbolicAtomsIsExternal a b c = liftIO $ symbolicAtomsIsExternalFFI a b c + +symbolicAtomsLiteral :: MonadIO m => SymbolicAtoms -> SymbolicAtomIterator -> Ptr Literal -> m CBool +symbolicAtomsLiteral a b c = liftIO $ symbolicAtomsLiteralFFI a b c + +symbolicAtomsSignaturesSize :: MonadIO m => SymbolicAtoms -> Ptr CSize -> m CBool +symbolicAtomsSignaturesSize a b = liftIO $ symbolicAtomsSignaturesSizeFFI a b + +symbolicAtomsSignatures :: MonadIO m => SymbolicAtoms -> Ptr Signature -> CSize -> m CBool +symbolicAtomsSignatures a b c = liftIO $ symbolicAtomsSignaturesFFI a b c + +symbolicAtomsNext :: MonadIO m => SymbolicAtoms -> SymbolicAtomIterator -> Ptr SymbolicAtomIterator -> m CBool +symbolicAtomsNext a b c = liftIO $ symbolicAtomsNextFFI a b c + +symbolicAtomsIsValid :: MonadIO m => SymbolicAtoms -> SymbolicAtomIterator -> Ptr CBool -> m CBool +symbolicAtomsIsValid a b c = liftIO $ symbolicAtomsIsValidFFI a b c diff --git a/src/Clingo/Raw/Inspection/Theory.hs b/src/Clingo/Raw/Inspection/Theory.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Inspection/Theory.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Inspection.Theory +( + -- * Term Inspection + theoryAtomsTermType, + theoryAtomsTermNumber, + theoryAtomsTermName, + theoryAtomsTermArguments, + theoryAtomsTermToStringSize, + theoryAtomsTermToString, + + -- * Element Inspection + theoryAtomsElementTuple, + theoryAtomsElementCondition, + theoryAtomsElementConditionId, + theoryAtomsElementToStringSize, + theoryAtomsElementToString, + + -- * Atom Inspection + theoryAtomsSize, + theoryAtomsAtomTerm, + theoryAtomsAtomElements, + theoryAtomsAtomHasGuard, + theoryAtomsAtomGuard, + theoryAtomsAtomLiteral, + theoryAtomsAtomToStringSize, + theoryAtomsAtomToString +) +where + +import Control.Monad.IO.Class +import Foreign +import Foreign.C +import Clingo.Raw.Types +import Clingo.Raw.Enums + +foreign import ccall "clingo.h clingo_theory_atoms_term_type" theoryAtomsTermTypeFFI :: + TheoryAtoms -> Identifier -> Ptr TheoryTermType -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_term_number" theoryAtomsTermNumberFFI :: + TheoryAtoms -> Identifier -> Ptr CInt -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_term_name" theoryAtomsTermNameFFI :: + TheoryAtoms -> Identifier -> Ptr CString -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_term_arguments" theoryAtomsTermArgumentsFFI :: + TheoryAtoms -> Identifier -> Ptr (Ptr Identifier) -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_term_to_string_size" theoryAtomsTermToStringSizeFFI :: + TheoryAtoms -> Identifier -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_term_to_string" theoryAtomsTermToStringFFI :: + TheoryAtoms -> Identifier -> Ptr CChar -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_element_tuple" theoryAtomsElementTupleFFI :: + TheoryAtoms -> Identifier -> Ptr (Ptr Identifier) -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_element_condition" theoryAtomsElementConditionFFI :: + TheoryAtoms -> Identifier -> Ptr (Ptr Literal) -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_element_condition_id" theoryAtomsElementConditionIdFFI :: + TheoryAtoms -> Identifier -> Ptr Literal -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_element_to_string_size" theoryAtomsElementToStringSizeFFI :: + TheoryAtoms -> Identifier -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_element_to_string" theoryAtomsElementToStringFFI :: + TheoryAtoms -> Identifier -> Ptr CChar -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_size" theoryAtomsSizeFFI :: + TheoryAtoms -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_atom_term" theoryAtomsAtomTermFFI :: + TheoryAtoms -> Identifier -> Ptr Identifier -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_atom_elements" theoryAtomsAtomElementsFFI :: + TheoryAtoms -> Identifier -> Ptr (Ptr Identifier) -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_atom_has_guard" theoryAtomsAtomHasGuardFFI :: + TheoryAtoms -> Identifier -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_atom_guard" theoryAtomsAtomGuardFFI :: + TheoryAtoms -> Identifier -> Ptr CString -> Ptr Identifier -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_atom_literal" theoryAtomsAtomLiteralFFI :: + TheoryAtoms -> Identifier -> Ptr Literal -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_atom_to_string_size" theoryAtomsAtomToStringSizeFFI :: + TheoryAtoms -> Identifier -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_theory_atoms_atom_to_string" theoryAtomsAtomToStringFFI :: + TheoryAtoms -> Identifier -> Ptr CChar -> CSize -> IO CBool + +theoryAtomsTermType :: MonadIO m => TheoryAtoms -> Identifier -> Ptr TheoryTermType -> m CBool +theoryAtomsTermType a b c = liftIO $ theoryAtomsTermTypeFFI a b c + +theoryAtomsTermNumber :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CInt -> m CBool +theoryAtomsTermNumber a b c = liftIO $ theoryAtomsTermNumberFFI a b c + +theoryAtomsTermName :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CString -> m CBool +theoryAtomsTermName a b c = liftIO $ theoryAtomsTermNameFFI a b c + +theoryAtomsTermArguments :: MonadIO m => TheoryAtoms -> Identifier -> Ptr (Ptr Identifier) -> Ptr CSize -> m CBool +theoryAtomsTermArguments a b c d = liftIO $ theoryAtomsTermArgumentsFFI a b c d + +theoryAtomsTermToStringSize :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CSize -> m CBool +theoryAtomsTermToStringSize a b c = liftIO $ theoryAtomsTermToStringSizeFFI a b c + +theoryAtomsTermToString :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CChar -> CSize -> m CBool +theoryAtomsTermToString a b c d = liftIO $ theoryAtomsTermToStringFFI a b c d + +theoryAtomsElementTuple :: MonadIO m => TheoryAtoms -> Identifier -> Ptr (Ptr Identifier) -> Ptr CSize -> m CBool +theoryAtomsElementTuple a b c d = liftIO $ theoryAtomsElementTupleFFI a b c d + +theoryAtomsElementCondition :: MonadIO m => TheoryAtoms -> Identifier -> Ptr (Ptr Literal) -> Ptr CSize -> m CBool +theoryAtomsElementCondition a b c d = liftIO $ theoryAtomsElementConditionFFI a b c d + +theoryAtomsElementConditionId :: MonadIO m => TheoryAtoms -> Identifier -> Ptr Literal -> m CBool +theoryAtomsElementConditionId a b c = liftIO $ theoryAtomsElementConditionIdFFI a b c + +theoryAtomsElementToStringSize :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CSize -> m CBool +theoryAtomsElementToStringSize a b c = liftIO $ theoryAtomsElementToStringSizeFFI a b c + +theoryAtomsElementToString :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CChar -> CSize -> m CBool +theoryAtomsElementToString a b c d = liftIO $ theoryAtomsElementToStringFFI a b c d + +theoryAtomsSize :: MonadIO m => TheoryAtoms -> Ptr CSize -> m CBool +theoryAtomsSize a b = liftIO $ theoryAtomsSizeFFI a b + +theoryAtomsAtomTerm :: MonadIO m => TheoryAtoms -> Identifier -> Ptr Identifier -> m CBool +theoryAtomsAtomTerm a b c = liftIO $ theoryAtomsAtomTermFFI a b c + +theoryAtomsAtomElements :: MonadIO m => TheoryAtoms -> Identifier -> Ptr (Ptr Identifier) -> Ptr CSize -> m CBool +theoryAtomsAtomElements a b c d = liftIO $ theoryAtomsAtomElementsFFI a b c d + +theoryAtomsAtomHasGuard :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CBool -> m CBool +theoryAtomsAtomHasGuard a b c = liftIO $ theoryAtomsAtomHasGuardFFI a b c + +theoryAtomsAtomGuard :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CString -> Ptr Identifier -> m CBool +theoryAtomsAtomGuard a b c d = liftIO $ theoryAtomsAtomGuardFFI a b c d + +theoryAtomsAtomLiteral :: MonadIO m => TheoryAtoms -> Identifier -> Ptr Literal -> m CBool +theoryAtomsAtomLiteral a b c = liftIO $ theoryAtomsAtomLiteralFFI a b c + +theoryAtomsAtomToStringSize :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CSize -> m CBool +theoryAtomsAtomToStringSize a b c = liftIO $ theoryAtomsAtomToStringSizeFFI a b c + +theoryAtomsAtomToString :: MonadIO m => TheoryAtoms -> Identifier -> Ptr CChar -> CSize -> m CBool +theoryAtomsAtomToString a b c d = liftIO $ theoryAtomsAtomToStringFFI a b c d diff --git a/src/Clingo/Raw/Model.hs b/src/Clingo/Raw/Model.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Model.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Model +( + -- * Inspecting Models + modelType, + modelNumber, + modelSymbolsSize, + modelSymbols, + modelContains, + modelCostSize, + modelCost, + modelOptimalityProven, + + -- * Adding Clauses + modelContext, + solveControlAddClause +) +where + +import Control.Monad.IO.Class +import Foreign +import Foreign.C +import Clingo.Raw.Types +import Clingo.Raw.Enums + +foreign import ccall "clingo.h clingo_model_type" modelTypeFFI :: + Model -> Ptr ModelType -> IO CBool +foreign import ccall "clingo.h clingo_model_number" modelNumberFFI :: + Model -> Ptr Word64 -> IO CBool +foreign import ccall "clingo.h clingo_model_symbols_size" modelSymbolsSizeFFI :: + Model -> ShowFlag -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_model_symbols" modelSymbolsFFI :: + Model -> ShowFlag -> Ptr Symbol -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_model_contains" modelContainsFFI :: + Model -> Symbol -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_model_cost_size" modelCostSizeFFI :: + Model -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_model_cost" modelCostFFI :: + Model -> Ptr Int64 -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_model_optimality_proven" + modelOptimalityProvenFFI :: + Model -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_model_context" modelContextFFI :: + Model -> Ptr SolveControl -> IO CBool +foreign import ccall "clingo.h clingo_solve_control_add_clause" + solveControlAddClauseFFI :: + SolveControl -> Ptr SymbolicLiteral -> CSize -> IO CBool + +modelType :: MonadIO m => Model -> Ptr ModelType -> m CBool +modelType a b = liftIO $ modelTypeFFI a b + +modelNumber :: MonadIO m => Model -> Ptr Word64 -> m CBool +modelNumber a b = liftIO $ modelNumberFFI a b + +modelSymbolsSize :: MonadIO m => Model -> ShowFlag -> Ptr CSize -> m CBool +modelSymbolsSize a b c = liftIO $ modelSymbolsSizeFFI a b c + +modelSymbols :: MonadIO m => Model -> ShowFlag -> Ptr Symbol -> CSize + -> m CBool +modelSymbols a b c d = liftIO $ modelSymbolsFFI a b c d + +modelContains :: MonadIO m => Model -> Symbol -> Ptr CBool -> m CBool +modelContains a b c = liftIO $ modelContainsFFI a b c + +modelCostSize :: MonadIO m => Model -> Ptr CSize -> m CBool +modelCostSize a b = liftIO $ modelCostSizeFFI a b + +modelCost :: MonadIO m => Model -> Ptr Int64 -> CSize -> m CBool +modelCost a b c = liftIO $ modelCostFFI a b c + +modelOptimalityProven :: MonadIO m => Model -> Ptr CBool -> m CBool +modelOptimalityProven a b = liftIO $ modelOptimalityProvenFFI a b + +modelContext :: MonadIO m => Model -> Ptr SolveControl -> m CBool +modelContext a b = liftIO $ modelContextFFI a b + +solveControlAddClause :: MonadIO m => SolveControl -> Ptr SymbolicLiteral + -> CSize -> m CBool +solveControlAddClause a b c = liftIO $ solveControlAddClauseFFI a b c diff --git a/src/Clingo/Raw/ProgramBuilding.hs b/src/Clingo/Raw/ProgramBuilding.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/ProgramBuilding.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.ProgramBuilding +( + backendRule, + backendWeightRule, + backendMinimize, + backendProject, + backendExternal, + backendAssume, + backendHeuristic, + backendAcycEdge, + backendAddAtom, + programBuilderBegin, + programBuilderAdd, + programBuilderEnd +) +where + +import Control.Monad.IO.Class + +import Foreign +import Foreign.C + +import Clingo.Raw.AST +import Clingo.Raw.Types +import Clingo.Raw.Enums + +foreign import ccall "clingo.h clingo_backend_rule" backendRuleFFI :: + Backend -> CBool -> Ptr Atom -> CSize -> Ptr Literal -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_backend_weight_rule" backendWeightRuleFFI :: + Backend -> CBool -> Ptr Atom -> CSize -> Weight -> Ptr WeightedLiteral -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_backend_minimize" backendMinimizeFFI :: + Backend -> Weight -> Ptr WeightedLiteral -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_backend_project" backendProjectFFI :: + Backend -> Ptr Atom -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_backend_external" backendExternalFFI :: + Backend -> Atom -> ExternalType -> IO CBool +foreign import ccall "clingo.h clingo_backend_assume" backendAssumeFFI :: + Backend -> Ptr Literal -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_backend_heuristic" backendHeuristicFFI :: + Backend -> Atom -> HeuristicType -> CInt -> CUInt -> Ptr Literal -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_backend_acyc_edge" backendAcycEdgeFFI :: + Backend -> CInt -> CInt -> Ptr Literal -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_backend_add_atom" backendAddAtomFFI :: + Backend -> Ptr Atom -> IO CBool +foreign import ccall "clingo.h clingo_program_builder_begin" programBuilderBeginFFI :: + ProgramBuilder -> IO CBool +foreign import ccall "clingo.h clingo_program_builder_add" programBuilderAddFFI :: + ProgramBuilder -> Ptr AstStatement -> IO CBool +foreign import ccall "clingo.h clingo_program_builder_end" programBuilderEndFFI :: + ProgramBuilder -> IO CBool + +backendRule :: MonadIO m => Backend -> CBool -> Ptr Atom -> CSize -> Ptr Literal -> CSize -> m CBool +backendRule a b c d e f = liftIO $ backendRuleFFI a b c d e f + +backendWeightRule :: MonadIO m => Backend -> CBool -> Ptr Atom -> CSize -> Weight -> Ptr WeightedLiteral -> CSize -> m CBool +backendWeightRule a b c d e f g = liftIO $ backendWeightRuleFFI a b c d e f g + +backendMinimize :: MonadIO m => Backend -> Weight -> Ptr WeightedLiteral -> CSize -> m CBool +backendMinimize a b c d = liftIO $ backendMinimizeFFI a b c d + +backendProject :: MonadIO m => Backend -> Ptr Atom -> CSize -> m CBool +backendProject a b c = liftIO $ backendProjectFFI a b c + +backendExternal :: MonadIO m => Backend -> Atom -> ExternalType -> m CBool +backendExternal a b c = liftIO $ backendExternalFFI a b c + +backendAssume :: MonadIO m => Backend -> Ptr Literal -> CSize -> m CBool +backendAssume a b c = liftIO $ backendAssumeFFI a b c + +backendHeuristic :: MonadIO m => Backend -> Atom -> HeuristicType -> CInt -> CUInt -> Ptr Literal -> CSize -> m CBool +backendHeuristic a b c d e f g = liftIO $ backendHeuristicFFI a b c d e f g + +backendAcycEdge :: MonadIO m => Backend -> CInt -> CInt -> Ptr Literal -> CSize -> m CBool +backendAcycEdge a b c d e = liftIO $ backendAcycEdgeFFI a b c d e + +backendAddAtom :: MonadIO m => Backend -> Ptr Atom -> m CBool +backendAddAtom a b = liftIO $ backendAddAtomFFI a b + +programBuilderBegin :: MonadIO m => ProgramBuilder -> m CBool +programBuilderBegin a = liftIO $ programBuilderBeginFFI a + +programBuilderAdd :: MonadIO m => ProgramBuilder -> Ptr AstStatement -> m CBool +programBuilderAdd a b = liftIO $ programBuilderAddFFI a b + +programBuilderEnd :: MonadIO m => ProgramBuilder -> m CBool +programBuilderEnd a = liftIO $ programBuilderEndFFI a diff --git a/src/Clingo/Raw/Propagation.hs b/src/Clingo/Raw/Propagation.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Propagation.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Propagation +( + -- * Initialization + propagateInitSolverLiteral, + propagateInitAddWatch, + propagateInitSymbolicAtoms, + propagateInitTheoryAtoms, + propagateInitNumberOfThreads, + + -- * Assignment + assignmentDecisionLevel, + assignmentHasConflict, + assignmentHasLiteral, + assignmentLevel, + assignmentDecision, + assignmentIsFixed, + assignmentIsTrue, + assignmentIsFalse, + assignmentTruthValue, + + -- * Propagation + propagateControlThreadId, + propagateControlAssignment, + propagateControlAddLiteral, + propagateControlAddWatch, + propagateControlHasWatch, + propagateControlRemoveWatch, + propagateControlAddClause, + propagateControlPropagate +) +where + +import Control.Monad.IO.Class +import Clingo.Raw.Enums +import Clingo.Raw.Types +import Foreign +import Foreign.C + +foreign import ccall "clingo.h clingo_propagate_init_solver_literal" propagateInitSolverLiteralFFI :: + PropagateInit -> Literal -> Ptr Literal -> IO CBool +foreign import ccall "clingo.h clingo_propagate_init_add_watch" propagateInitAddWatchFFI :: + PropagateInit -> Literal -> IO CBool +foreign import ccall "clingo.h clingo_propagate_init_symbolic_atoms" propagateInitSymbolicAtomsFFI :: + PropagateInit -> Ptr SymbolicAtoms -> IO CBool +foreign import ccall "clingo.h clingo_propagate_init_theory_atoms" propagateInitTheoryAtomsFFI :: + PropagateInit -> Ptr TheoryAtoms -> IO CBool +foreign import ccall "clingo.h clingo_propagate_init_number_of_threads" propagateInitNumberOfThreadsFFI :: + PropagateInit -> IO CInt +foreign import ccall "clingo.h clingo_assignment_decision_level" assignmentDecisionLevelFFI :: + Assignment -> IO Word32 +foreign import ccall "clingo.h clingo_assignment_has_conflict" assignmentHasConflictFFI :: + Assignment -> IO CBool +foreign import ccall "clingo.h clingo_assignment_has_literal" assignmentHasLiteralFFI :: + Assignment -> Literal -> IO CBool +foreign import ccall "clingo.h clingo_assignment_level" assignmentLevelFFI :: + Assignment -> Literal -> Ptr Word32 -> IO CBool +foreign import ccall "clingo.h clingo_assignment_decision" assignmentDecisionFFI :: + Assignment -> Word32 -> Ptr Literal -> IO CBool +foreign import ccall "clingo.h clingo_assignment_is_fixed" assignmentIsFixedFFI :: + Assignment -> Literal -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_assignment_is_true" assignmentIsTrueFFI :: + Assignment -> Literal -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_assignment_is_false" assignmentIsFalseFFI :: + Assignment -> Literal -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_assignment_truth_value" assignmentTruthValueFFI :: + Assignment -> Literal -> Ptr TruthValue -> IO CBool +foreign import ccall "clingo.h clingo_propagate_control_thread_id" propagateControlThreadIdFFI :: + PropagateControl -> IO Identifier +foreign import ccall "clingo.h clingo_propagate_control_assignment" propagateControlAssignmentFFI :: + PropagateControl -> IO Assignment +foreign import ccall "clingo.h clingo_propagate_control_add_literal" propagateControlAddLiteralFFI :: + PropagateControl -> Ptr Literal -> IO CBool +foreign import ccall "clingo.h clingo_propagate_control_add_watch" propagateControlAddWatchFFI :: + PropagateControl -> Literal -> IO CBool +foreign import ccall "clingo.h clingo_propagate_control_has_watch" propagateControlHasWatchFFI :: + PropagateControl -> Literal -> IO CBool +foreign import ccall "clingo.h clingo_propagate_control_remove_watch" propagateControlRemoveWatchFFI :: + PropagateControl -> Literal -> IO () +foreign import ccall "clingo.h clingo_propagate_control_add_clause" propagateControlAddClauseFFI :: + PropagateControl -> Ptr Literal -> CSize -> ClauseType -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_propagate_control_propagate" propagateControlPropagateFFI :: + PropagateControl -> Ptr CBool -> IO CBool + +propagateInitSolverLiteral :: MonadIO m => PropagateInit -> Literal -> Ptr Literal -> m CBool +propagateInitSolverLiteral a b c = liftIO $ propagateInitSolverLiteralFFI a b c + +propagateInitAddWatch :: MonadIO m => PropagateInit -> Literal -> m CBool +propagateInitAddWatch a b = liftIO $ propagateInitAddWatchFFI a b + +propagateInitSymbolicAtoms :: MonadIO m => PropagateInit -> Ptr SymbolicAtoms -> m CBool +propagateInitSymbolicAtoms a b = liftIO $ propagateInitSymbolicAtomsFFI a b + +propagateInitTheoryAtoms :: MonadIO m => PropagateInit -> Ptr TheoryAtoms -> m CBool +propagateInitTheoryAtoms a b = liftIO $ propagateInitTheoryAtomsFFI a b + +propagateInitNumberOfThreads :: MonadIO m => PropagateInit -> m CInt +propagateInitNumberOfThreads a = liftIO $ propagateInitNumberOfThreadsFFI a + +assignmentDecisionLevel :: MonadIO m => Assignment -> m Word32 +assignmentDecisionLevel a = liftIO $ assignmentDecisionLevelFFI a + +assignmentHasConflict :: MonadIO m => Assignment -> m CBool +assignmentHasConflict a = liftIO $ assignmentHasConflictFFI a + +assignmentHasLiteral :: MonadIO m => Assignment -> Literal -> m CBool +assignmentHasLiteral a b = liftIO $ assignmentHasLiteralFFI a b + +assignmentLevel :: MonadIO m => Assignment -> Literal -> Ptr Word32 -> m CBool +assignmentLevel a b c = liftIO $ assignmentLevelFFI a b c + +assignmentDecision :: MonadIO m => Assignment -> Word32 -> Ptr Literal -> m CBool +assignmentDecision a b c = liftIO $ assignmentDecisionFFI a b c + +assignmentIsFixed :: MonadIO m => Assignment -> Literal -> Ptr CBool -> m CBool +assignmentIsFixed a b c = liftIO $ assignmentIsFixedFFI a b c + +assignmentIsTrue :: MonadIO m => Assignment -> Literal -> Ptr CBool -> m CBool +assignmentIsTrue a b c = liftIO $ assignmentIsTrueFFI a b c + +assignmentIsFalse :: MonadIO m => Assignment -> Literal -> Ptr CBool -> m CBool +assignmentIsFalse a b c = liftIO $ assignmentIsFalseFFI a b c + +assignmentTruthValue :: MonadIO m => Assignment -> Literal -> Ptr TruthValue -> m CBool +assignmentTruthValue a b c = liftIO $ assignmentTruthValueFFI a b c + +propagateControlThreadId :: MonadIO m => PropagateControl -> m Identifier +propagateControlThreadId a = liftIO $ propagateControlThreadIdFFI a + +propagateControlAssignment :: MonadIO m => PropagateControl -> m Assignment +propagateControlAssignment a = liftIO $ propagateControlAssignmentFFI a + +propagateControlAddLiteral :: MonadIO m => PropagateControl -> Ptr Literal -> m CBool +propagateControlAddLiteral a b = liftIO $ propagateControlAddLiteralFFI a b + +propagateControlAddWatch :: MonadIO m => PropagateControl -> Literal -> m CBool +propagateControlAddWatch a b = liftIO $ propagateControlAddWatchFFI a b + +propagateControlHasWatch :: MonadIO m => PropagateControl -> Literal -> m CBool +propagateControlHasWatch a b = liftIO $ propagateControlHasWatchFFI a b + +propagateControlRemoveWatch :: MonadIO m => PropagateControl -> Literal -> m () +propagateControlRemoveWatch a b = liftIO $ propagateControlRemoveWatchFFI a b + +propagateControlAddClause :: MonadIO m => PropagateControl -> Ptr Literal -> CSize -> ClauseType -> Ptr CBool -> m CBool +propagateControlAddClause a b c d e = liftIO $ propagateControlAddClauseFFI a b c d e + +propagateControlPropagate :: MonadIO m => PropagateControl -> Ptr CBool -> m CBool +propagateControlPropagate a b = liftIO $ propagateControlPropagateFFI a b diff --git a/src/Clingo/Raw/Solving.hs b/src/Clingo/Raw/Solving.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Solving.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Solving +( + solveHandleGet, + solveHandleWait, + solveHandleModel, + solveHandleResume, + solveHandleCancel, + solveHandleClose +) +where + +import Control.Monad.IO.Class + +import Foreign +import Foreign.C.Types + +import Clingo.Raw.Types +import Clingo.Raw.Enums + +foreign import ccall "clingo.h clingo_solve_handle_get" + solveHandleGetFFI :: + SolveHandle -> Ptr SolveResult -> IO CBool +foreign import ccall "clingo.h clingo_solve_handle_wait" + solveHandleWaitFFI :: + SolveHandle -> CDouble -> Ptr CBool -> IO () +foreign import ccall "clingo.h clingo_solve_handle_model" + solveHandleModelFFI :: + SolveHandle -> Ptr Model -> IO CBool +foreign import ccall "clingo.h clingo_solve_handle_resume" + solveHandleResumeFFI :: + SolveHandle -> IO CBool +foreign import ccall "clingo.h clingo_solve_handle_cancel" + solveHandleCancelFFI :: + SolveHandle -> IO CBool +foreign import ccall "clingo.h clingo_solve_handle_close" + solveHandleCloseFFI :: + SolveHandle -> IO CBool + +solveHandleGet :: MonadIO m => SolveHandle -> Ptr SolveResult -> m CBool +solveHandleGet a b = liftIO $ solveHandleGetFFI a b + +solveHandleWait :: MonadIO m => SolveHandle -> CDouble -> Ptr CBool -> m () +solveHandleWait a b c = liftIO $ solveHandleWaitFFI a b c + +solveHandleModel :: MonadIO m => SolveHandle -> Ptr Model -> m CBool +solveHandleModel a b = liftIO $ solveHandleModelFFI a b + +solveHandleResume :: MonadIO m => SolveHandle -> m CBool +solveHandleResume a = liftIO $ solveHandleResumeFFI a + +solveHandleCancel :: MonadIO m => SolveHandle -> m CBool +solveHandleCancel a = liftIO $ solveHandleCancelFFI a + +solveHandleClose :: MonadIO m => SolveHandle -> m CBool +solveHandleClose a = liftIO $ solveHandleCloseFFI a diff --git a/src/Clingo/Raw/Statistics.hs b/src/Clingo/Raw/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Statistics.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Statistics +( + statisticsRoot, + statisticsType, + + -- * Array Access + statisticsArraySize, + statisticsArrayAt, + + -- * Map Access + statisticsMapSize, + statisticsMapSubkeyName, + statisticsMapAt, + + -- * Value Access + statisticsValueGet +) +where + +import Control.Monad.IO.Class +import Foreign +import Foreign.C + +import Clingo.Raw.Enums +import Clingo.Raw.Types + +foreign import ccall "clingo.h clingo_statistics_root" statisticsRootFFI :: + Statistics -> Ptr Word64 -> IO CBool +foreign import ccall "clingo.h clingo_statistics_type" statisticsTypeFFI :: + Statistics -> Word64 -> Ptr StatisticsType -> IO CBool +foreign import ccall "clingo.h clingo_statistics_array_size" + statisticsArraySizeFFI :: Statistics -> Word64 -> Ptr Word64 -> IO CBool +foreign import ccall "clingo.h clingo_statistics_array_at" + statisticsArrayAtFFI :: Statistics -> Word64 -> CSize -> Ptr Word64 + -> IO CBool +foreign import ccall "clingo.h clingo_statistics_map_size" + statisticsMapSizeFFI :: Statistics -> Word64 -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_statistics_map_subkey_name" + statisticsMapSubkeyNameFFI :: Statistics -> Word64 -> CSize + -> Ptr CString -> IO CBool +foreign import ccall "clingo.h clingo_statistics_map_at" statisticsMapAtFFI :: + Statistics -> Word64 -> CString -> Ptr Word64 -> IO CBool +foreign import ccall "clingo.h clingo_statistics_value_get" + statisticsValueGetFFI :: Statistics -> Word64 -> Ptr CDouble -> IO CBool + +statisticsRoot :: MonadIO m => Statistics -> Ptr Word64 -> m CBool +statisticsRoot a b = liftIO $ statisticsRootFFI a b + +statisticsType :: MonadIO m => Statistics -> Word64 -> Ptr StatisticsType + -> m CBool +statisticsType a b c = liftIO $ statisticsTypeFFI a b c + +statisticsArraySize :: MonadIO m => Statistics -> Word64 -> Ptr Word64 + -> m CBool +statisticsArraySize a b c = liftIO $ statisticsArraySizeFFI a b c + +statisticsArrayAt :: MonadIO m => Statistics -> Word64 -> CSize + -> Ptr Word64 -> m CBool +statisticsArrayAt a b c d = liftIO $ statisticsArrayAtFFI a b c d + +statisticsMapSize :: MonadIO m => Statistics -> Word64 -> Ptr CSize + -> m CBool +statisticsMapSize a b c = liftIO $ statisticsMapSizeFFI a b c + +statisticsMapSubkeyName :: MonadIO m => Statistics -> Word64 -> CSize + -> Ptr CString -> m CBool +statisticsMapSubkeyName a b c d = liftIO $ statisticsMapSubkeyNameFFI a b c d + +statisticsMapAt :: MonadIO m => Statistics -> Word64 -> CString + -> Ptr Word64 -> m CBool +statisticsMapAt a b c d = liftIO $ statisticsMapAtFFI a b c d + +statisticsValueGet :: MonadIO m => Statistics -> Word64 -> Ptr CDouble + -> m CBool +statisticsValueGet a b c = liftIO $ statisticsValueGetFFI a b c diff --git a/src/Clingo/Raw/Symbol.hs b/src/Clingo/Raw/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Symbol.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Clingo.Raw.Symbol +( + addString, + parseTerm, + + -- * Signatures + signatureCreate, + signatureName, + signatureArity, + signatureIsPositive, + signatureIsNegative, + signatureIsEqualTo, + signatureIsLessThan, + signatureHash, + + -- * Symbol construction + symbolCreateNumber, + symbolCreateSupremum, + symbolCreateInfimum, + symbolCreateString, + symbolCreateId, + symbolCreateFunction, + + -- * Symbol inspection + symbolNumber, + symbolName, + symbolString, + symbolIsPositive, + symbolIsNegative, + symbolArguments, + symbolType, + symbolToStringSize, + symbolToString, + + -- * Symbol comparison + symbolIsEqualTo, + symbolIsLessThan, + symbolHash +) +where + +import Control.Monad.IO.Class +import Foreign +import Foreign.C +import Clingo.Raw.Types +import Clingo.Raw.Enums + +foreign import ccall "clingo.h clingo_add_string" addStringFFI :: + CString -> Ptr CString -> IO CBool +foreign import ccall "clingo.h clingo_parse_term" parseTermFFI :: + CString -> FunPtr (Logger a) -> Ptr a -> CUInt -> Ptr Symbol -> IO CBool +foreign import ccall "clingo.h clingo_signature_create" signatureCreateFFI :: + CString -> Word32 -> CBool -> Ptr Signature -> IO CBool +foreign import ccall "clingo.h clingo_signature_name" signatureNameFFI :: + Signature -> CString +foreign import ccall "clingo.h clingo_signature_arity" signatureArityFFI :: + Signature -> Word32 +foreign import ccall "clingo.h clingo_signature_is_positive" + signatureIsPositiveFFI :: Signature -> CBool +foreign import ccall "clingo.h clingo_signature_is_negative" + signatureIsNegativeFFI :: Signature -> CBool +foreign import ccall "clingo.h clingo_signature_is_equal_to" + signatureIsEqualToFFI :: Signature -> Signature -> CBool +foreign import ccall "clingo.h clingo_signature_is_less_than" + signatureIsLessThanFFI :: Signature -> Signature -> CBool +foreign import ccall "clingo.h clingo_signature_hash" signatureHashFFI :: + Signature -> CSize +foreign import ccall "clingo.h clingo_symbol_create_number" + symbolCreateNumberFFI :: CInt -> Ptr Symbol -> IO () +foreign import ccall "clingo.h clingo_symbol_create_supremum" + symbolCreateSupremumFFI :: Ptr Symbol -> IO () +foreign import ccall "clingo.h clingo_symbol_create_infimum" + symbolCreateInfimumFFI :: Ptr Symbol -> IO () +foreign import ccall "clingo.h clingo_symbol_create_string" + symbolCreateStringFFI :: CString -> Ptr Symbol -> IO CBool +foreign import ccall "clingo.h clingo_symbol_create_id" symbolCreateIdFFI :: + CString -> CBool -> Ptr Symbol -> IO CBool +foreign import ccall "clingo.h clingo_symbol_create_function" + symbolCreateFunctionFFI :: CString -> Ptr Symbol -> CSize -> CBool + -> Ptr Symbol -> IO CBool +foreign import ccall "clingo.h clingo_symbol_number" symbolNumberFFI :: + Symbol -> Ptr CInt -> IO CBool +foreign import ccall "clingo.h clingo_symbol_name" symbolNameFFI :: + Symbol -> Ptr CString -> IO CBool +foreign import ccall "clingo.h clingo_symbol_string" symbolStringFFI :: + Symbol -> Ptr CString -> IO CBool +foreign import ccall "clingo.h clingo_symbol_is_positive" symbolIsPositiveFFI :: + Symbol -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_symbol_is_negative" symbolIsNegativeFFI :: + Symbol -> Ptr CBool -> IO CBool +foreign import ccall "clingo.h clingo_symbol_arguments" symbolArgumentsFFI :: + Symbol -> Ptr (Ptr Symbol) -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_symbol_type" symbolTypeFFI :: + Symbol -> SymbolType +foreign import ccall "clingo.h clingo_symbol_to_string_size" + symbolToStringSizeFFI :: Symbol -> Ptr CSize -> IO CBool +foreign import ccall "clingo.h clingo_symbol_to_string" + symbolToStringFFI :: Symbol -> Ptr CChar -> CSize -> IO CBool +foreign import ccall "clingo.h clingo_symbol_is_equal_to" symbolIsEqualToFFI :: + Symbol -> Symbol -> CBool +foreign import ccall "clingo.h clingo_symbol_is_less_than" + symbolIsLessThanFFI :: Symbol -> Symbol -> CBool +foreign import ccall "clingo.h clingo_symbol_hash" symbolHashFFI :: + Symbol -> CSize + +addString :: MonadIO m => CString -> Ptr CString -> m CBool +addString a b = liftIO $ addStringFFI a b + +parseTerm :: MonadIO m => CString -> FunPtr (Logger a) -> Ptr a -> CUInt + -> Ptr Symbol -> m CBool +parseTerm a b c d e = liftIO $ parseTermFFI a b c d e + +signatureCreate :: MonadIO m => CString -> Word32 -> CBool -> Ptr Signature + -> m CBool +signatureCreate a b c d = liftIO $ signatureCreateFFI a b c d + +signatureName :: Signature -> CString +signatureName = signatureNameFFI + +signatureArity :: Signature -> Word32 +signatureArity = signatureArityFFI + +signatureIsPositive :: Signature -> CBool +signatureIsPositive = signatureIsPositiveFFI + +signatureIsNegative :: Signature -> CBool +signatureIsNegative = signatureIsNegativeFFI + +signatureIsEqualTo :: Signature -> Signature -> CBool +signatureIsEqualTo = signatureIsEqualToFFI + +signatureIsLessThan :: Signature -> Signature -> CBool +signatureIsLessThan = signatureIsLessThanFFI + +signatureHash :: Signature -> CSize +signatureHash = signatureHashFFI + +symbolCreateNumber :: MonadIO m => CInt -> Ptr Symbol -> m () +symbolCreateNumber a b = liftIO $ symbolCreateNumberFFI a b + +symbolCreateSupremum :: MonadIO m => Ptr Symbol -> m () +symbolCreateSupremum a = liftIO $ symbolCreateSupremumFFI a + +symbolCreateInfimum :: MonadIO m => Ptr Symbol -> m () +symbolCreateInfimum a = liftIO $ symbolCreateInfimumFFI a + +symbolCreateString :: MonadIO m => CString -> Ptr Symbol -> m CBool +symbolCreateString a b = liftIO $ symbolCreateStringFFI a b + +symbolCreateId :: MonadIO m => CString -> CBool -> Ptr Symbol -> m CBool +symbolCreateId a b c = liftIO $ symbolCreateIdFFI a b c + +symbolCreateFunction :: MonadIO m => CString -> Ptr Symbol -> CSize -> CBool + -> Ptr Symbol -> m CBool +symbolCreateFunction a b c d e = liftIO $ symbolCreateFunctionFFI a b c d e + +symbolNumber :: MonadIO m => Symbol -> Ptr CInt -> m CBool +symbolNumber a b = liftIO $ symbolNumberFFI a b + +symbolName :: MonadIO m => Symbol -> Ptr CString -> m CBool +symbolName a b = liftIO $ symbolNameFFI a b + +symbolString :: MonadIO m => Symbol -> Ptr CString -> m CBool +symbolString a b = liftIO $ symbolStringFFI a b + +symbolIsPositive :: MonadIO m => Symbol -> Ptr CBool -> m CBool +symbolIsPositive a b = liftIO $ symbolIsPositiveFFI a b + +symbolIsNegative :: MonadIO m => Symbol -> Ptr CBool -> m CBool +symbolIsNegative a b = liftIO $ symbolIsNegativeFFI a b + +symbolArguments :: MonadIO m => Symbol -> Ptr (Ptr Symbol) -> Ptr CSize + -> m CBool +symbolArguments a b c = liftIO $ symbolArgumentsFFI a b c + +symbolType :: Symbol -> SymbolType +symbolType = symbolTypeFFI + +symbolToStringSize :: MonadIO m => Symbol -> Ptr CSize -> m CBool +symbolToStringSize a b = liftIO $ symbolToStringSizeFFI a b + +symbolToString :: MonadIO m => Symbol -> Ptr CChar -> CSize -> m CBool +symbolToString a b c = liftIO $ symbolToStringFFI a b c + +symbolIsEqualTo :: Symbol -> Symbol -> CBool +symbolIsEqualTo = symbolIsEqualToFFI + +symbolIsLessThan :: Symbol -> Symbol -> CBool +symbolIsLessThan = symbolIsLessThanFFI + +symbolHash :: Symbol -> CSize +symbolHash = symbolHashFFI diff --git a/src/Clingo/Raw/Types.hsc b/src/Clingo/Raw/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Clingo/Raw/Types.hsc @@ -0,0 +1,397 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Clingo.Raw.Types +( + CBool, + + -- * Basic types + Literal, + Atom, + Identifier, + Weight, + Logger, + mkCallbackLogger, + Location (..), + + -- * Symbols + Signature, + Symbol, + SymbolicLiteral (..), + + -- * Model and Solving + Model (..), + SolveHandle(..), + SolveControl (..), + + -- * Symbolic and Theory Atoms + SymbolicAtoms (..), + SymbolicAtomIterator, + TheoryAtoms (..), + + -- * Propagators + PropagateInit (..), + Assignment (..), + PropagateControl (..), + CallbackPropagatorInit, + mkCallbackPropagatorInit, + CallbackPropagatorPropagate, + mkCallbackPropagatorPropagate, + CallbackPropagatorUndo, + mkCallbackPropagatorUndo, + CallbackPropagatorCheck, + mkCallbackPropagatorCheck, + Propagator (..), + + -- * Program Builder + WeightedLiteral (..), + Backend (..), + ProgramBuilder (..), + + -- * Configuration & Statistics + Configuration (..), + Statistics (..), + + -- * Program Inspection + GroundProgramObserver (..), + mkGpoInitProgram, + mkGpoBeginStep, + mkGpoEndStep, + mkGpoRule, + mkGpoWeightRule, + mkGpoMinimize, + mkGpoProject, + mkGpoExternal, + mkGpoAssume, + mkGpoHeuristic, + mkGpoAcycEdge, + mkGpoTheoryTermNum, + mkGpoTheoryTermStr, + mkGpoTheoryTermCmp, + mkGpoTheoryElement, + mkGpoTheoryAtom, + mkGpoTheoryAtomGrd, + + -- * Control + Control (..), + Part (..), + CallbackSymbol, + mkCallbackSymbol, + getCallbackSymbol, + CallbackGround, + mkCallbackGround, + CallbackEvent, + mkCallbackEvent, + CallbackFinish, + mkCallbackFinish +) +where + +import Data.Int +import Data.Word +import Foreign +import Foreign.C + +import Clingo.Raw.Enums + +#include + +type CBool = #type bool + +type Literal = #type clingo_literal_t +type Atom = #type clingo_atom_t +type Identifier = #type clingo_id_t +type Weight = #type clingo_weight_t + +type Logger a = ClingoWarning -> Ptr CChar -> Ptr a -> IO () + +foreign import ccall "wrapper" mkCallbackLogger :: + Logger a -> IO (FunPtr (Logger a)) + +data Location = Location + { locBeginFile :: CString + , locEndFile :: CString + , locBeginLine :: #type size_t + , locEndLine :: #type size_t + , locBeginCol :: #type size_t + , locEndCol :: #type size_t } + deriving (Eq, Show) + +instance Storable Location where + sizeOf _ = #{size clingo_location_t} + alignment = sizeOf + + peek p = Location + <$> (#{peek clingo_location_t, begin_file} p) + <*> (#{peek clingo_location_t, end_file} p) + <*> (#{peek clingo_location_t, begin_line} p) + <*> (#{peek clingo_location_t, end_line} p) + <*> (#{peek clingo_location_t, begin_column} p) + <*> (#{peek clingo_location_t, end_column} p) + + poke p l = do + (#poke clingo_location_t, begin_file) p (locBeginFile l) + (#poke clingo_location_t, end_file) p (locEndFile l) + (#poke clingo_location_t, begin_line) p (locBeginLine l) + (#poke clingo_location_t, end_line) p (locEndLine l) + (#poke clingo_location_t, begin_column) p (locBeginCol l) + (#poke clingo_location_t, end_column) p (locEndCol l) + +type Signature = #type clingo_signature_t +type Symbol = #type clingo_symbol_t + +data SymbolicLiteral = SymbolicLiteral + { slitSymbol :: Symbol + , slitPositive :: CBool } + +instance Storable SymbolicLiteral where + sizeOf _ = #{size clingo_symbolic_literal_t} + alignment = sizeOf + peek p = SymbolicLiteral + <$> (#{peek clingo_symbolic_literal_t, symbol} p) + <*> (#{peek clingo_symbolic_literal_t, positive} p) + + poke p lit = do + (#poke clingo_symbolic_literal_t, symbol) p (slitSymbol lit) + (#poke clingo_symbolic_literal_t, positive) p (slitPositive lit) + +newtype SolveHandle = SolveHandle (Ptr SolveHandle) deriving Storable +newtype SolveControl = SolveControl (Ptr SolveControl) deriving Storable +newtype Model = Model (Ptr Model) deriving Storable +newtype SymbolicAtoms = SymbolicAtoms (Ptr SymbolicAtoms) deriving Storable + +type SymbolicAtomIterator = #type clingo_symbolic_atom_iterator_t + +newtype TheoryAtoms = TheoryAtoms (Ptr TheoryAtoms) deriving Storable +newtype PropagateInit = PropagateInit (Ptr PropagateInit) deriving Storable +newtype Assignment = Assignment (Ptr Assignment) deriving Storable +newtype PropagateControl = PropagateControl (Ptr PropagateControl) + deriving Storable + +type CallbackPropagatorInit a = + PropagateInit -> Ptr a -> IO (CBool) + +foreign import ccall "wrapper" mkCallbackPropagatorInit :: + CallbackPropagatorInit a -> IO (FunPtr (CallbackPropagatorInit a)) + +type CallbackPropagatorPropagate a = + PropagateControl -> Ptr Literal -> CSize -> Ptr a -> IO CBool + +foreign import ccall "wrapper" mkCallbackPropagatorPropagate :: + CallbackPropagatorPropagate a -> IO (FunPtr (CallbackPropagatorPropagate a)) + +type CallbackPropagatorUndo a = + PropagateControl -> Ptr Literal -> CSize -> Ptr a -> IO CBool + +foreign import ccall "wrapper" mkCallbackPropagatorUndo :: + CallbackPropagatorUndo a -> IO (FunPtr (CallbackPropagatorUndo a)) + +type CallbackPropagatorCheck a = + PropagateControl -> Ptr a -> IO CBool + +foreign import ccall "wrapper" mkCallbackPropagatorCheck :: + CallbackPropagatorCheck a -> IO (FunPtr (CallbackPropagatorCheck a)) + +data Propagator a = Propagator + { propagatorInit :: FunPtr (CallbackPropagatorInit a) + , propagatorPropagate :: FunPtr (CallbackPropagatorPropagate a) + , propagatorUndo :: FunPtr (CallbackPropagatorUndo a) + , propagatorCheck :: FunPtr (CallbackPropagatorCheck a) + } + +instance Storable (Propagator a) where + sizeOf _ = #{size clingo_propagator_t} + alignment = sizeOf + peek p = Propagator + <$> (#{peek clingo_propagator_t, init} p) + <*> (#{peek clingo_propagator_t, propagate} p) + <*> (#{peek clingo_propagator_t, undo} p) + <*> (#{peek clingo_propagator_t, check} p) + + poke p prop = do + (#poke clingo_propagator_t, init) p (propagatorInit prop) + (#poke clingo_propagator_t, propagate) p (propagatorPropagate prop) + (#poke clingo_propagator_t, undo) p (propagatorUndo prop) + (#poke clingo_propagator_t, check) p (propagatorCheck prop) + +data WeightedLiteral = WeightedLiteral + { wlLiteral :: Literal + , wlWeight :: Weight + } + +instance Storable WeightedLiteral where + sizeOf _ = #{size clingo_weighted_literal_t} + alignment = sizeOf + peek p = WeightedLiteral + <$> (#{peek clingo_weighted_literal_t, literal} p) + <*> (#{peek clingo_weighted_literal_t, weight} p) + + poke p wl = do + (#poke clingo_weighted_literal_t, literal) p (wlLiteral wl) + (#poke clingo_weighted_literal_t, weight) p (wlWeight wl) + +newtype Backend = Backend (Ptr Backend) deriving Storable +newtype Configuration = Configuration (Ptr Configuration) deriving Storable +newtype Statistics = Statistics (Ptr Statistics) deriving Storable +newtype ProgramBuilder = ProgramBuilder (Ptr ProgramBuilder) deriving Storable + +data GroundProgramObserver a = GroundProgramObserver + { gpoInitProgram :: FunPtr (CBool -> Ptr a -> IO CBool) + , gpoBeginStep :: FunPtr (Ptr a -> IO CBool) + , gpoEndStep :: FunPtr (Ptr a -> IO CBool) + , gpoRule :: FunPtr (CBool -> Ptr Atom -> CSize + -> Ptr Literal -> CSize + -> Ptr a -> IO CBool) + , gpoWeightRule :: FunPtr (CBool -> Ptr Atom -> CSize -> Weight + -> Ptr WeightedLiteral -> CSize + -> Ptr a -> IO CBool) + , gpoMinimize :: FunPtr (Weight -> Ptr WeightedLiteral -> CSize + -> Ptr a -> IO CBool) + , gpoProject :: FunPtr (Ptr Atom -> CSize -> Ptr a -> IO CBool) + , gpoExternal :: FunPtr (Atom -> ExternalType -> Ptr a -> IO CBool) + , gpoAssume :: FunPtr (Ptr Literal -> CSize -> Ptr a -> IO CBool) + , gpoHeuristic :: FunPtr (Atom -> HeuristicType -> CInt + -> CUInt -> Ptr Literal -> CSize + -> Ptr a -> IO CBool) + , gpoAcycEdge :: FunPtr (CInt -> CInt -> Ptr Literal -> CSize + -> Ptr a -> IO CBool) + , gpoTheoryTermNum :: FunPtr (Identifier -> CInt -> Ptr a -> IO CBool) + , gpoTheoryTermStr :: FunPtr (Identifier -> Ptr CChar -> Ptr a -> IO CBool) + , gpoTheoryTermCmp :: FunPtr (Identifier -> CInt -> Ptr Identifier -> CSize + -> Ptr a -> IO CBool) + , gpoTheoryElement :: FunPtr (Identifier -> Ptr Identifier -> CSize + -> Ptr Literal -> CSize -> Ptr a + -> IO CBool) + , gpoTheoryAtom :: FunPtr (Identifier -> Identifier -> Ptr Identifier + -> CSize -> IO CBool) + , gpoTheoryAtomGrd :: FunPtr (Identifier -> Identifier -> Ptr Identifier + -> CSize -> Identifier + -> Identifier -> Ptr a + -> IO CBool) + } + +foreign import ccall "wrapper" mkGpoInitProgram :: + (CBool -> Ptr a -> IO CBool) -> IO (FunPtr (CBool -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoBeginStep :: + (Ptr a -> IO CBool) -> IO (FunPtr (Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoEndStep :: + (Ptr a -> IO CBool) -> IO (FunPtr (Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoRule :: + (CBool -> Ptr Atom -> CSize -> Ptr Literal -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (CBool -> Ptr Atom -> CSize -> Ptr Literal -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoWeightRule :: + (CBool -> Ptr Atom -> CSize -> Weight -> Ptr WeightedLiteral -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (CBool -> Ptr Atom -> CSize -> Weight -> Ptr WeightedLiteral -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoMinimize :: + (Weight -> Ptr WeightedLiteral -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (Weight -> Ptr WeightedLiteral -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoProject :: + (Ptr Atom -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (Ptr Atom -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoExternal :: + (Atom -> ExternalType -> Ptr a -> IO CBool) -> IO (FunPtr (Atom -> ExternalType -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoAssume :: + (Ptr Literal -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (Ptr Literal -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoHeuristic :: + (Atom -> HeuristicType -> CInt -> CUInt -> Ptr Literal -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (Atom -> HeuristicType -> CInt -> CUInt -> Ptr Literal -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoAcycEdge :: + (CInt -> CInt -> Ptr Literal -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (CInt -> CInt -> Ptr Literal -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoTheoryTermNum :: + (Identifier -> CInt -> Ptr a -> IO CBool) -> IO (FunPtr (Identifier -> CInt -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoTheoryTermStr :: + (Identifier -> Ptr CChar -> Ptr a -> IO CBool) -> IO (FunPtr (Identifier -> Ptr CChar -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoTheoryTermCmp :: + (Identifier -> CInt -> Ptr Identifier -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (Identifier -> CInt -> Ptr Identifier -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoTheoryElement :: + (Identifier -> Ptr Identifier -> CSize -> Ptr Literal -> CSize -> Ptr a -> IO CBool) -> IO (FunPtr (Identifier -> Ptr Identifier -> CSize -> Ptr Literal -> CSize -> Ptr a -> IO CBool)) +foreign import ccall "wrapper" mkGpoTheoryAtom :: + (Identifier -> Identifier -> Ptr Identifier -> CSize -> IO CBool) -> IO (FunPtr (Identifier -> Identifier -> Ptr Identifier -> CSize -> IO CBool)) +foreign import ccall "wrapper" mkGpoTheoryAtomGrd :: + (Identifier -> Identifier -> Ptr Identifier -> CSize -> Identifier -> Identifier -> Ptr a -> IO CBool) -> IO (FunPtr (Identifier -> Identifier -> Ptr Identifier -> CSize -> Identifier -> Identifier -> Ptr a -> IO CBool)) + +instance Storable (GroundProgramObserver a) where + sizeOf _ = #{size clingo_ground_program_observer_t} + alignment = sizeOf + peek p = GroundProgramObserver + <$> (#{peek clingo_ground_program_observer_t, init_program} p) + <*> (#{peek clingo_ground_program_observer_t, begin_step} p) + <*> (#{peek clingo_ground_program_observer_t, end_step} p) + <*> (#{peek clingo_ground_program_observer_t, rule} p) + <*> (#{peek clingo_ground_program_observer_t, weight_rule} p) + <*> (#{peek clingo_ground_program_observer_t, minimize} p) + <*> (#{peek clingo_ground_program_observer_t, project} p) + <*> (#{peek clingo_ground_program_observer_t, external} p) + <*> (#{peek clingo_ground_program_observer_t, assume} p) + <*> (#{peek clingo_ground_program_observer_t, heuristic} p) + <*> (#{peek clingo_ground_program_observer_t, acyc_edge} p) + <*> (#{peek clingo_ground_program_observer_t, theory_term_number} p) + <*> (#{peek clingo_ground_program_observer_t, theory_term_string} p) + <*> (#{peek clingo_ground_program_observer_t, theory_term_compound} p) + <*> (#{peek clingo_ground_program_observer_t, theory_element} p) + <*> (#{peek clingo_ground_program_observer_t, theory_atom} p) + <*> (#{peek clingo_ground_program_observer_t, theory_atom_with_guard} p) + + poke p g = do + (#poke clingo_ground_program_observer_t, init_program) p + (gpoInitProgram g) + (#poke clingo_ground_program_observer_t, begin_step) p (gpoBeginStep g) + (#poke clingo_ground_program_observer_t, end_step) p (gpoEndStep g) + (#poke clingo_ground_program_observer_t, rule) p (gpoRule g) + (#poke clingo_ground_program_observer_t, weight_rule) p + (gpoWeightRule g) + (#poke clingo_ground_program_observer_t, minimize) p (gpoMinimize g) + (#poke clingo_ground_program_observer_t, project) p (gpoProject g) + (#poke clingo_ground_program_observer_t, external) p (gpoExternal g) + (#poke clingo_ground_program_observer_t, assume) p (gpoAssume g) + (#poke clingo_ground_program_observer_t, heuristic) p (gpoHeuristic g) + (#poke clingo_ground_program_observer_t, acyc_edge) p (gpoAcycEdge g) + (#poke clingo_ground_program_observer_t, theory_term_number) p + (gpoTheoryTermNum g) + (#poke clingo_ground_program_observer_t, theory_term_string) p + (gpoTheoryTermStr g) + (#poke clingo_ground_program_observer_t, theory_term_compound) p + (gpoTheoryTermCmp g) + (#poke clingo_ground_program_observer_t, theory_element) p + (gpoTheoryElement g) + (#poke clingo_ground_program_observer_t, theory_atom) p + (gpoTheoryAtom g) + (#poke clingo_ground_program_observer_t, theory_atom_with_guard) p + (gpoTheoryAtomGrd g) + +newtype Control = Control (Ptr Control) deriving Storable + +data Part = Part + { partName :: CString + , partParams :: Ptr Symbol + , partSize :: CSize + } + +instance Storable Part where + sizeOf _ = #{size clingo_part_t} + alignment = sizeOf + peek p = Part + <$> (#{peek clingo_part_t, name} p) + <*> (#{peek clingo_part_t, params} p) + <*> (#{peek clingo_part_t, size} p) + + poke p part = do + (#poke clingo_part_t, name) p (partName part) + (#poke clingo_part_t, params) p (partParams part) + (#poke clingo_part_t, size) p (partSize part) + +type CallbackSymbol a = Ptr Symbol -> CSize -> Ptr a -> IO CBool +type CallbackGround a = + Ptr Location -> Ptr CChar -> Ptr Symbol -> CSize -> Ptr a + -> FunPtr (CallbackSymbol a) -> Ptr a -> IO CBool +type CallbackEvent a = SolveEvent -> Ptr Model -> Ptr a -> Ptr CBool -> IO CBool +type CallbackFinish a = SolveResult -> Ptr a -> IO CBool + +foreign import ccall "wrapper" mkCallbackGround :: + CallbackGround a -> IO (FunPtr (CallbackGround a)) + +foreign import ccall "wrapper" mkCallbackSymbol :: + CallbackSymbol a -> IO (FunPtr (CallbackSymbol a)) + +foreign import ccall "dynamic" getCallbackSymbol :: + FunPtr (CallbackSymbol a) -> CallbackSymbol a + +foreign import ccall "wrapper" mkCallbackFinish :: + CallbackFinish a -> IO (FunPtr (CallbackFinish a)) + +foreign import ccall "wrapper" mkCallbackEvent :: + CallbackEvent a -> IO (FunPtr (CallbackEvent a)) diff --git a/src/Clingo/Solving.hs b/src/Clingo/Solving.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Solving.hs @@ -0,0 +1,88 @@ +module Clingo.Solving +( + ResultReady(..), + MonadSolve(..), + solverClose, + allModels +) +where + +import Control.Monad.IO.Class +import Control.Monad.Catch +import Clingo.Model (MonadModel) +import Clingo.Internal.Types +import Foreign.Ptr +import Foreign.Marshal.Utils +import Clingo.Internal.Utils +import qualified Clingo.Raw as Raw + +data ResultReady = Ready | NotReady + deriving (Eq, Show, Read, Ord) + +toRR :: Bool -> ResultReady +toRR True = Ready +toRR False = NotReady + +class MonadModel m => MonadSolve m where + -- | Get the next solve result. + getResult :: Solver s -> m s SolveResult + + -- | Get the next model if it exists. + getModel :: Solver s -> m s (Maybe (Model s)) + + -- | Wait for the specified time to check if the result is ready. + solverWait :: Solver s -> Double -> m s ResultReady + + -- | Discard the last model and start search for the next. + solverResume :: Solver s -> m s () + + -- | Stop the running search and block until done. + solverCancel :: Solver s -> m s () + +instance MonadSolve IOSym where + getResult = getResult' + getModel = getModel' + solverWait = solverWait' + solverResume = solverResume' + solverCancel = solverCancel' + +instance MonadSolve Clingo where + getResult = getResult' + getModel = getModel' + solverWait = solverWait' + solverResume = solverResume' + solverCancel = solverCancel' + +-- | Convenience method to get all models. Note that this is dependent on the +-- solver configuration! +allModels :: (Monad (m s), MonadSolve m) => Solver s -> m s [Model s] +allModels solver = do + solverResume solver + m <- getModel solver + case m of + Nothing -> pure [] + Just x -> (x :) <$> allModels solver + +getResult' :: (MonadThrow m, MonadIO m) => Solver s -> m SolveResult +getResult' (Solver s) = fromRawSolveResult <$> marshall1 (Raw.solveHandleGet s) + +getModel' :: (MonadThrow m, MonadIO m) => Solver s -> m (Maybe (Model s)) +getModel' (Solver s) = do + m@(Raw.Model x) <- marshall1 $ Raw.solveHandleModel s + pure $ if x == nullPtr then Nothing else Just (Model m) + +solverWait' :: MonadIO m => Solver s -> Double -> m ResultReady +solverWait' (Solver s) timeout = do + x <- marshall1V $ Raw.solveHandleWait s (realToFrac timeout) + pure . toRR . toBool $ x + +solverResume' :: (MonadThrow m, MonadIO m) => Solver s -> m () +solverResume' (Solver s) = marshall0 $ Raw.solveHandleResume s + +solverCancel' :: (MonadThrow m, MonadIO m) => Solver s -> m () +solverCancel' (Solver s) = marshall0 $ Raw.solveHandleCancel s + +-- | Stops the running search and releases the handle. Blocks until search is +-- stopped. +solverClose :: Solver s -> Clingo s () +solverClose (Solver s) = marshall0 $ Raw.solveHandleClose s diff --git a/src/Clingo/Statistics.hs b/src/Clingo/Statistics.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Statistics.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Statistics +( + StatsTree (..), + AMVTree (..), + (>=>), + fromStats, + fromStatsMany, + subStats +) +where + +import Control.Monad +import Control.Monad.Catch +import Control.Monad.IO.Class +import Control.DeepSeq +import Data.Text (Text) + +import GHC.Generics + +import Clingo.Internal.Types +import Clingo.Internal.Statistics + +import System.IO.Unsafe + +-- | The polymorphic statistics tree. +data StatsTree v + = SValue v + | SMap [(Text, StatsTree v)] + | SArray [(Int, StatsTree v)] + deriving (Eq, Ord, Show, Functor, Foldable, Traversable, Generic) + +instance NFData v => NFData (StatsTree v) + +getTree :: (MonadIO m, MonadThrow m) => Statistics s -> m (StatsTree Double) +getTree s = statisticsRoot s >>= liftIO . go + where go k = unsafeInterleaveIO $ do + t <- statisticsType s k + case t of + StatsArray -> do + len <- statisticsArraySize s k + let offsets = take (fromIntegral len) [0..] + cs <- mapM (go <=< statisticsArrayAt s k) offsets + return $ SArray (zip (map fromIntegral offsets) cs) + StatsMap -> do + len <- statisticsMapSize s k + let offsets = take (fromIntegral len) [0..] + nms <- mapM (statisticsMapSubkeyName s k) offsets + cs <- mapM (go <=< statisticsMapAt s k) nms + return $ SMap (zip nms cs) + StatsValue -> SValue <$> statisticsValueGet s k + _ -> error "Encountered empty statistics node" + +instance AMVTree StatsTree where + atArray i (SArray a) = lookup i a + atArray _ _ = Nothing + + atMap i (SMap m) = lookup i m + atMap _ _ = Nothing + + value (SValue v) = Just v + value _ = Nothing + +-- | Get a statistics value from the tree. If any lookup fails, the result will +-- be 'Nothing'. The tree will be traversed lazily, but the result is evaluated +-- before returning! +fromStats :: NFData w + => Statistics s -> (StatsTree Double -> Maybe w) -> Clingo s (Maybe w) +fromStats s f = head <$> fromStatsMany s [f] + +-- | Like 'fromTree' but supporting multiple paths. +fromStatsMany :: NFData w + => Statistics s -> [StatsTree Double -> Maybe w] + -> Clingo s [Maybe w] +fromStatsMany s fs = getTree s >>= \t -> return (force (fs <*> [t])) + +-- | Get an entire subtree from the statistics. The entire subtree will be +-- evaluated before returning! +subStats :: NFData w + => Statistics s -> (StatsTree Double -> Maybe (StatsTree w)) + -> Clingo s (Maybe (StatsTree w)) +subStats s f = force . f <$> getTree s diff --git a/src/Clingo/Symbol.hs b/src/Clingo/Symbol.hs new file mode 100644 --- /dev/null +++ b/src/Clingo/Symbol.hs @@ -0,0 +1,221 @@ +-- | Functions for handling symbols and signatures with clingo. +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-missing-pattern-synonym-signatures #-} +module Clingo.Symbol +( + Clingo, + ClingoWarning, + warningString, + Symbol, + Location, + Signed (..), + + -- * Symbol types + SymbolType (..), + symbolType, + pattern SymInfimum, + pattern SymNumber, + pattern SymString, + pattern SymFunction, + pattern SymSupremum, + + -- ** Function symbols + FunctionSymbol, + functionSymbol, + + -- * Signature parsing/inspection + Signature, + parseTerm, + + signatureArity, + signatureHash, + signatureName, + + -- * Symbol and signature creation + MonadSymbol (..), + createId, + + -- * Symbol inspection + symbolArguments, + symbolGetArg, + symbolHash, + symbolName, + symbolNumber, + symbolString, + prettySymbol, + + -- * Pure types + PureSymbol (..), + unpureSymbol, + toPureSymbol, + PureSignature (..), + unpureSignature, + toPureSignature +) +where + +import Data.Maybe (fromJust) +import Data.Text (Text, unpack) +import Data.Text.Lazy (fromStrict) +import Numeric.Natural +import Foreign.C +import Foreign + +import Text.PrettyPrint.Leijen.Text hiding ((<$>)) + +import GHC.Generics + +import Clingo.Internal.Types +import Clingo.Internal.Utils +import Clingo.Internal.Symbol +import qualified Clingo.Raw as Raw + +import System.IO.Unsafe + +newtype SymbolType = SymbolType Raw.SymbolType + deriving Eq + +pattern SymInfimum = SymbolType Raw.SymInfimum +pattern SymNumber = SymbolType Raw.SymNumber +pattern SymString = SymbolType Raw.SymString +pattern SymFunction = SymbolType Raw.SymFunction +pattern SymSupremum = SymbolType Raw.SymSupremum + +-- | Get the type of a symbol +symbolType :: Symbol s -> SymbolType +symbolType = SymbolType . symType + +newtype FunctionSymbol s = FuncSym { unFuncSym :: Symbol s } + deriving (Eq, Ord) + +-- | Obtain a 'FunctionSymbol' if possible. +functionSymbol :: Symbol s -> Maybe (FunctionSymbol s) +functionSymbol s = case symbolType s of + SymFunction -> Just $ FuncSym s + _ -> Nothing + +instance Signed (FunctionSymbol s) where + positive s = unsafePerformIO $ + toBool <$> marshall1 (Raw.symbolIsPositive . rawSymbol . unFuncSym $ s) + negative s = unsafePerformIO $ + toBool <$> marshall1 (Raw.symbolIsNegative . rawSymbol . unFuncSym $ s) + +-- | Construct a symbol representing an id. +createId :: MonadSymbol m => Text -> Bool -> m s (Symbol s) +createId t = createFunction t [] + +-- | Parse a term in string form. This does not return an AST Term! +parseTerm :: Text -- ^ Term as 'Text' + -> Maybe (ClingoWarning -> Text -> IO ()) -- ^ Logger callback + -> Natural -- ^ Callback limit + -> Clingo s (Symbol s) +parseTerm t logger limit = pureSymbol =<< marshall1 go + where go x = withCString (unpack t) $ \cstr -> do + logCB <- maybe (pure nullFunPtr) wrapCBLogger logger + Raw.parseTerm cstr logCB nullPtr (fromIntegral limit) x + +-- | Get the name of a signature. +signatureName :: Signature s -> Text +signatureName = sigName + +-- | Get the arity of a signature. +signatureArity :: Signature s -> Natural +signatureArity = sigArity + +-- | Hash a signature. +signatureHash :: Signature s -> Integer +signatureHash = sigHash + +-- | Hash a symbol +symbolHash :: Symbol s -> Integer +symbolHash = symHash + +-- | Obtain number from symbol. Will fail for invalid symbol types. +symbolNumber :: Symbol s -> Maybe Integer +symbolNumber = symNum + +-- | Obtain the name of a symbol when possible. +symbolName :: Symbol s -> Maybe Text +symbolName = symName + +-- | Obtain the string from a suitable symbol. +symbolString :: Symbol s -> Maybe Text +symbolString = symString + +-- | Obtain the arguments of a symbol. May be empty. +symbolArguments :: Symbol s -> [Symbol s] +symbolArguments = symArgs + +-- | Obtain the n-th argument of a symbol. +symbolGetArg :: Symbol s -> Int -> Maybe (Symbol s) +symbolGetArg s i = + let args = symbolArguments s in + if length args <= i then Nothing + else Just $ args !! i + +-- | Pretty print a symbol into a 'Text'. +prettySymbol :: Symbol s -> Text +prettySymbol = symPretty + +-- | 'PureSymbol' represents a completely pure Haskell alternative to the +-- handled 'Symbol' type of the clingo library. +data PureSymbol + = PureInfimum + | PureSupremum + | PureNumber Integer + | PureFunction Text [PureSymbol] Bool + | PureString Text + deriving (Eq, Show, Ord, Generic) + +instance Pretty PureSymbol where + pretty c = case c of + PureInfimum -> text "inf" + PureSupremum -> text "sup" + PureNumber x -> pretty x + PureFunction x vs s -> s' <+> text (fromStrict x) + <> if null vs then mempty else vs' + where s' = if s then empty else text "not" + vs' = tupled (map pretty vs) + PureString s -> text (fromStrict s) + +-- | Create a 'Symbol' in the solver from a 'PureSymbol' +unpureSymbol :: (Monad (m s), MonadSymbol m) => PureSymbol -> m s (Symbol s) +unpureSymbol PureInfimum = createInfimum +unpureSymbol PureSupremum = createSupremum +unpureSymbol (PureNumber i) = createNumber i +unpureSymbol (PureFunction f as b) = + flip (createFunction f) b =<< mapM unpureSymbol as +unpureSymbol (PureString t) = createString t + +toPureSymbol :: Symbol s -> PureSymbol +toPureSymbol s = case symType s of + Raw.SymInfimum -> PureInfimum + Raw.SymSupremum -> PureSupremum + Raw.SymString -> PureString (fromJust $ symbolString s) + Raw.SymFunction -> PureFunction + (fromJust $ symbolName s) + (map toPureSymbol $ symbolArguments s) + (fromJust (positive <$> functionSymbol s)) + Raw.SymNumber -> PureNumber (fromJust $ symbolNumber s) + _ -> error "Unknown symbol type" + +-- | 'PureSignature' represents a completely pure Haskell alternative to the +-- handled 'Signature' type of the clingo library. +data PureSignature = PureSignature Text Natural Bool + deriving (Eq, Show, Ord, Generic) + +instance Pretty PureSignature where + pretty (PureSignature s a b) = + b' <+> text (fromStrict s) <> char '/' + <> pretty (fromIntegral a :: Integer) + where b' = if b then empty else text "not" + +-- | Create a 'Signature' in the solver from a 'PureSignature' +unpureSignature :: MonadSymbol m => PureSignature -> m s (Signature s) +unpureSignature (PureSignature t a b) = createSignature t a b + +toPureSignature :: Signature s -> PureSignature +toPureSignature s = PureSignature + (signatureName s) (signatureArity s) (positive s)