module UHC.Util.CHR.Solve.TreeTrie.Examples.Term.Main
( RunOpt(..)
, Verbosity(..)
, runFile
)
where
import Data.Maybe
import System.IO
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.Set as Set
import UU.Parsing
import UU.Scanner
import UHC.Util.Substitutable
import UHC.Util.Pretty
import UHC.Util.CHR.Rule
import UHC.Util.CHR.GTerm.Parser
import UHC.Util.CHR.Solve.TreeTrie.MonoBacktrackPrio as MBP
import UHC.Util.CHR.Solve.TreeTrie.Examples.Term.AST
data RunOpt
= RunOpt_DebugTrace
| RunOpt_SucceedOnLeftoverWork
| RunOpt_SucceedOnFailedSolve
| RunOpt_Verbosity Verbosity
deriving (Eq)
mbRunOptVerbosity :: [RunOpt] -> Maybe Verbosity
mbRunOptVerbosity [] = Nothing
mbRunOptVerbosity (RunOpt_Verbosity v : _) = Just v
mbRunOptVerbosity (_ : r) = mbRunOptVerbosity r
runFile :: [RunOpt] -> FilePath -> IO ()
runFile runopts f = do
msg $ "READ " ++ f
mbParse <- parseFile f
case mbParse of
Left e -> putPPLn e
Right (prog, query) -> do
let sopts = defaultCHRSolveOpts
{ chrslvOptSucceedOnLeftoverWork = RunOpt_SucceedOnLeftoverWork `elem` runopts
, chrslvOptSucceedOnFailedSolve = RunOpt_SucceedOnFailedSolve `elem` runopts
}
mbp :: CHRMonoBacktrackPrioT C G P P S E IO (SolverResult S)
mbp = do
liftIO $ putPPLn $ "Rules" >-< indent 2 (vlist $ map pp prog)
query <- slvFreshSubst Set.empty query >>= \s -> return $ s `varUpd` query
liftIO $ putPPLn $ "Query" >-< indent 2 (vlist $ map pp query)
mapM_ addRule prog
mapM_ addConstraintAsWork query
liftIO $ msg $ "SOLVE " ++ f
r <- chrSolve sopts ()
let verbosity = maximum $ [Verbosity_Quiet] ++ maybeToList (mbRunOptVerbosity runopts) ++ (if RunOpt_DebugTrace `elem` runopts then [Verbosity_ALot] else [])
ppSolverResult verbosity r >>= \sr -> liftIO $ putPPLn $ "Solution" >-< indent 2 sr
return r
runCHRMonoBacktrackPrioT (emptyCHRGlobState) (emptyCHRBackState ) mbp
msg $ "DONE " ++ f
where
msg m = putStrLn $ "---------------- " ++ m ++ " ----------------"
mainTerm = do
forM_
[
"typing2"
] $ \f -> do
let f' = "test/" ++ f ++ ".chr"
runFile
[ RunOpt_SucceedOnLeftoverWork
, RunOpt_DebugTrace
] f'