Skip to content
Browse files

Move interpreter logic back to server because of speed issues

  • Loading branch information...
1 parent 8ceaaeb commit 037d4404e7444d9ed3bc2a3c1b4087763bdbd90e @norm2782 norm2782 committed Apr 3, 2012
Showing with 22 additions and 14 deletions.
  1. +6 −14 resources/static/hjs/jcu.hs
  2. +16 −0 src/Application.hs
View
20 resources/static/hjs/jcu.hs
@@ -109,22 +109,14 @@ initInterpreter = do
qryFld <- jQuery "#query"
qry <- valString qryFld
case tryParseTerm qry of
- Nothing -> markInvalidTerm qryFld
- Just goal -> do
- rules <- readIORef rlsref
- showProof (solve rules emptyEnv [("0",goal)])
+ Nothing -> markInvalidTerm qryFld
+ Just _ -> do
+ obj <- mkAnonObj
+ ajaxQ GET ("/interpreter/" ++ encodeURIComponent qry) obj showProof noop
return True
- showProof result = do
+ showProof result _ _ = do
resFld <- jQuery "#output"
- let prRes = [ concatMap (\(prefix, pr) -> prefix ++ " " ++ show (subst env pr) ++ "<br />\n") (reverse proof)
- ++ envToStr (show env) ++ "<br /><br />\n"
- | (proof, env) <- enumerateDepthFirst [] result ]
- envToStr env | DL.null env = ""
- | otherwise = "substitution: " ++ env
- txt = if null prRes
- then "Could not find an answer to that query"
- else DL.concat prRes
- setHTML resFld txt
+ _setHTML resFld result
checkTermSyntax :: EventHandler
checkTermSyntax _ = do
View
16 src/Application.hs
@@ -73,6 +73,7 @@ jcu = makeSnaplet "jcu" "Prolog proof tree practice application" Nothing $ do
, ("/logout", logoutH)
, ("/signup", signupH)
, ("/interpreter", method GET interpreterH)
+ , ("/interpreter/:query", method GET runInterpreterH)
, ("/rules/stored", method GET readStoredRulesH)
, ("/rules/stored", method POST addStoredRuleH)
, ("/rules/stored/:id", method DELETE deleteStoredRuleH)
@@ -172,6 +173,21 @@ logoutH = do
interpreterH :: AppHandler ()
interpreterH = restrict forbiddenH $ blaze (template interpreterHTML)
+runInterpreterH :: AppHandler ()
+runInterpreterH = restrict forbiddenH $ do
+ qry <- getParam "query"
+ case qry of
+ Nothing -> writeBS "Failed to produce a solution"
+ Just q' -> do let (goal, errs) = startParse pTerm (BS.unpack q')
+ if null errs
+ then do
+ rs <- getStoredRules =<< getUserId
+ let rules = [r |(DBRule _ _ r) <- rs]
+ let result = solve rules emptyEnv [("0", goal)]
+ shpref env (prefix, pr) = prefix ++ " " ++ show (subst env pr) ++ "<br />\n"
+ writeBS . BS.pack $ show $ concat [concatMap (shpref env) (reverse proof) ++ "substitution: " ++ show env ++ "<br /><br />\n" | (proof, env) <- enumerateDepthFirst [] result]
+ else writeBS . BS.pack $ "There has been an error"
+
readStoredRulesH :: AppHandler ()
readStoredRulesH = restrict forbiddenH $ do
rules <- getStoredRules =<< getUserId

0 comments on commit 037d440

Please sign in to comment.
Something went wrong with that request. Please try again.