activehs 0.3.1 → 0.3.2
raw patch · 15 files changed
+327/−259 lines, 15 filesdep +blaze-markupdep +exceptionsdep ~QuickCheckdep ~arraydep ~basenew-uploader
Dependencies added: blaze-markup, exceptions
Dependency ranges changed: QuickCheck, array, base, blaze-html, deepseq, filepath, haskell-src-exts, highlighting-kate, hint, hoogle, mtl, pandoc, process, snap-core, snap-server, syb, text, time, utf8-string
Files
- Args.hs +2/−2
- Converter.hs +22/−19
- HoogleCustom.hs +14/−26
- Html.hs +19/−12
- Logger.hs +0/−1
- Main.hs +43/−30
- Parse.hs +4/−3
- QuickCheck.hs +31/−19
- Result.hs +4/−4
- Simple.hs +15/−14
- Smart.hs +99/−79
- Special.hs +31/−20
- Specialize.hs +1/−1
- activehs.cabal +36/−24
- copy/common.css +6/−5
Args.hs view
@@ -21,7 +21,7 @@ , fileservedir :: String , logdir :: String - , hoogledb :: String+ , hoogledb :: (Maybe String) , mainpage :: String , restartpath :: String@@ -46,7 +46,7 @@ , fileservedir = "" &= typDir &= help "Files in this directory will be served as they are (for css and javascript files). Default points to the distribution's directory." , logdir = "log" &= typDir &= help "Directory to put log files in. Default is 'log'." - , hoogledb = "" &= typFile &= help "Hoogle database file"+ , hoogledb = Nothing &= typFile &= help "Hoogle database file" , mainpage = "Index.xml" &= typ "PATH" &= help "Main web page path" , restartpath = "" &= typ "PATH" &= help "Opening this path in browser restarts the ghci server."
Converter.hs view
@@ -28,7 +28,7 @@ import Control.Monad import Data.List-import Data.Char+import Data.Char hiding (Format) ---------------------------------- @@ -59,6 +59,7 @@ writeEx (what <.> ext) [showEnv mode $ importsHiding []] ss' <- zipWithM processBlock [1..] $ preprocessForSlides ss ht <- readFile' $ templatedir </> lang' ++ ".template"+ putStrLn $ "Lang is:" ++ lang' writeFile' (gendir </> what <.> "xml") $ flip writeHtmlString (Pandoc meta $ concat ss') $ def@@ -96,7 +97,7 @@ importsHiding funnames = case modu of HaskellModule (HSyn.Module loc (HSyn.ModuleName modname) directives _ _ imps _) -> HPty.prettyPrint $ - HSyn.Module loc (HSyn.ModuleName "Main") directives Nothing Nothing+ HSyn.Module loc (HSyn.ModuleName "") directives Nothing Nothing ([mkImport modname funnames, mkImport_ ('X':magicname) modname] ++ imps) [] -- _ -> error "error in Converter.extract" @@ -105,6 +106,10 @@ ---------------------------- +-- todo: processBlock :: Int -> BBlock -> IO (Either Html [Block])+-- hogy a hibákhoz lehessen rendes html oldalt generálni+-- vagy a Resulthoz jobb show-t írni+ processBlock :: Int -> BBlock -> IO [Block] processBlock _ (Exercise visihidden _ _ funnames is)@@ -126,27 +131,24 @@ $ mkCodeBlock static_ ++ showBlockSimple lang' fn i rows (intercalate "\n" inForm) - processBlock ii (OneLineExercise 'H' erroneous exp) + processBlock ii (OneLineExercise 'H' correct exp) = return []- processBlock ii (OneLineExercise p erroneous exp) = do+ processBlock ii (OneLineExercise p correct exp) = do let m5 = mkHash $ show ii ++ exp i = show m5 fn = what ++ (if p == 'R' then "_" ++ i else "") <.> ext act = getOne "eval" fn i i when (p == 'R') $ writeEx fn [showEnv mode $ importsHiding [], "\n" ++ magicname ++ " = " ++ exp]- (b, exp') <- if p == 'F' && all (==' ') exp - then return (True, [])+ when verbose $ putStrLn $ "interpreting " ++ exp+ result <- if p `elem` ['F', 'R']+ then return Nothing else do- when verbose $ putStrLn $ "interpreting " ++ exp- r <- interp False m5 lang' ghci (exercisedir </> fn) exp $ \a -> return $ return []-- return $ (not $ hasError r, take 1 r)-- when (erroneous /= b) - $ error $ translate lang' "Erroneous evaluation" ++ ": " ++ exp ++ " ; " ++ showHtmlFragment (renderResults_ exp')-- return [rawHtml $ showHtmlFragment $ showInterpreter lang' 60 act i p exp exp']+ result <- interp False m5 lang' ghci (exercisedir </> fn) exp Nothing+ when (correct == hasError [result])+ $ error $ translate lang' "Erroneous evaluation" ++ ": " ++ exp ++ " ; " ++ showHtmlFragment (renderResult result)+ return $ Just result+ return [rawHtml $ showHtmlFragment $ showInterpreter lang' 60 act i p exp result] processBlock _ (Text (CodeBlock ("",[t],[]) l)) | t `elem` ["dot","neato","twopi","circo","fdp","dfdp","latex"] = do@@ -181,7 +183,7 @@ _ -> [ t, "-Tpng", "-o", outfile, tmpfile, "2>&1 >/dev/null" ] if x == ExitSuccess - then return [Para [Image [Str imgname] (imgname, "")]]+ then return [Para [Image ("", [], []) [Str imgname] (imgname, "")]] else fail $ "processDot " ++ tmpfile ++ "; " ++ show x processBlock _ (Text l)@@ -206,7 +208,7 @@ ------------------------------------ rawHtml :: String -> Block-rawHtml x = RawBlock "html" x+rawHtml x = RawBlock (Format "html") x showBlockSimple :: Language -> String -> String -> Int -> String -> [Block] @@ -245,12 +247,13 @@ , HSyn.importPkg = Nothing , HSyn.importAs = Nothing , HSyn.importSpecs = Just (True, map (HSyn.IVar . mkName) d)+ , HSyn.importSafe = False } mkName :: String -> HSyn.Name mkName n@(c:_)- | isSymbol c = HSyn.Symbol n-mkName n = HSyn.Ident n+ | isLetter c = HSyn.Ident n+mkName n = HSyn.Symbol n mkImport_ :: String -> String -> HSyn.ImportDecl mkImport_ magic m
HoogleCustom.hs view
@@ -7,37 +7,25 @@ import Result import Lang -import Hoogle hiding (Language, Result)-import qualified Hoogle--import Data.List (nub)+import qualified Hoogle as H ------------------------- -query :: Bool -> Maybe Database -> String -> [Result]-query b ch a - = case parseQuery Haskell a of- Right q -> format $ nub $ map (self . snd) $ search' ch q- Left err -> [Error b (errorMessage err)]+query :: FilePath -> String -> IO Result+query ch q = format <$> search' ch q -queryInfo :: Language -> Bool -> Maybe Database -> String -> [Result]-queryInfo lang b ch a - = case parseQuery Haskell a of- Right q -> case search' ch q of- ((_,r):_) -> [SearchResults False [showTagHTML $ docs r]]- [] -> [Message (translate lang "No info for " ++ a) Nothing | b]- Left err -> [Error b $ errorMessage err]+queryInfo :: Language -> FilePath -> String -> IO Result+queryInfo lang db q = do+ res <- search' db q+ case res of+ (r : _) -> return $ SearchResults False [H.targetDocs r]+ [] -> return $ Message (translate lang "No info for " ++ q) Nothing -search' :: Maybe Database -> Query -> [(Score, Hoogle.Result)]-search' ch q - = case ch of- Nothing -> []- Just db -> search db q+search' :: FilePath -> String -> IO [H.Target]+search' dbname q = H.withDatabase dbname+ (\db -> return $ H.searchDatabase db q) -format :: [TagStr] -> [Result]-format [] = []-format r = [SearchResults (not $ null b) (map showTagHTML a)]+format :: [H.Target] -> Result+format r = SearchResults (not $ null b) (map H.targetDocs a) where (a, b) = splitAt 10 r--
Html.hs view
@@ -6,13 +6,16 @@ , renderResults_ , showInterpreter , indent, delim, getOne, getTwo+ , renderHtml+ , (|-|) ) where import Result import Lang import Data.Data.Compare -import Text.XHtml.Strict+import Text.XHtml.Strict hiding (renderHtml)+import qualified Text.XHtml.Strict as H import qualified Data.Text as T ---------------------@@ -39,16 +42,21 @@ renderResult (Error _ s) = showRes "" "" "" [showLines s] renderResult (Message s r) - = toHtml s |-| maybe noHtml renderResult r+ = p (toHtml s) |-| maybe noHtml renderResult r renderResult (Comparison a x b es) = showRes a (showAnswer x) b (map mkBott es) renderResult (Dia htm err) = showResErr htm (map mkBott err)-renderResult (ModifyCommandLine _)+renderResult (ShowFailedTestCase _ _) = noHtml renderResult (ShowInterpreter lang limit act i prompt exp res) = showInterpreter lang limit act i prompt exp res +renderHtml :: Html -> T.Text+renderHtml = T.pack . H.renderHtmlFragment++infixr 2 |-|+ (|-|) :: Html -> Html -> Html a |-| b | isNoHtml a || isNoHtml b = a +++ b a |-| b = a +++ br +++ b@@ -119,8 +127,8 @@ skipString a [] = (a, []) -showInterpreter :: Language -> Int -> String -> String{-Id-} -> Char -> String -> [Result] -> Html-showInterpreter lang limit act i prompt exp res = indent $+showInterpreter :: Language -> Int -> String -> String{-Id-} -> Char -> String -> Maybe Result -> Html+showInterpreter lang limit act i prompt exp result = form ! [ theclass $ if prompt == 'R' || null exp then "interpreter" else "resetinterpreter" , action act ]@@ -135,12 +143,11 @@ , value $ if prompt == 'R' then "" else exp ] , br- ] ++- [ thediv- ! [ theclass "answer"- , identifier $ "res" ++ i- ] << if prompt `notElem` ['R', 'F'] then renderResults_ res else noHtml- ])+ ] ++ [ thediv+ ! [ theclass "answer"+ , identifier $ "res" ++ i+ ]+ $ maybe noHtml renderResult result]) onlyIf :: Bool -> [a] -> [a] onlyIf True l = l@@ -156,6 +163,6 @@ getOne c f t x = concat ["javascript:getOne('c=", c, "&f=", f, "','", t, "','", x, "');"] getTwo :: String -> String -> String -> String -> String -> String-getTwo c f t x y = concat ["javascript:getTwo('c=", c, "&f=", f, "','", t, "','", x, "','", y, "');"]+getTwo command f t x y = concat ["javascript:getTwo('c=", command, "&f=", f, "','", t, "','", x, "','", y, "');"]
Logger.hs view
@@ -8,7 +8,6 @@ import qualified System.FastLogger as SF -import Control.Applicative import Control.Monad import qualified Data.ByteString as B
Main.hs view
@@ -3,7 +3,7 @@ module Main where -import Smart+import Smart hiding (hoogledb) import Cache import Converter import Args@@ -25,13 +25,13 @@ import System.FilePath ((</>), takeExtension, dropExtension) import System.Directory (doesFileExist)-import Control.Concurrent (threadDelay)+import System.IO (hSetBuffering, stdin, BufferMode(NoBuffering))+import Control.Concurrent (threadDelay, forkIO, killThread) import Control.Monad (when)+import Control.Monad.Trans (liftIO) import Control.Applicative ((<|>))-import System.Locale (defaultTimeLocale)-import Data.Time (getCurrentTime, formatTime, diffUTCTime)+import Data.Time (getCurrentTime, diffUTCTime) import Data.Maybe (listToMaybe)---import Prelude hiding (catch) --------------------------------------------------------------- @@ -41,31 +41,35 @@ mainWithArgs :: Args -> IO () mainWithArgs args@(Args {verbose, port, static, logdir, hoogledb, fileservedir, gendir, mainpage, restartpath, sourcedir, includedir}) = do - ti <- getCurrentTime log <- newLogger verbose $ - logdir </> "interpreter_" ++ formatTime defaultTimeLocale "%Y-%m-%d-%H-%M-%S" ti ++ ".log"- -- "%Y-%m-%d-%H:%M:%S" is not ok, colons are not supported in filenames under windows+ logdir </> "interpreter.log" ch <- startGHCiServer [sourcedir] log hoogledb cache <- newCache 10 - httpServe+ logStrMsg 2 log ("lang: " ++ lang args) - ( setPort port- . setAccessLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir </> "access.log"))- . setErrorLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir </> "error.log"))- $ emptyConfig- )+ putStrLn "Press any key to stop the server."+ t <- forkIO $ httpServe - ( method GET- ( serveDirectoryWith simpleDirectoryConfig fileservedir- <|> serveHtml ch- <|> ifTop (redirectString mainpage)- <|> pathString restartpath (liftIO $ restart ch >> clearCache cache)- )- <|> method POST (exerciseServer (sourcedir:includedir) (cache, ch) args)- <|> notFound- )+ ( setPort port+ . setAccessLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir </> "access.log"))+ . setErrorLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir </> "error.log"))+ $ emptyConfig+ )++ ( method GET+ ( serveDirectoryWith simpleDirectoryConfig fileservedir+ <|> serveHtml ch+ <|> ifTop (redirectString mainpage)+ <|> pathString restartpath (liftIO $ restart ch >> clearCache cache)+ )+ <|> method POST (exerciseServer (sourcedir:includedir) (cache, ch) args)+ <|> notFound+ )+ hSetBuffering stdin NoBuffering+ _ <- getChar+ killThread t where serveHtml ch = do p <- getSafePath@@ -100,16 +104,21 @@ return res Right cacheAction -> do time <- liftIO $ getCurrentTime- res <- fmap renderResults $ do+ res <- fmap renderHtml $ do Just [ss, fn_, x, y, T.unpack -> lang'] <- fmap sequence $ mapM getTextParam ["c","f","x","y","lang"] let fn = exercisedir </> T.unpack fn_- ext = reverse $ takeWhile (/='.') $ reverse fn- True <- liftIO $ doesFileExist fn- Just task <- liftIO $ fmap (eval_ ext ss y . T.splitOn (T.pack delim)) $ T.readFile fn- liftIO $ exerciseServer' ('X':magicname) ch verboseinterpreter fn x lang md5Id task-- <|> return [Error True $ translate lang "Inconsistency between server and client."]+ ext = case takeExtension fn of+ ('.':ext) -> ext+ _ -> ""+ fnExists <- liftIO $ doesFileExist fn+ if fnExists+ then do+ Just task <- liftIO $ fmap (eval_ ext ss y . T.splitOn (T.pack delim)) $ T.readFile fn+ liftIO $ exerciseServer' ('X':magicname) ch verboseinterpreter fn x lang' md5Id task+ else+ return (inconsistencyError lang')+ <|> return (inconsistencyError lang) liftIO $ do time' <- getCurrentTime@@ -119,6 +128,10 @@ return res where+ inconsistencyError :: String -> Html+ inconsistencyError lang' = renderResult $ Error True $ translate lang' "Inconsistency between server and client."++ eval_ :: String -> T.Text -> T.Text -> [T.Text] -> Maybe SpecialTask eval_ _ "eval" _ [_] = Just Eval eval_ _ "eval" _ [_, goodsol]
Parse.hs view
@@ -72,12 +72,13 @@ mainParse mode s = do c <- readFile s case readMarkdown pState . unlines . concatMap preprocess . lines $ c of- Pandoc meta (CodeBlock ("",["sourceCode","literate","haskell"],[]) h: blocks) -> do+ Right (Pandoc meta (CodeBlock ("",["sourceCode","literate","haskell"],[]) h: blocks)) -> do header <- parseModule mode $ h fmap (Doc meta header) $ collectTests mode $ map ({-highlight . -}interpreter . Text) blocks- Pandoc meta blocks -> do+ Right (Pandoc meta blocks) -> do header <- parseModule mode $ "module Unknown where" fmap (Doc meta header) $ collectTests mode $ map ({-highlight . -}interpreter . Text) blocks+ Left err -> fail $ "readMarkdown: " ++ show err where parseModule :: ParseMode -> String -> IO Module parseModule HaskellMode m = case HPar.parseModuleWithMode HPar.defaultParseMode m of@@ -137,7 +138,7 @@ getFName (HPar.ParseOk x) = case x of HSyn.TypeSig _ a _ -> map printName a- HSyn.PatBind _ (HSyn.PVar a) _ _ _ -> [printName a]+ HSyn.PatBind _ (HSyn.PVar a) _ _ -> [printName a] HSyn.FunBind (HSyn.Match _ a _ _ _ _ :_) -> [printName a] HSyn.TypeDecl _ a _ _ -> [printName a] HSyn.DataDecl _ _ _ a _ x _ -> printName a: [printName n | HSyn.QualConDecl _ _ _ y<-x, n <- getN y]
QuickCheck.hs view
@@ -7,14 +7,16 @@ import Logger import Qualify (qualify) import Hash+import Specialize (specialize) import Test.QuickCheck hiding (Result) import qualified Test.QuickCheck.Property as QC import Data.Char (isLower) import Data.List (intercalate)-import Control.Monad (join)-import Control.Concurrent.MVar+import Control.Monad (join,forM,void)+import Control.Monad.Trans (liftIO)+import Control.Concurrent.MVar (newMVar, swapMVar, takeMVar) --------------------------------------- @@ -27,7 +29,7 @@ -> String -> [String] -> [([String],String)] -- test cases- -> IO [Result]+ -> IO Result quickCheck qualifier m5 lang ch fn ft funnames testcases = do logStrMsg 3 (logger ch) $ "test cases: " ++ show testcases logStrMsg 3 (logger ch) $ "names to be qualified: " ++ show funnames@@ -35,22 +37,27 @@ case allRight $ map (qualify qualifier funnames . snd) testcases of Left err -> do logStrMsg 3 (logger ch) $ "Error in qualification: " ++ err- return [Error True err]+ return $ Error True err Right s_ -> do logStrMsg 3 (logger ch) $ "Qualified expressions: " ++ show s_-- let ts = mkTestCases [(v,s,s') | ((v,s),s')<- zip testcases s_]- logStrMsg 3 (logger ch) $ "Test cases: " ++ ts- - interp False m5 lang ch fn "" $ \a ->- do liftIO $ logStrMsg 3 (logger ch) "Before interpretation"+ interp False m5 lang ch fn "" $ Just $ \a ->+ do ss <- forM (testcases `zip` s_) $ \((v,s1),s2) -> do+ ts1 <- typeOf s1+ ts2 <- typeOf s2+ let [x1,x2] = map fixType [(s1,ts1),(s2,ts2)]+ return $ mkTestCase (v,x1,x2)+ let ts = "[" ++ intercalate ", " ss ++ "]"+ liftIO $ logStrMsg 3 (logger ch) $ "Test cases: " ++ ts+ liftIO $ logStrMsg 3 (logger ch) "Before interpretation" m <- interpret ts (as :: [TestCase]) liftIO $ logStrMsg 3 (logger ch) "After interpretation"- return $ qcs lang (logger ch) m+ liftIO $ qcs lang (logger ch) m where- mkTestCases ss - = "[" ++ intercalate ", " (map mkTestCase ss) ++ "]"+ fixType (s,t) =+ case (specialize t) of+ Right (st,_) | t /= st -> unwords [s, "::", st]+ _ -> s mkTestCase (vars, s, s2) = "TestCase (\\qcinner " @@ -67,20 +74,25 @@ g x | x `elem` vs = {- "\"(\" ++ -} " show " ++ x -- ++ " ++ \")\"" g x = show x -qcs :: Language -> Logger -> [TestCase] -> IO [Result]-qcs lang log = join . foldM (return [Message (translate lang "All test cases are completed.") Nothing]) (qc lang log)+qcs :: Language -> Logger -> [TestCase] -> IO Result+qcs lang log = foldM (Message (translate lang "All test cases are completed.") Nothing) (qc lang log) -- test = qc $ TestCase $ \f (QCNat x) (QCInt y) -> f (show x ++ " + " ++ show y, min 10 (x + y), x + y) -- test' = qc $ TestCase $ \f (QCInt x) -> f ("sqr " ++ show x, min 10 (x*x), x*x) -qc :: Language -> Logger -> TestCase -> IO (Maybe (IO [Result]))+qc :: Language -> Logger -> TestCase -> IO (Maybe Result) qc lang log (TestCase p) = do v <- newMVar Nothing let ff (s, x, y)- = QC.whenFail (modifyMVar_ v $ const $ return $ Just $ fmap (ModifyCommandLine s :) res)- $ QC.morallyDubiousIOProperty- $ fmap (\s -> if hasError s then QC.failed else QC.succeeded) res+ = QC.morallyDubiousIOProperty $ do+ r <- res+ if hasError [r]+ then do + void $ swapMVar v $ Just $ ShowFailedTestCase s r+ return QC.failed+ else return QC.succeeded where+ res :: IO Result res = do logStrMsg 4 log $ "compare: " ++ s compareClearGen lang "noId" $ WrapData2 x y
Result.hs view
@@ -25,8 +25,8 @@ | Error Bool String -- True: important error message | Dia Html [Err] | Message String (Maybe Result)- | ModifyCommandLine String- | ShowInterpreter Language Int String String{-Id-} Char String [Result]+ | ShowFailedTestCase String Result+ | ShowInterpreter Language Int String String{-Id-} Char String (Maybe Result) deriving (Show) instance NFData Result where@@ -37,7 +37,7 @@ rnf (Error b s) = rnf (b, s) rnf (Message s r) = rnf (s, r) rnf (Dia h e) = length (showHtmlFragment h) `seq` rnf e- rnf (ModifyCommandLine s) = rnf s+ rnf (ShowFailedTestCase testcase res) = rnf (testcase, res) rnf (ShowInterpreter a b c d e f g) = rnf (a,b,c,d,e,f,g) errors :: Result -> Bool@@ -47,7 +47,7 @@ errors (Dia _ l) = not $ null l errors (Error i _) = i errors (Message _ x) = maybe False errors x-errors (ShowInterpreter _ _ _ _ _ _ g) = any errors g+errors (ShowInterpreter _ _ _ _ _ _ g) = maybe False errors g errors _ = False filterResults :: [Result] -> [Result]
Simple.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, FlexibleContexts #-}+{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, FlexibleContexts, CPP #-} module Simple ( Task (..), TaskChan@@ -9,7 +9,8 @@ , Interpreter, typeOf, kindOf , InterpreterError (..), errMsg, interpret- , as, liftIO, parens+ , MonadInterpreter+ , as, parens ) where import Logger@@ -19,11 +20,14 @@ import Control.Concurrent (forkIO) import Control.Concurrent.MVar (MVar, newEmptyMVar, takeMVar, putMVar) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Exception (SomeException, catch)+import Control.Exception (SomeException)+import qualified Control.Exception as CE import Control.Monad (when, forever)-import Control.Monad.Error (MonadError, catchError)+import Control.Monad.Catch (catch) import Data.List (isPrefixOf)---import Prelude hiding (catch)+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif ------------------------- @@ -42,8 +46,8 @@ _ <- forkIO $ forever $ do logStrMsg 1 log "start interpreter" e <- runInterpreter (handleTask ch Nothing)- `catch` \(e :: SomeException) ->- return $ Left $ UnknownError "GHCi server died."+ `CE.catch` \(e :: SomeException) ->+ return $ Left $ UnknownError $ "GHCi server died: " ++ show e case e of Left e -> logStrMsg 0 log $ "stop interpreter: " ++ show e Right () -> return ()@@ -63,9 +67,9 @@ when (oldFn /= Just fn) $ do reset set [searchPath := paths]+ set [languageExtensions := [ExtendedDefaultRules]] loadModules [fn] setTopLevelModules ["Main"]- x <- m return (True, Right x) @@ -87,18 +91,15 @@ writeChan ch $ Just $ Task fn rep m takeMVar rep --- fatal :: InterpreterError -> Bool fatal (WontCompile _) = False fatal (NotAllowed _) = False fatal _ = True -catchError_fixed - :: MonadError InterpreterError m +catchError_fixed+ :: MonadInterpreter m => m a -> (InterpreterError -> m a) -> m a-m `catchError_fixed` f = m `catchError` (f . fixError)+m `catchError_fixed` f = m `catch` (f . fixError) where fixError (UnknownError s) | Just x <- dropPrefix "GHC returned a result but said: [GhcError {errMsg =" s
Smart.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ViewPatterns, PatternGuards, OverloadedStrings #-}+{-# LANGUAGE ViewPatterns, PatternGuards #-} module Smart ( module Simple , startGHCiServer@@ -30,32 +30,29 @@ import Data.Data.GenRep.Functions (mistify, numberErrors) import Data.Data.GenRep.Doc (toDoc) -import Hoogle (Database, loadDatabase)--import Control.Monad (join) import Data.Dynamic hiding (typeOf) import qualified Data.Data as D-import Data.List (nub)+import Control.DeepSeq (force)+import Control.Monad (void)+import Control.Monad.Trans (liftIO) import Data.Char (isAlpha)---import Prelude hiding (catch)-+import Data.Maybe (catMaybes, maybe) ---------------------------------------------------------------------- data TaskChan = TC { logger :: Logger- , database :: Maybe Database -- for Hoogle searches+ , hoogledb :: Maybe FilePath -- for Hoogle searches , chan :: Simple.TaskChan } -startGHCiServer :: [FilePath] -> Logger -> FilePath -> IO TaskChan+startGHCiServer :: [FilePath] -> Logger -> Maybe FilePath -> IO TaskChan startGHCiServer searchpaths log dbname = do- db <- if (dbname == "") then return Nothing else fmap Just $ loadDatabase dbname ch <- Simple.startGHCiServer searchpaths log return $ TC { logger = log- , database = db+ , hoogledb = dbname , chan = ch } @@ -65,11 +62,11 @@ --------------- -showErr :: Language -> InterpreterError -> [String]-showErr lang (WontCompile l) = nub{-miért?? -} . map errMsg $ l-showErr lang (UnknownError s) = [ translate lang "Unknown error: " ++ s]-showErr lang (NotAllowed s) = [ translate lang "Not allowed: " ++ s]-showErr lang (GhcException s) = [ translate lang "GHC exception: " ++ s]+showErr :: Language -> InterpreterError -> String+showErr lang (WontCompile l) = unlines $ map errMsg l+showErr lang (UnknownError s) = translate lang "Unknown error: " ++ s+showErr lang (NotAllowed s) = translate lang "Not allowed: " ++ s+showErr lang (GhcException s) = translate lang "GHC exception: " ++ s ---------------------------------------------------------------------- @@ -88,71 +85,94 @@ interp :: Bool -> Hash -> Language -> TaskChan -> FilePath -> String - -> (String -> Interpreter (IO [Result])) -> IO [Result]-interp verboseinterpreter (show -> idi) lang ch fn s@(getCommand -> (c, a)) xy - = case c of-- "?" -> return $ query True (database ch) a-- "i" -> return $ queryInfo lang True (database ch) a-- c | c `elem` ["t","k",""]- -> join - $ fmap (either (return . map (Error True) . showErr lang) id)- $ sendToServer (chan ch) fn- $ case c of- "t" -> catchE True $ do- xx <- typeOf a- return $ return [ExprType False a xx []]- "k" -> catchE True $ do- xx <- kindOf a- return $ return [TypeKind a xx []]- "" -> fmap (fmap ((if verboseinterpreter then id else filterResults) . concat) . sequence) $ sequence- [ catchE False $ do- ty <- typeOf s- case specialize ty of- Left err -> return $ return [Error True err]- Right (ty',ty'') -> fmap (fmap concat . sequence) $ sequence- [ catchE False $ fmap (pprintData idi ty'') $- interpret ("wrapData (" ++ parens s ++ " :: " ++ ty'' ++")") (as :: WrapData)-- , catchE False $ fmap (pprint idi) $- interpret ("toDyn (" ++ parens s ++ " :: " ++ ty' ++")") (as :: Dynamic)+ -> Maybe (String -> Interpreter Result) -> IO Result+interp verboseinterpreter (show -> idi) lang ch fn s@(getCommand -> (cmd, arg)) extraStep+ = force <$> case cmd of - , return $ return [ExprType True s ty []]- ]+ "?" -> maybe (return $ noInfo arg) (\db -> query db arg) (hoogledb ch) - , catchE False $ do- k<- kindOf s- return $ return [TypeKind s k []]- , catchE True $ xy a- , return $ return $ query False (database ch) s- , return $ return $ queryInfo lang False (database ch) s- ]+ "i" -> maybe (return $ noInfo arg) (\db -> queryInfo lang db arg) (hoogledb ch) - _ -> return [Error True $ - translate lang "The" ++ " :" ++ c ++ " " ++ translate lang "command is not supported" ++ "."]+ c | c `elem` ["t","k",""]+ -> fmap (either (Error True . showErr lang) id)+ $ sendToServer (chan ch) fn+ $ case cmd of+ "t" ->+ do+ xx <- typeOf arg+ return $ ExprType False arg xx []+ `catchE`+ (return . Error True . showErr lang)+ "k" ->+ do + xx <- kindOf arg+ return $ TypeKind arg xx []+ `catchE`+ (return . Error True . showErr lang)+ "" ->+ do+ (typ, pprData, ppr) <- do+ ty <- typeOf s+ case specialize ty of+ Left err -> return (Error True err, Nothing, Nothing)+ Right (ty',ty'') -> do+ pprData <- do+ wd <- interpret ("wrapData (" ++ parens s ++ " :: " ++ ty'' ++")") (as :: WrapData)+ liftIO (pprintData idi ty'' wd)+ `catchE`+ (return . Just . Error False . showErr lang)+ ppr <- do+ dyn <- interpret ("toDyn (" ++ parens s ++ " :: " ++ ty' ++")") (as :: Dynamic)+ liftIO (pprint idi dyn)+ `catchE`+ (return . Just . Error False . showErr lang)+ return (ExprType True s ty [], pprData, ppr)+ `catchE`+ (\e -> return (Error False (showErr lang e), Nothing, Nothing))+ kind <- do+ k <- kindOf s+ return $ TypeKind s k []+ `catchE`+ (return . Error False . showErr lang)+ mExtraRes <- case extraStep of+ Nothing -> return Nothing+ Just step -> do+ extraRes <- step arg `catchE` (return . Error True . showErr lang)+ return $ Just extraRes+ mHooInfo <- case (hoogledb ch) of+ Nothing -> return Nothing+ Just db -> do+ hoo <- liftIO $ query db s+ hooInfo <- liftIO $ queryInfo lang db s+ return $ Just [hoo, hooInfo]+ let everyResult = catMaybes [mExtraRes, pprData, ppr] ++ maybe [] id mHooInfo ++ [typ, kind]+ case filterResults everyResult of+ [] -> return typ+ (res:_) -> return res+ _ -> return $ force $ Error True $ + translate lang "The" ++ " :" ++ cmd ++ " " ++ translate lang "command is not supported" ++ "." where+ catchE :: Interpreter a -> (InterpreterError -> Interpreter a) -> Interpreter a+ catchE = Simple.catchError_fixed - catchE b m - = m `Simple.catchError_fixed` \e -> - return $ return $ map (Error b) $ showErr lang e+ noInfo :: String -> Result+ noInfo query = Message (translate lang "No info for " ++ query) Nothing -------------------- -pprintData :: String -> String -> WrapData -> IO [Result]+pprintData :: String -> String -> WrapData -> IO (Maybe Result) pprintData idi y (WrapData x)- | D.dataTypeName (D.dataTypeOf x) == "Diagram"- = return []-pprintData idi y (WrapData x) = do- a <- C.eval 1 700 x- let ([p], es) = numberErrors [a]- return $ [ExprType False (show $ toDoc p) y es]+ | D.dataTypeName (D.dataTypeOf x) == "Diagram" =+ return Nothing+ | otherwise = do+ a <- C.eval 1 700 x+ let ([p], es) = numberErrors [a]+ return . Just $ ExprType False (show $ toDoc p) y es -pprint :: String -> Dynamic -> IO [Result]+pprint :: String -> Dynamic -> IO (Maybe Result) pprint idi d | Just x <- fromDynamic d = ff x | Just x <- fromDynamic d = ff $ showFunc (x :: Double -> Double)@@ -165,10 +185,10 @@ | Just x <- fromDynamic d = ff $ showFunc_ $ fromIntegral . fromEnum . (x :: Integer -> Ordering) | Just x <- fromDynamic d = ff $ displayArc' (x :: Double -> (Double, Double)) | Just (f,g) <- fromDynamic d = ff $ displayArc' ((\x -> (f x, g x)) :: Double -> (Double, Double))- | otherwise = return []+ | otherwise = return Nothing where- ff = fmap g . render 10 (-16, -10) (16, 10) 0.5 1000 idi- g (htm, err) = [Dia htm err]+ ff = fmap g . render 10 (-16, -10) (16, 10) 5 2048 idi+ g (htm, err) = Just (Dia htm err) showFunc :: (RealFrac a, Real b) => (a -> b) -> Diagram showFunc = displayFun (-16,-10) (16,10) showFunc_ :: (Real b, Integral a) => (a -> b) -> Diagram@@ -182,33 +202,33 @@ ---------------- -compareMistGen :: Language -> String -> WrapData2 -> String -> IO [Result]+compareMistGen :: Language -> String -> WrapData2 -> String -> IO Result compareMistGen lang idi (WrapData2 x y) goodsol | D.dataTypeName (D.dataTypeOf x) == "Diagram" - = return [Message (translate lang "Can't decide the equality of diagrams (yet).") Nothing]+ = return $ Message (translate lang "Can't decide the equality of diagrams (yet).") Nothing compareMistGen lang idi (WrapData2 x y) goodsol = do (ans, a', b') <- C.compareData 0.8 0.2 700 x y return $ case ans of- C.Yes -> [ Message (translate lang "Good solution! Another good solution:")- $ Just $ ExprType False goodsol "" []]+ C.Yes -> Message (translate lang "Good solution! Another good solution:")+ $ Just $ ExprType False goodsol "" [] _ -> let x = case ans of C.Maybe _ -> "I cannot decide whether this is a good solution:" C.No -> "Wrong solution:"- in [Message (translate lang x) $ Just $ showPair ans (a', mistify b')]+ in Message (translate lang x) $ Just $ showPair ans (a', mistify b') --------------------------------- -compareClearGen :: Language -> String -> WrapData2 -> IO [Result]+compareClearGen :: Language -> String -> WrapData2 -> IO Result compareClearGen lang idi (WrapData2 x y) | D.dataTypeName (D.dataTypeOf x) == "Diagram"- = return [Message (translate lang "Can't decide the equality of diagrams (yet).") Nothing]+ = return $ Message (translate lang "Can't decide the equality of diagrams (yet).") Nothing compareClearGen lang idi (WrapData2 x y) = do (ans, a', b') <- C.compareData 0.8 0.2 700 x y return $ case ans of -- C.Yes -> []- _ -> [showPair ans (a', b')]+ _ -> showPair ans (a', b') showPair :: C.Answer -> (GenericData, GenericData) -> Result
Special.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, PatternGuards, NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, PatternGuards, NamedFieldPuns, CPP #-} module Special ( SpecialTask (..), exerciseServer'@@ -17,6 +17,7 @@ import qualified Data.Text as T import qualified Data.Text.IO as T+import Text.XHtml.Strict ((+++)) import Control.DeepSeq import Control.Concurrent.MVar@@ -25,8 +26,10 @@ import System.Directory (getTemporaryDirectory) import Control.Concurrent (threadDelay, forkIO, killThread)---import Prelude hiding (catch)-+import Control.Monad.Trans (liftIO)+#if !MIN_VERSION_base(4,6,0)+import Prelude hiding (catch)+#endif --------------------------------------------------------------- @@ -57,46 +60,54 @@ -> Language -> Hash -> SpecialTask- -> IO [Result]+ -> IO Html exerciseServer' qualifier ch verbose fn sol lang m5 task = do- let error = do logStrMsg 0 (logger ch) $ "Server error:" ++ show m5- return [Error True "Server error."]+ return $ renderResult $ Error True "Server error." - action =- do res <- eval task- res `deepseq` return res- `catch` \(e :: SomeException) -> -- ???- return [Error True $ show e]+ action = eval task `catch` \(e :: SomeException) -> -- ???+ return $ renderResult $ Error True $ show e timeout (10*1000000) error action where eval Eval- = interp verbose m5 lang ch fn (T.unpack sol) $ \a -> return $ return []+ = renderResult <$> interp verbose m5 lang ch fn (T.unpack sol) Nothing eval (Compare hiddenname goodsol)- = interp verbose m5 lang ch fn (T.unpack sol) $ \a ->- do x <- interpret (wrap2 a hiddenname) (as :: WrapData2)- return $ compareMistGen lang (show m5) x $ goodsol+ = do+ res <- interp verbose m5 lang ch fn (T.unpack sol) $ Just $ \a -> do+ x <- interpret (wrap2 a hiddenname) (as :: WrapData2)+ liftIO $ compareMistGen lang (show m5) x $ goodsol+ return $ renderResult res eval (Compare2 env funnames s) = do fn' <- tmpSaveHs "hs" (show m5) $ env `T.append` sol case qualify qualifier funnames s of- Left err -> return [Error True err]- Right s2 -> interp verbose m5 lang ch fn' s $ \a ->- fmap (compareClearGen lang (show m5)) $ interpret (wrap2 a s2) (as :: WrapData2)+ Left err -> return $ renderResult (Error True err)+ Right s2 -> do+ res <- interp verbose m5 lang ch fn' s $ Just $ \a -> do+ result <- interpret (wrap2 a s2) (as :: WrapData2)+ liftIO $ compareClearGen lang (show m5) result+ return $ renderResult res eval (Check ext sourcedirs env funnames is i j) = do fn' <- tmpSaveHs ext (show m5) $ env `T.append` sol case ext of "hs" -> do ss <- quickCheck qualifier m5 lang ch fn' (T.unpack sol) funnames is- let ht = head $ [x | ModifyCommandLine x <- ss] ++ [""]- return [ShowInterpreter lang 59 (getTwo "eval2" (takeFileName fn) j i j) j 'E' ht ss]+ case ss of+ ShowFailedTestCase testcase reason ->+ return . indent . renderResult $ ShowInterpreter lang 59 (getTwo "eval2" (takeFileName fn) j i j) j 'E' testcase (Just reason)+ Message _ _ ->+ return . indent $+ renderResult ss+ +++ (renderResult (ShowInterpreter lang 59 (getTwo "eval2" (takeFileName fn) j i j) j 'E' "" Nothing))+ _ ->+ return . indent $ renderResult ss tmpSaveHs :: String -> String -> T.Text -> IO FilePath tmpSaveHs ext x s = do
Specialize.hs view
@@ -15,7 +15,7 @@ specialize :: String -> Either String (String, String) specialize a- = case parseTypeWithMode (defaultParseMode {extensions = [FlexibleContexts]}) a of+ = case parseTypeWithMode (defaultParseMode {extensions = [EnableExtension FlexibleContexts]}) a of ParseFailed loc s -> Left $ show s ParseOk t -> let
activehs.cabal view
@@ -1,14 +1,14 @@ name: activehs-version: 0.3.1+version: 0.3.2 category: Education, Documentation synopsis: Haskell code presentation tool description: ActiveHs is a Haskell source code presentation tool, developed for education purposes. .- User's Guide: <http://pnyf.inf.elte.hu:8000/UsersGuide_en.xml>+ User's Guide: <http://lambda.inf.elte.hu/fp/UsersGuide_en.xml> .- Developer's Documentation (partial): <http://pnyf.inf.elte.hu:8000/DevDoc_en.xml>+ Developer's Documentation (partial): <http://lambda.inf.elte.hu/fp/DevDoc_en.xml> . The software is in prototype phase, although it already served more than 700 000 user requests at Eötvös Loránd University Budapest, Hungary.@@ -19,9 +19,10 @@ license: BSD3 license-file: LICENSE author: Péter Diviánszky-maintainer: divip@aszt.inf.elte.hu+maintainer: Artúr Poór <gombocarti@gmail.com> cabal-version: >=1.6 build-type: Simple+ data-files: copy/*.css, copy/*.js, @@ -31,8 +32,17 @@ doc/DevDoc_en.lhs, doc/watchserver.sh +source-repository head+ type: git+ location: https://github.com/poor-a/ActiveHs++source-repository this+ type: git+ location: https://github.com/poor-a/ActiveHs/tree/0.3.2+ tag: 0.3.2+ Executable activehs- GHC-Options: -threaded -rtsopts -Wall -fwarn-tabs -fno-warn-incomplete-patterns -fno-warn-type-defaults -fno-warn-unused-matches -fno-warn-name-shadowing+ GHC-Options: -threaded -rtsopts -with-rtsopts=-N2 -Wall -fwarn-tabs -fwarn-monomorphism-restriction -fwarn-missing-import-lists Main-is: Main.hs Other-modules:@@ -56,37 +66,39 @@ Special Build-Depends:- highlighting-kate >= 0.5 && < 0.6,- hoogle >= 4.2.11 && < 4.3,+ highlighting-kate >= 0.5 && < 0.7,+ hoogle >= 5.0 && < 5.1, dia-base >= 0.1 && < 0.2, dia-functions >= 0.2.1.1 && < 0.3, activehs-base >= 0.2 && < 0.4, data-pprint >= 0.2 && < 0.3,- base >= 4.0 && < 4.7,- QuickCheck >= 2.4 && < 2.6,- array >= 0.3 && < 0.5,+ base >= 4.0 && < 5.0,+ QuickCheck >= 2.4 && < 2.9,+ array >= 0.3 && < 0.6, directory >= 1.1 && < 1.3, containers >= 0.4 && < 0.6,- filepath >= 1.2 && < 1.4,- text >= 0.11 && < 0.12,- snap-core >= 0.6 && < 0.10,- snap-server >= 0.6 && < 0.10,- syb >= 0.2 && < 0.4,- haskell-src-exts >= 1.12 && < 1.14,+ filepath >= 1.2 && < 1.5,+ text >= 1.1 && < 1.3,+ snap-core >= 1.0 && < 1.1,+ snap-server >= 1.0 && < 1.1,+ syb >= 0.6 && < 0.7,+ haskell-src-exts >= 1.17 && < 1.18, bytestring >= 0.9 && < 0.11,- utf8-string >= 0.3 && < 0.4,+ utf8-string >= 0.3 && < 1.1, xhtml >= 3000.2 && < 3000.3,- blaze-html >= 0.4 && < 0.6,+ blaze-html >= 0.6 && < 0.9,+ blaze-markup >= 0.6 && < 0.8, pureMD5 >= 2.1 && < 2.2,- deepseq >= 1.1 && < 1.4,+ deepseq >= 1.1 && < 1.5,+ exceptions >= 0.6 && < 0.9, split >= 0.1 && < 0.3,- pandoc >= 1.10 && < 1.11,- time >= 1.2 && < 1.5,+ pandoc >= 1.17 && < 1.18,+ time >= 1.6 && < 1.7, old-time >= 1.0 && < 1.2,- process >= 1.0 && < 1.2,- hint >= 0.3.3.2 && < 0.4,+ process >= 1.4 && < 1.5,+ hint >= 0.6 && < 0.7, simple-reflect >= 0.2 && < 0.4,- mtl >= 2.0 && < 2.2,+ mtl >= 2.0 && < 2.3, old-locale >= 1.0 && < 1.1, cmdargs >= 0.7 && < 0.11
copy/common.css view
@@ -50,20 +50,21 @@ width: 95%; } -div.indent, pre {+pre { margin-top: 0.5em; margin-bottom: 0.5em; } +form[class$="interpreter"] {+ margin-top: 0.5em;+ margin-bottom: 0.5em;+}+ pre.normal { margin: 0; width: auto; } --div.indent input {- margin-bottom: 0.5em;-} input, textarea { margin: 0;