activehs (empty) → 0.2
raw patch · 27 files changed
+3643/−0 lines, 27 filesdep +QuickCheckdep +activehs-basedep +arraysetup-changedbinary-added
Dependencies added: QuickCheck, activehs-base, array, base, bytestring, cmdargs, containers, data-pprint, deepseq, dia-base, dia-functions, directory, filepath, haskell-src-exts, hint, hoogle, mtl, old-locale, old-time, pandoc, process, pureMD5, simple-reflect, snap-core, snap-server, split, syb, text, time, utf8-string, xhtml
Files
- Args.hs +88/−0
- Cache.hs +70/−0
- Converter.hs +273/−0
- HoogleCustom.hs +43/−0
- Html.hs +161/−0
- LICENSE +31/−0
- Lang.hs +44/−0
- Main.hs +152/−0
- Parse.hs +213/−0
- Qualify.hs +67/−0
- QuickCheck.hs +82/−0
- Result.hs +78/−0
- Setup.hs +2/−0
- Simple.hs +108/−0
- Smart.hs +238/−0
- Special.hs +110/−0
- Specialize.hs +67/−0
- activehs.cabal +92/−0
- copy/common.css +205/−0
- copy/common_en.js +357/−0
- copy/common_hu.js +357/−0
- copy/icon.ico binary
- doc/DevDoc_en.lhs +244/−0
- doc/UsersGuide_en.lhs +475/−0
- doc/watchserver.sh +46/−0
- template/en.template +20/−0
- template/hu.template +20/−0
+ Args.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DeriveDataTypeable, NamedFieldPuns #-}+module Args where++import Paths_activehs++import System.Directory (createDirectoryIfMissing)+import System.Console.CmdArgs.Implicit+import System.FilePath++------------------++data Args+ = Args+ { sourcedir :: String+ , gendir :: String+ , exercisedir :: String+ , templatedir :: String+ , fileservedir :: String+ , logdir :: String++ , hoogledb :: String++ , mainpage :: String+ , restartpath :: String++ , port :: Int+ , lang :: String+ , static :: Bool+ , verbose :: Bool+ , verboseinterpreter :: Bool+ , recompilecmd :: String+ , magicname :: String+ }+ deriving (Show, Data, Typeable)++myargs :: Args+myargs = Args+ { sourcedir = "." &= typDir &= help "Directory of lhs files to serve. Default is '.'"+ , gendir = "html" &= typDir &= help "Directory to put generated content to serve. Default is 'html'"+ , exercisedir = "exercise" &= typDir &= help "Directory to put generated exercises to serve. Default is 'exercise'"+ , templatedir = "" &= typDir &= help "Directory of html template files for pandoc. Default points to the distribution's directory."+ , 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"++ , mainpage = "Index.xml" &= typ "PATH" &= help "Main web page path"+ , restartpath = "" &= typ "PATH" &= help "Opening this path in browser restarts the ghci server."++ , lang = "en" &= typ "LANGUAGE" &= help "Default language. It is 'en' by default."+ , port = 8000 &= typ "PORT" &= help "Port to listen"+ , static = False &= help "Do not regenerate pages."+ , verbose = False &= help "Verbose activehs output"+ , verboseinterpreter = False &= help "Verbose interpreter output in the browser"+ , recompilecmd = "ghc -O" &= typ "COMMAND" &= help "Command to run before page generation. Default is 'ghc -O'."+ , magicname = "a9xYf" &= typ "VARNAME" &= help "Magic variable name."+ } &= summary "activehs 0.2, (C) 2010-2011 Péter Diviánszky"+ &= program "activehs"++completeArgs :: Args -> IO Args+completeArgs args+-- | gendir args == "" = completeArgs (args {gendir = root args </> "html"})+-- | exercisedir args == "" = completeArgs (args {exercisedir = root args </> "exercise"})+ | templatedir args == "" = do+ dir <- getDataDir+ completeArgs (args {templatedir = dir </> "template"})+ | fileservedir args == "" = do+ dir <- getDataDir+ completeArgs (args {fileservedir = dir </> "copy"})+completeArgs args = return args+++createDirs :: Args -> IO ()+createDirs (Args {sourcedir, gendir, exercisedir, logdir}) + = mapM_ f [sourcedir, gendir, exercisedir, logdir]+ where+ f "" = return ()+ f path = createDirectoryIfMissing True path+++getArgs :: IO Args+getArgs = do+ args <- cmdArgs myargs >>= completeArgs+ createDirs args+ return args+++
+ Cache.hs view
@@ -0,0 +1,70 @@+-- | A very simple cache+module Cache+ ( Cache+ , newCache+ , lookupCache+ , clearCache+ ) where++import Data.Digest.Pure.MD5 (MD5Digest)++import Control.Concurrent.MVar (MVar, newEmptyMVar, readMVar, putMVar)+import Data.Array.IO (IOArray, newArray, readArray, writeArray, getBounds)+import Data.Char (digitToInt)++-------------------------++data Cache a + = Cache+ { array :: IOArray Int [CacheEntry a]+ , cacheLineSize :: Int -- length of the lists+ }++data CacheEntry a+ = CacheEntry + { question :: MD5Digest+ , answer :: MVar a+ }+++newCache :: Int -> IO (Cache a)+newCache x = do+ a <- newArray (0,255) []+ return $ Cache a x+++clearCache :: Cache a -> IO ()+clearCache c = do+ (a,b) <- getBounds $ array c+ mapM_ (\i -> writeArray (array c) i []) [a..b]+++lookupCache :: Cache a -> MD5Digest -> IO (Either a (a -> IO ()))+lookupCache ch e = modifyCacheLine (array ch) (getIndex e) $ \vv ->+ case lookupIA (cacheLineSize ch) (\x -> e == question x) vv of+ (Just x_, c) -> do+ x <- readMVar (answer x_)+ return (x_ : c, Left x)+ (Nothing, c) -> do+ v <- newEmptyMVar+ return (CacheEntry e v: c, Right $ putMVar v)+ where+ lookupIA :: Int -> (a -> Bool) -> [a] -> (Maybe a, [a])+ lookupIA i p l = f i l where+ f _ (x: xs) | p x = (Just x, xs)+ f 1 _ = (Nothing, [])+ f i (x: xs) = case f (i-1) xs of+ (a, b) -> (a, x:b)+ f _ [] = (Nothing, [])++ modifyCacheLine ch i f = do+ x <- readArray ch i+ (x', r) <- f x+ writeArray ch i x'+ return r++ getIndex :: MD5Digest -> Int+ getIndex e = 16 * digitToInt a + digitToInt b where (a:b:_) = show e+++
+ Converter.hs view
@@ -0,0 +1,273 @@+{-# LANGUAGE PatternGuards, ViewPatterns, NamedFieldPuns #-}++module Converter+ ( convert+ ) where++import Parse++import Smart (TaskChan, restart, mkId, interp)+import Result (hasError)+import Html+import Lang+import Args++import Language.Haskell.Exts.Pretty+import Language.Haskell.Exts.Syntax++import Text.XHtml.Strict hiding (lang)+import Text.Pandoc++import System.Process (readProcessWithExitCode)+import System.Cmd+import System.FilePath+import System.Exit+import System.Directory (getTemporaryDirectory, getModificationTime, doesFileExist, getTemporaryDirectory, createDirectoryIfMissing)+import System.Time (diffClockTimes, noTimeDiff) ++import Control.Monad+import Data.List++----------------------------------++convert :: TaskChan -> Args -> String -> IO ()+convert ghci args@(Args {magicname, sourcedir, gendir, recompilecmd, verbose}) what = do+ whenOutOfDate () output input $ do+ whenOutOfDate () object input $ do+ when verbose $ putStrLn $ object ++ " is out of date, regenerating"+-- x <- system $ recompilecmd ++ " " ++ input+ let (ghc:args) = words recompilecmd -- !!!+ (x, out, err) <- readProcessWithExitCode ghc (args ++ [input]) ""+ if x == ExitSuccess + then do+ restart ghci+ return ()+ else fail $ unlines [unwords [recompilecmd, input], show x, out, err]+ when verbose $ putStrLn $ output ++ " is out of date, regenerating"+ mainParse False input >>= extract verbose ghci args what+ whenOutOfDate () output input2 $ do+ when verbose $ putStrLn $ output ++ " is out of date, regenerating"+ mainParse True input2 >>= extract verbose ghci args what+-- return True+ where+ input = sourcedir </> what <.> "lhs"+ input2 = sourcedir </> what <.> "lagda"+ output = gendir </> what <.> "xml"+ object = sourcedir </> what <.> "o"+++extract :: Bool -> TaskChan -> Args -> Language -> Doc -> IO ()+extract verbose ghci (Args {lang, templatedir, sourcedir, exercisedir, gendir, magicname}) what (Doc meta modu ss) = do++ writeEx (what <.> "hs") [showEnv $ importsHiding []]+ ss' <- zipWithM processBlock [1..] $ preprocessForSlides ss+ ht <- readFile' $ templatedir </> lang' ++ ".template"++ writeFile' (gendir </> what <.> "xml") $ flip writeHtmlString (Pandoc meta $ concat ss')+ $ defaultWriterOptions+ { writerStandalone = True+ , writerTableOfContents = True+ , writerSectionDivs = True+ , writerTemplate = ht+ }++ where+ lang' = case span (/= '_') . reverse $ what of+ (l, "") -> lang+ (l, _) | length l > 2 -> lang+ (x, _) -> reverse x++ writeEx f l =+ writeFile' (exercisedir </> f) $ intercalate delim l++ writeFile' f s = do+ when verbose $ putStrLn $ f ++ " is written."+ createDirectoryIfMissing True (dropFileName f)+ writeFile f s++ readFile' f = do+ when verbose $ putStrLn $ f ++ " is to read..."+ readFile f++ system' s = do+ when verbose $ putStrLn $ "executing " ++ s+ system s++ importsHiding funnames+ = prettyPrint $ + Module loc (ModuleName "Main") directives Nothing Nothing+ ([mkImport modname funnames, mkImport_ ('X':magicname) modname] ++ imps) []+ where+ (Module loc (ModuleName modname) directives _ _ imps _) = modu++ mkCodeBlock l =+ [ CodeBlock ("", ["haskell"], []) $ intercalate "\n" l | not $ null l ]++----------------------------++ processBlock :: Int -> BBlock -> IO [Block]++ processBlock _ (Exercise visihidden _ _ funnames is)+ | null funnames || null is+ = return $ mkCodeBlock $ visihidden++ processBlock _ (Exercise _ visi hidden funnames is) = do+ let i = show $ mkId $ unlines $ map printName funnames+ j = "_j" ++ i+ fn = what ++ "_" ++ i <.> "hs"+ (static_, inForm, rows) = if null hidden+ then ([], visi, length visi) + else (visi, [], 2 + length hidden)++ writeEx fn [ showEnv $ importsHiding funnames ++ "\n" ++ unlines static_+ , unlines $ hidden, show $ map parseQuickCheck is, j, i+ , show $ map printName funnames ]+ return+ $ mkCodeBlock static_+ ++ showBlockSimple lang' fn i rows (intercalate "\n" inForm)++ processBlock ii (OneLineExercise 'H' erroneous exp) + = return []+ processBlock ii (OneLineExercise p erroneous exp) = do+ let m5 = mkId $ show ii ++ exp+ i = show m5+ fn = what ++ (if p == 'R' then "_" ++ i else "") <.> "hs"+ act = getOne "eval" fn i i++ when (p == 'R') $ writeEx fn [showEnv $ importsHiding [], "\n" ++ magicname ++ " = " ++ exp]+ (b, exp') <- if p == 'F' && all (==' ') exp + then return (True, [])+ 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']++ processBlock _ (Text (CodeBlock ("",[t],[]) l)) + | t `elem` ["dot","neato","twopi","circo","fdp","dfdp","latex"] = do+ tmpdir <- getTemporaryDirectory+ let i = show $ mkId $ t ++ l+ fn = what ++ i+ imgname = takeFileName fn <.> "png"+ outfile = gendir </> fn <.> "png"+ tmpfile = tmpdir </> takeFileName fn <.> if t=="latex" then "tex" else t++ writeFile' tmpfile $ unlines $ case t of+ "latex" -> + [ "\\documentclass{article}"+ , "\\usepackage{ucs}"+ , "\\usepackage[utf8x]{inputenc}"+ , "\\usepackage{amsmath}"+ , "\\pagestyle{empty}"+ -- , "\\newcommand{\\cfrac}[2]{\\displaystyle\\frac{#1}{#2}}"+ , "\\begin{document}"+ , "$$", l, "$$"+ , "\\end{document}" ]+ _ ->+ ["digraph G {", l, "}"]++ createDirectoryIfMissing True (dropFileName outfile)++ x <- system' $ unwords $ case t of+ "latex" -> [ "(", "cd", dropFileName tmpfile, "&&"+ , "latex -halt-on-error", takeFileName tmpfile, "2>&1 >/dev/null", ")"+ , "&&", "(", "dvipng -D 150 -T tight", "-o", outfile+ , replaceExtension tmpfile "dvi", "2>&1 >/dev/null",")"]+ _ -> [ t, "-Tpng", "-o", outfile, tmpfile, "2>&1 >/dev/null" ]++ if x == ExitSuccess + then return [Para [Image [Str imgname] (imgname, "")]]+ else fail $ "processDot " ++ tmpfile ++ "; " ++ show x++ processBlock _ (Text l)+ = return [l]+++---------------------------------++preprocessForSlides :: [BBlock] -> [BBlock]+preprocessForSlides x = case span (not . isLim) x of+ (a, []) -> a+ (a, b) -> a ++ case span (not . isHeader) b of+ (c, d) -> [Text $ rawHtml "<div class=\"handout\">"] ++ c + ++ [Text $ rawHtml "</div>"] ++ preprocessForSlides d+ where+ isLim (Text HorizontalRule) = True+ isLim _ = False++ isHeader (Text (Header _ _)) = True+ isHeader _ = False++------------------------------------++rawHtml :: String -> Block+rawHtml x = RawBlock "html" x++showBlockSimple :: Language -> String -> String -> Int -> String -> [Block]++showBlockSimple lang fn i rows_ cont = (:[]) $ rawHtml $ showHtmlFragment $ indent $+ [ form+ ! [ theclass $ if null cont then "interpreter" else "resetinterpreter"+ , action $ getOne "check" fn i i+ ]+ <<[ textarea + ! [ cols "80"+ , rows $ show rows_+ , identifier $ "tarea" ++ i+ ]+ << cont+ , br+ , input ! [thetype "submit", value $ translate lang "Check"]+ ]+ , thediv ! [theclass "answer", identifier $ "res" ++ i] << ""+ ]++-----------------++showEnv :: String -> String+showEnv prelude+ = "{-# LINE 1 \"testenv\" #-}\n"+ ++ prelude+ ++ "\n{-# LINE 1 \"input\" #-}\n"++mkImport :: String -> [Name] -> ImportDecl+mkImport m d + = ImportDecl+ { importLoc = undefined+ , importModule = ModuleName m+ , importQualified = False+ , importSrc = False+ , importPkg = Nothing+ , importAs = Nothing+ , importSpecs = Just (True, map IVar d)+ }++mkImport_ :: String -> String -> ImportDecl+mkImport_ magic m + = (mkImport m []) { importQualified = True, importAs = Just $ ModuleName magic }++------------------++whenOutOfDate :: b -> FilePath -> FilePath -> IO b -> IO b+whenOutOfDate def x src m = do+ a <- modTime x+ b <- modTime src+ case (a, b) of+ (Nothing, Just _) -> m+ (Just t1, Just t2) | diffClockTimes t2 t1 > noTimeDiff -> m+ _ -> return def+ where+ modTime f = do+ a <- doesFileExist f+ if a then fmap Just $ getModificationTime f else return Nothing+++--------------------+++
+ HoogleCustom.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+module HoogleCustom+ ( query+ , queryInfo+ ) where++import Result+import Lang++import Hoogle hiding (Language, Result)+import qualified Hoogle++import Data.List (nub)++-------------------------++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)]++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]++search' :: Maybe Database -> Query -> [(Score, Hoogle.Result)]+search' ch q + = case ch of+ Nothing -> []+ Just db -> search db q++format :: [TagStr] -> [Result]+format [] = []+format r = [SearchResults (not $ null b) (map showTagHTML a)]+ where+ (a, b) = splitAt 10 r++
+ Html.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE OverloadedStrings #-}+module Html + ( Html+ , renderResult+ , renderResults+ , renderResults_+ , showInterpreter+ , indent, delim, getOne, getTwo+ ) where++import Result+import Lang+import Data.Data.Compare++import Text.XHtml.Strict+import qualified Data.Text as T++---------------------++renderResults :: [Result] -> T.Text+renderResults + = T.intercalate " " . T.splitOn " " + . T.pack + . showHtmlFragment + . renderResults_++renderResults_ :: [Result] -> Html+renderResults_+ = foldr (|-|) noHtml + . map renderResult++renderResult :: Result -> Html+renderResult (ExprType _ e t err) + = showRes e "::" t $ map mkBott err+renderResult (TypeKind e t err) + = showRes e "::" t $ map mkBott err+renderResult (SearchResults b l)+ = foldr (|-|) noHtml $ map (showCode_ "search") l ++ [toHtml ("..." :: String) | b]+renderResult (Error _ s) + = showRes "" "" "" [showLines s]+renderResult (Message s r) + = 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 _)+ = noHtml+renderResult (ShowInterpreter lang limit act i prompt exp res)+ = showInterpreter lang limit act i prompt exp res++(|-|) :: Html -> Html -> Html+a |-| b | isNoHtml a || isNoHtml b = a +++ b+a |-| b = a +++ br +++ b++showCode :: String -> String -> Html+showCode c x + | isNoHtml x' = x'+ | null c = f $ thecode << x'+ | otherwise = f $ thecode ! [theclass c] << x'+ where+ x' = toHtml x+ f y | elem '\n' x = pre ! [theclass "normal"] << y+ | otherwise = y++showCode_ :: String -> String -> Html+showCode_ c x + = thecode ! [theclass c] << primHtml x++showRes :: String -> String -> String -> [Html] -> Html+showRes e x b err+ = showResErr (p1+ +++ showCode "" (if null x || isNoHtml p1 || isNoHtml p2 then "" else " " ++ x ++ " ")+ +++ p2+ +++ showCode "comment" (if null c then c else " --" ++ c))+ err+ where+ p1 = showCode "result" a+ p2 = showCode (if x == "::" then "type" else "result") b+ (a, c) = splitComment e++showResErr :: Html -> [Html] -> Html+showResErr r err = r |-| me err+ where+ me [] = noHtml+ me x = thediv ! [theclass "error"] << foldr (|-|) noHtml err++showLines :: String -> Html+showLines e + | elem '\n' e = pre ! [theclass "normal"] << toHtml e+ | otherwise = toHtml e++mkBott :: (String, String) -> Html+mkBott (i, e) = toHtml (" " ++ i ++ ": ") +++ showLines e++splitComment :: String -> (String, String)+splitComment x = case splitComment' x of+ Just (a,b) -> (a, b)+ _ -> (x, "")++splitComment' :: String -> Maybe (String, String)+splitComment' a = f [] a where++ f ac ('-':'-':c) | isComment c = Just (reverse $ dropWhile (==' ') ac, c) -- !!!+ f ac ('"':cs) = uncurry f $ skipString ('"':ac) cs+ f ac (c:cs) = f (c:ac) cs+ f ac [] = Nothing++ isComment ('-':c) = isComment c+ isComment (d:_) | isSymbol d = False+ isComment _ = True++ isSymbol d = False --- !!!++ skipString a ('"':cs) = ('"':a, cs)+ skipString a ('\\':'\\':cs) = skipString ('\\':'\\':a) cs+ skipString a ('\\':'"':cs) = skipString ('"':'\\':a) cs+ skipString a (c:cs) = skipString (c:a) cs+ skipString a [] = (a, [])+++showInterpreter :: Language -> Int -> String -> String{-Id-} -> Char -> String -> [Result] -> Html+showInterpreter lang limit act i prompt exp res = indent $+ form+ ! [ theclass $ if prompt == 'R' || null exp then "interpreter" else "resetinterpreter"+ , action act ]+ << (onlyIf (prompt /= 'A')+ [ thecode ! [theclass "prompt"] << (translate lang (if prompt /= 'R' then "Test" else "Solution") ++ "> ")+ , input + ! [ theclass "interpreter"+ , thetype "text"+ , size $ show limit+ , maxlength 1000+ , identifier $ "tarea" ++ i+ , value $ if prompt == 'R' then "" else exp+ ]+ , br+ ] +++ [ thediv+ ! [ theclass "answer"+ , identifier $ "res" ++ i+ ] << if prompt `notElem` ['R', 'F'] then renderResults_ res else noHtml+ ])++onlyIf :: Bool -> [a] -> [a]+onlyIf True l = l+onlyIf _ _ = []++indent :: HTML a => a -> Html+indent x = thediv ! [ theclass "indent" ] << x++delim :: String+delim = "-----"++getOne :: String -> String -> String -> String -> String+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, "');"]++
+ LICENSE view
@@ -0,0 +1,31 @@+Copyright Péter Diviánszky 2010-2011++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Péter Diviánszky nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+
+ Lang.hs view
@@ -0,0 +1,44 @@++module Lang + ( Language+ , translate+ ) where++import Data.List (elemIndex)++------------++type Language = String -- "en", "hu"++translate :: Language -> String -> String+translate lang txt = + head $ [txts !! i | txts <- tail langTable, head txts == txt] ++ [txt]+ where+ i = maybe 0 id $ elemIndex lang (head langTable)++langTable :: [[String]]+langTable =+ [ ["en", "hu"]+ , ["Erroneous evaluation", "Hibás kiértékelés"]+ , ["Test", "Teszt"]+ , ["Solution", "Megoldás"]+ , ["Check", "Ellenőrzés"]+ , ["The", "A"]+ , ["command is not supported", "parancs itt nem támogatott"]+ , ["Erroneous solution", "Hibás megoldás"]+ , ["Interrupted evaluation.", "Félbehagyott kiértékelés."]+ , ["Inconsistency between server and client. Try to reload the page.", "Inkonzisztencia a kliens és a szerver között. Próbáld meg újratölteni az oldalt!"]+ , ["The site is overloaded.", "Az oldal leterhelt."]+ , ["Too long request.", "Túl hosszú kérés."]+ , ["Inconsistency between server and client.", "Inkonzisztencia a kliens és a szerver között."]+ , ["All test cases are completed.", "Minden általam ismert tesztesetnek megfelelt!"]+ , ["Good solution! Another good solution:", "Jó megoldás! Szintén helyes megoldás:"]+ , ["I cannot decide whether this is a good solution:", "Nem tudom eldönteni, hogy jó megoldás-e:"]+ , ["Wrong solution:", "Nem jó megoldás:"]+ , ["Unknown error: ", "Ismeretlen hiba: "]+ , ["Not allowed: ", "Nem engedélyezett: "]+ , ["GHC exception: ", "GHC kivétel: "]+ , ["Can't decide the equality of diagrams (yet).", "Lehet hogy jó, sajnos nem tudom az ábrák egyezőségét ellenőrizni (most még)."]+ , ["No info for ", "Nincs erről információ: "]+ ]+
+ Main.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE OverloadedStrings, ViewPatterns, NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, PatternGuards, NamedFieldPuns #-}++module Main where++import Smart+import Cache+import Converter+import Args+import Special+import Lang+import Result+import Html++import Snap.Types+import Snap.Http.Server (httpServe)+import Snap.Http.Server.Config+import Snap.Util.FileServe (getSafePath, serveDirectoryWith, simpleDirectoryConfig)++import Data.Digest.Pure.MD5 (md5)+import System.FastLogger++import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Data.ByteString (ByteString)+import Data.ByteString.UTF8 (fromString)+import qualified Data.ByteString.Lazy.UTF8 as Lazy++import System.FilePath ((</>), takeExtension, dropExtension)+import System.Directory (doesFileExist)+import Language.Haskell.Interpreter (liftIO)+import Control.Concurrent (threadDelay)+import Control.Monad (when)+import Control.Applicative ((<|>))+import Data.Time (getCurrentTime, diffUTCTime)+import Data.Maybe (listToMaybe)+import Prelude hiding (catch)++---------------------------------------------------------------++main :: IO ()+main = getArgs >>= mainWithArgs++mainWithArgs :: Args -> IO ()+mainWithArgs args@(Args {port, static, logdir, hoogledb, fileservedir, gendir, mainpage, restartpath, sourcedir}) = do ++ ch <- startGHCiServer [sourcedir] (logdir </> "interpreter") hoogledb+ cache <- newCache 10++ httpServe++ ( setPort port+ . setAccessLog (if null logdir then Nothing else Just (logdir </> "access.log"))+ . setErrorLog (if null logdir then Nothing else Just (logdir </> "error.log"))+ $ emptyConfig+ )++ ( method GET+ ( serveDirectoryWith simpleDirectoryConfig fileservedir+ <|> serveHtml ch+ <|> ifTop (redirect $ fromString mainpage)+ <|> path (fromString restartpath) (liftIO $ restart ch >> clearCache cache)+ )+ <|> method POST (exerciseServer (cache, ch) args)+ <|> notFound+ )+ where+ serveHtml ch = do+ p <- getSafePath+ when (not static && takeExtension p `elem` [".xml"]) $ liftIO $+ convert ch args $ dropExtension p+ serveDirectoryWith simpleDirectoryConfig gendir++ notFound :: Snap ()+ notFound = do+ writeText "<html xmlns=\"http://www.w3.org/1999/xhtml\"><body>Page not found.</body></html>"+ getResponse >>= finishWith . setResponseCode 404+++++++---------------------------------------------------------------++logNormalMsg :: TaskChan -> String -> IO ()+logNormalMsg ch x = do+ v <- timestampedLogEntry $ fromString x+ logMsg (logger ch) v ++getParam' :: ByteString -> Snap (Maybe T.Text)+getParam' = fmap (fmap $ decodeUtf8With lenientDecode) . getParam++type TaskChan' = (Cache (Int, T.Text), TaskChan)++exerciseServer :: TaskChan' -> Args -> Snap ()+exerciseServer (cache, ch) args@(Args {magicname, lang, exercisedir, verboseinterpreter}) = do+ params <- fmap show getParams+ when (length params > 3000) $ do+ writeText "<html xmlns=\"http://www.w3.org/1999/xhtml\"><body>Too long request.</body></html>"+ getResponse >>= finishWith . setResponseCode 400++ let md5Id = md5 $ Lazy.fromString params -- could be more efficient+ liftIO $ logNormalMsg ch $ " eval " ++ show md5Id ++ " " ++ params+ j <- liftIO $ lookupCache cache md5Id+ (>>= writeText) $ case j of+ Left (delay, res) -> liftIO $ do+ logNormalMsg ch $ " ch " ++ show md5Id+ threadDelay delay+ return res+ Right cacheAction -> do+ time <- liftIO $ getCurrentTime+ res <- fmap renderResults $ do+ Just [ss, fn_, x, y, T.unpack -> lang'] <- fmap sequence $ mapM getParam' ["c","f","x","y","lang"]++ let fn = exercisedir </> T.unpack fn_+ True <- liftIO $ doesFileExist fn+ Just task <- liftIO $ fmap (eval_ 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."]++ liftIO $ do+ time' <- getCurrentTime+ let delay = round $ 1000000 * (realToFrac $ diffUTCTime time' time :: Double) :: Int+ logNormalMsg ch $ " end " ++ show md5Id ++ " " ++ show delay ++ " ms " ++ T.unpack res+ cacheAction (delay, res)+ return res++ where+ eval_ "eval" _ [_]+ = Just Eval+ eval_ "eval" _ [_, goodsol]+ = Just $ Compare magicname $ T.unpack $ T.drop (length magicname + 4) $ goodsol+ eval_ comm+ (T.unpack -> s) + [env, hidden, re -> Just (is :: [([String],String)]), T.unpack -> j, T.unpack -> i, re -> Just funnames] + = Just $ case comm of + "eval2" -> Compare2 env funnames s+ "check" -> Check env funnames is i j+ eval_ _ _ _+ = Nothing++maybeRead :: Read a => String -> Maybe a+maybeRead s = listToMaybe [a | (a,"") <- reads s] ++re :: Read b => T.Text -> Maybe b+re = maybeRead . T.unpack++
+ Parse.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE RelaxedPolyRec, PatternGuards, ViewPatterns #-}++module Parse + ( Doc (..)+ , BBlock (..)+ , Prompt+ , mainParse+ , getCommand+ , printName+ , parseQuickCheck+ ) where++import Text.Pandoc++import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Syntax++{- Agda support (unfinished)+import qualified Agda.Syntax.Common as Agda+import qualified Agda.Syntax.Concrete as Agda+import qualified Agda.Syntax.Parser as Agda+-}++import Data.List.Split (splitOn)+import Data.List (tails, partition, groupBy)+import Data.Function (on)+import Data.Char (isAlpha, isSpace, toUpper, isUpper)+import Control.Monad (zipWithM)++++--------------------------------- data structures++data Doc+ = Doc+ Meta{-title, author, date-}+ Module{-module directives, module name, imports-}+ [BBlock]+ deriving (Show)++data BBlock+ = Text Block{-pandoc block-}+ | OneLineExercise+ Prompt+ Bool{-intentional error-}+ String+ | Exercise+ [String]{-lines-}+ [String]{-visible lines-}+ [String]{-hidden lines-}+ [Name]{-defined names-}+ [String]{-test expressions-}+ deriving (Show)++type Prompt = Char -- see the separate documentation++-----------------------------------++mainParse :: Bool -> FilePath -> IO Doc+mainParse agda s = do+ c <- readFile s+ case readMarkdown pState . unlines . concatMap preprocess . lines $ c of+ Pandoc meta (CodeBlock ("",["sourceCode","literate","haskell"],[]) h: blocks) -> do+ header <- liftError . parseModule' $ h+ fmap (Doc meta header) $ collectTests agda $ map (interpreter . Text) blocks+ Pandoc meta blocks -> do+ header <- liftError . parseModule' $ "module Unknown where"+ fmap (Doc meta header) $ collectTests agda $ map (interpreter . Text) blocks+ where++ parseModule' = parseModuleWithMode (defaultParseMode {fixities = []})++ preprocess (c:'>':' ':l) | c `elem` commandList+ = ["~~~~~ {." ++ [c] ++ "}", dropWhile (==' ') l, "~~~~~", ""]+ preprocess ('|':l) + = []+ preprocess l+ = [l]++ pState = defaultParserState + { stateSmart = True+ , stateStandalone = True+ , stateLiterateHaskell = True + }++ liftError :: (Monad m, Show a) => ParseResult a -> m a+ liftError (ParseOk m) = return m+ liftError x = fail $ "parseHeader: " ++ show x++ interpreter :: BBlock -> BBlock+ interpreter (Text (CodeBlock ("",[[x]],[]) e)) | x `elem` commandList + = OneLineExercise (toUpper x) (isUpper x) e+ interpreter a = a+++commandList, testCommandList :: String+commandList = "AaRr" ++ testCommandList+testCommandList = "EeFfH"+++------------------------------++collectTests :: Bool -> [BBlock] -> IO [BBlock]+collectTests agda l = zipWithM f l $ tail $ tails l where++ f (Text (CodeBlock ("",["sourceCode","literate","haskell"],[]) h)) l = do+ let+ isExercise = True -- not $ null $ concatMap fst exps++ (visible, hidden, funnames) <- processLines agda isExercise h+ let+ exps = [snd $ getCommand e | (OneLineExercise _ _ e) <- takeWhile p l]++ p (OneLineExercise x _ e) = x `elem` testCommandList && fst (getCommand e) == ""+ p _ = False++ return $ Exercise (lines h) visible hidden funnames exps++ f x _ = return x++processLines :: Bool -> Bool -> String -> IO ([String], [String], [Name])+--processLines True = processAgdaLines+processLines _ = processHaskellLines++{- Agda support (unfinished)+processAgdaLines :: Bool -> String -> IO ([String], [String], [Name])+processAgdaLines isExercise l_ = do+ let+ l = parts l_++ x <- fmap (zip l) $ mapM (Agda.parse Agda.moduleParser . ("module X where\n"++) . unlines) l+ let+ names = map toName $ concatMap (getFName . snd . snd) x++-- getFName [Agda.Module _ _ [Agda.TypedBindings _ (Agda.Arg _ _ [Agda.TBind _ a _])] declarations] +-- = map Agda.boundName a+ getFName [Agda.Module _ _ _ [Agda.TypeSig _ n _]]+ = [n]+ getFName _ = []++-- isVisible [Agda.Module _ _ [Agda.TypedBindings _ (Agda.Arg _ _ [Agda.TBind _ a _])] declarations] +-- = True+ isVisible [Agda.Module _ _ _ [Agda.TypeSig _ n _]] = True+ isVisible _ = not isExercise++ (visible, hidden) = partition (isVisible . snd . snd) x++ toName n = Ident $ show n++ return (concatMap fst visible, concatMap fst hidden, names)+-}++processHaskellLines :: Bool -> String -> IO ([String], [String], [Name])+processHaskellLines isExercise l_ = return (concatMap fst visible, concatMap fst hidden, names)+ where+ x = zip l $ map (parseDeclWithMode (defaultParseMode {fixities = []}) . unlines) l++ l = parts l_++ names = concatMap (getFName . snd) x++ getFName (ParseOk x) = case x of+ TypeSig _ a _ -> a+ PatBind _ (PVar a) _ _ _ -> [a]+ FunBind (Match _ a _ _ _ _ :_) -> [a]+ TypeDecl _ a _ _ -> [a]+ DataDecl _ _ _ a _ x _ -> a: [n | QualConDecl _ _ _ y<-x, n <- getN y]+ _ -> []+ getFName _ = []++ getN (ConDecl n _) = [n]+ getN (InfixConDecl _ n _) = [n]+ getN (RecDecl n l) = n: concatMap fst l++ isVisible (ParseOk (TypeSig _ _ _)) = True+ isVisible (ParseOk (InfixDecl _ _ _ _)) = True+ isVisible _ = not isExercise++ (visible, hidden) = partition (isVisible . snd) x+++parts :: String -> [[String]]+parts = groupBy (const id `on` isIndented) . lines where+ isIndented s | all isSpace s = True+ isIndented (' ':_) = True+ isIndented _ = False++------------------------------++getCommand :: String -> (String, String)+getCommand (':':'?': (dropSpace -> Just x)) + = ("?", x)+getCommand (':': (span isAlpha -> (c@(_:_), dropSpace -> Just x)))+ = (c, x)+getCommand s+ = ("", s)++dropSpace :: String -> Maybe String+dropSpace (' ':y) = Just $ dropWhile (==' ') y+dropSpace "" = Just ""+dropSpace _ = Nothing++parseQuickCheck :: String -> ([String], String)+parseQuickCheck s = case splitOn ";;" s of+ l -> (init l, last l)++printName :: Name -> String+printName (Ident x) = x+printName (Symbol x) = x++++
+ Qualify.hs view
@@ -0,0 +1,67 @@+-- | Qualify given names in a Haskell expression+module Qualify+ ( qualify+ ) where++import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Pretty+import Language.Haskell.Exts.Syntax++import Data.List ((\\))+import Data.Generics+import Control.Monad.Reader++-------------------------------------++type R = Reader [String]++qualify + :: String -- ^ qualifier to add+ -> [String] -- ^ names to qualifiy+ -> String -- ^ Haskell expression+ -> Either String String -- ^ either the modified expression or an error+qualify q ns x = case parseExpWithMode (defaultParseMode {fixities = []}) x of+ ParseOk y -> Right $ prettyPrint $ runReader (trExp y) ns+ e -> Left $ show e+ where + trQName :: QName -> R QName+ trQName y@(UnQual x) = do+ b <- asks (printName x `elem`)+ return $ if b then (Qual (ModuleName q) x) else y+ trQName y = return y++ trExp :: Exp -> R Exp+ trExp (Lambda loc pats e) = do+ pats' <- tr pats+ e' <- local (\\ vars pats) $ trExp e+ return $ Lambda loc pats' e'+ trExp (Let b e) = do+ (b', e') <- local (\\ vars b) $ tr (b, e)+ return $ Let b' e'+ trExp x = gmapM tr x++{-+Alt:+Alt SrcLoc Pat GuardedAlts Binds+-}++ tr :: Data x => x -> R x+ tr = everywhereM (mkM trQName) `extM` trExp++ vars :: Data a => a -> [String]+ vars = map printName . everything (++) (mkQ [] patVars_)++ patVars_ :: Pat -> [Name]+ patVars_ (PVar x) = [x]+ patVars_ (PAsPat x _) = [x]+ patVars_ (PNPlusK x _) = [x]+ patVars_ _ = []++ printName (Ident x) = x+ printName (Symbol x) = x++{- !!!+PatTypeSig SrcLoc Pat Type +PViewPat Exp Pat+-}+
+ QuickCheck.hs view
@@ -0,0 +1,82 @@+module QuickCheck where++import Smart+import ActiveHs.Base (WrapData2 (WrapData2), TestCase (TestCase))+import Lang+import Result+import Qualify (qualify)++import Data.Digest.Pure.MD5+import Language.Haskell.Interpreter hiding (eval)+import Test.QuickCheck hiding (Result)+import qualified Test.QuickCheck.Property as QC++import Data.Char (isLower)+import Data.List (intercalate)+import Control.Concurrent.MVar++---------------------------------------++quickCheck+ :: String -> MD5Digest -> Language -> TaskChan -> FilePath -> String -> [String] -> [([String],String)] + -> IO [Result]+quickCheck qualifier m5 lang ch fn ft funnames is+ = case allRight $ map (qualify qualifier funnames . snd) is of+ Left err -> return [Error True err]+ Right s_ -> interp False m5 lang ch fn "" $ \a ->+ do m <- interpret (mkTestCases [(v,s,s') | ((v,s),s')<- zip is s_]) (as :: [TestCase])+ return $ qcs lang m++ where+ allRight :: [Either a b] -> Either a [b]+ allRight x = case [s | Left s<-x] of+ (y:_) -> Left y+ [] -> Right [s | Right s<-x]++ mkTestCases ss + = "[" ++ intercalate ", " (map mkTestCase ss) ++ "]"++ mkTestCase (vars, s, s2) + = "TestCase (\\qcinner " + ++ unwords ["(" ++ v ++ ")" | v<-vars] + ++ " -> qcinner (" ++ showTr vars s ++ ", " ++ parens s ++ ", " ++ parens s2 ++ "))"+++ showTr vars s = "unwords [" ++ intercalate ", " (map g $ words s) ++ "]" -- !!!+ where++ vs = concatMap f vars++ f = filter (isLower . head) . words++ g x | x `elem` vs = {- "\"(\" ++ -} " show " ++ x -- ++ " ++ \")\""+ g x = show x++qcs :: Language -> [TestCase] -> IO [Result]+qcs lang [] = return [Message (translate lang "All test cases are completed.") Nothing]+qcs lang (t:ts) = do+ s' <- qc lang t+ case s' of+ Just rep -> rep+ Nothing -> qcs lang ts++-- 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 -> TestCase -> IO (Maybe (IO [Result]))+qc lang (TestCase p) = do+ v <- newMVar Nothing+ _ <- quickCheckWithResult (stdArgs { chatty = False }) $ {- QC.noShrinking $ -} p $ ff v+ takeMVar v+ where+ ff v (s, x, y)+ = QC.whenFail (modifyMVar_ v $ const $ return $ Just $ fmap (ModifyCommandLine s :) res)+ $ QC.morallyDubiousIOProperty+ $ fmap f res+ where+ res = compareClearGen lang "noId" $ WrapData2 x y++ f s | hasError s = QC.failed+ f s = QC.succeeded++
+ Result.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE OverloadedStrings #-}+module Result+ ( Result (..)+ , hasError+ , filterResults+ ) where++import Lang+import Data.Data.Compare++import Text.XHtml.Strict+import Control.DeepSeq++---------------------++type Err = (String, String)++data Result+ = ExprType Bool String String [Err] + -- expression with type and error messages+ -- True: this is an error (can't do better just show the type)+ | TypeKind String String [Err] -- type with kind and error messages+ | Comparison String Answer String [Err]+ | SearchResults Bool [String]+ | 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]+ deriving (Show)++instance NFData Result where+ rnf (ExprType e a b l) = rnf (e,a,b,l)+ rnf (TypeKind a b l) = rnf (a,b,l)+ rnf (Comparison a x b l) = rnf (a,x,b,l)+ rnf (SearchResults b l) = rnf (b,l)+ 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 (ShowInterpreter a b c d e f g) = rnf (a,b,c,d,e,f,g)++errors :: Result -> Bool+errors (ExprType _ _ _ l) = not $ null l+errors (TypeKind _ _ l) = not $ null l+errors (Comparison _ x _ l) = x /= Yes || not (null l)+errors (Dia _ l) = not $ null l+errors (Error i _) = i+errors (Message _ x) = maybe False errors x+errors (ShowInterpreter _ _ _ _ _ _ g) = any errors g+errors _ = False++filterResults :: [Result] -> [Result]+filterResults rs = case filter (not . weakError) rs of+ [] -> take 1 rs+ rs -> case filter (not . searchResult) rs of+ [] -> rs+ rs -> {- nubBy f -} rs+{-+ where+ f (ExprType _ _ _ _) (ExprType _ _ _ _) = True+ f _ _ = False+-}++hasError :: [Result] -> Bool+hasError rs = case filter (not . weakError) rs of+ [] -> True+ rs -> any errors rs++weakError :: Result -> Bool+weakError (Error _ _) = True+weakError (ExprType b _ _ _) = b+weakError _ = False++searchResult :: Result -> Bool+searchResult (SearchResults _ _) = True+searchResult _ = False+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ Simple.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE ExistentialQuantification, ScopedTypeVariables, PatternGuards, FlexibleContexts #-}++module Simple+ ( Task (..), TaskChan+ , startGHCiServer+ , restartGHCiServer+ , interpret+ , catchError_fixed+ ) where++import Language.Haskell.Interpreter hiding (interpret)++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.Monad (when, forever)+import Control.Monad.Error (MonadError, catchError)+import Data.List (isPrefixOf)+import Prelude hiding (catch)++-------------------------++data Task + = forall a. Task FilePath (MVar (Either InterpreterError a)) (Interpreter a)++newtype TaskChan + = TC (Chan (Maybe Task))++---------------++startGHCiServer :: [String] -> (String -> IO ()) -> (String -> IO ()) -> IO TaskChan+startGHCiServer paths{-searchpaths-} logError logMsg = do+ ch <- newChan ++ _ <- forkIO $ forever $ do+ logMsg "start interpreter"+ e <- runInterpreter (handleTask ch Nothing)+ `catch` \(e :: SomeException) ->+ return $ Left $ UnknownError "GHCi server died."+ case e of+ Left e -> logError $ "stop interpreter: " ++ show e+ Right () -> return ()++ return $ TC ch++ where+ handleTask :: Chan (Maybe Task) -> Maybe FilePath -> Interpreter ()+ handleTask ch oldFn = do+ task <- lift $ readChan ch+ case task of+ Just task -> handleTask_ ch oldFn task+ Nothing -> liftIO $ logError "interpreter stopped intentionally"++ handleTask_ ch oldFn (Task fn repVar m) = do+ (cont, res) <- do + when (oldFn /= Just fn) $ do+ reset+ set [searchPath := paths]+ loadModules [fn]+ setTopLevelModules ["Main"]++ x <- m+ return (True, Right x)++ `catchError_fixed` \er ->+ return (not $ fatal er, Left er)++ lift $ putMVar repVar res+ when cont $ handleTask ch $ case res of+ Right _ -> Just fn+ Left _ -> Nothing+++restartGHCiServer :: TaskChan -> IO ()+restartGHCiServer (TC ch) = writeChan ch Nothing++interpret :: TaskChan -> FilePath -> Interpreter a -> IO (Either InterpreterError a)+interpret (TC ch) fn m = do+ rep <- newEmptyMVar+ 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 + => m a -> (InterpreterError -> m a) -> m a+m `catchError_fixed` f = m `catchError` (f . fixError)+ where+ fixError (UnknownError s) + | Just x <- dropPrefix "GHC returned a result but said: [GhcError {errMsg =" s+ = WontCompile [GhcError {errMsg = case reads x of ((y,_):_) -> y; _ -> s}]+ fixError x = x++dropPrefix :: Eq a => [a] -> [a] -> Maybe [a]+dropPrefix s m+ | s `isPrefixOf` m = Just $ drop (length s) m+ | otherwise = Nothing+++
+ Smart.hs view
@@ -0,0 +1,238 @@+{-# LANGUAGE ViewPatterns, PatternGuards, OverloadedStrings #-}+module Smart where++import HoogleCustom+import Specialize+import Lang+import Result+import qualified Simple++import ActiveHs.Base (WrapData2 (..), WrapData(..))+import Graphics.Diagrams (Diagram)+import Graphics.Diagrams.SVG (render)+import Graphics.Diagrams.FunctionGraphs (displayFun, displayDiscreteFun, displayArc)++import qualified Data.Data.Eval as C+import qualified Data.Data.Compare as C+import Data.Data.GenRep hiding (Error)+import Data.Data.GenRep.Functions (mistify, numberErrors)+import Data.Data.GenRep.Doc (toDoc)++import Language.Haskell.Interpreter hiding (eval)+import Data.Digest.Pure.MD5+import Hoogle (Database, loadDatabase)+import System.FastLogger++import System.Locale (defaultTimeLocale)+import Data.Time (getCurrentTime, formatTime)+import Data.ByteString.UTF8 (fromString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy.UTF8 as Lazy++import Control.Monad (join)+import Data.Dynamic hiding (typeOf)+import qualified Data.Data as D+import Data.List (nub)+import Data.Char (isAlpha)+import Prelude hiding (catch)+++----------------------------------------------------------------------++data TaskChan + = TC + { logger :: Logger+ , database :: Maybe Database -- for Hoogle searches+ , chan :: Simple.TaskChan+ }++startGHCiServer :: [FilePath] -> FilePath -> FilePath -> IO TaskChan+startGHCiServer searchpaths logfilebase dbname = do+ ti <- getCurrentTime+ log <- newLogger $ logfilebase ++ "_" ++ formatTime defaultTimeLocale "%Y-%m-%d-%H:%M:%S" ti ++ ".log"+ db <- if (dbname == "") then return Nothing else fmap Just $ loadDatabase dbname+ ch <- Simple.startGHCiServer+ searchpaths+ (logMsgWithImportance 5 log . fromString) + (logMsgWithImportance 4 log . fromString)+ return $ TC+ { logger = log+ , database = db+ , chan = ch+ }++restart :: TaskChan -> IO ()+restart ch = do+ Simple.restartGHCiServer (chan ch)++---------------++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]++----------------------------------------------------------------------++logMsgWithImportance :: Int -> Logger -> B.ByteString -> IO ()+logMsgWithImportance n ch x = do+ v <- timestampedLogEntry $ B.concat + [nn, " ", x, " ", nn]+ logMsg ch v + where+ nn = fromString $ replicate n '#'++++----------------------------------------------------------------------++mkId :: String -> MD5Digest+mkId = md5 . Lazy.fromString++------------------++getCommand :: String -> (String, String)+getCommand (':':'?': (dropSpace -> Just x)) + = ("?", x)+getCommand (':': (span isAlpha -> (c@(_:_), dropSpace -> Just x)))+ = (c, x)+getCommand s+ = ("", s)++dropSpace :: String -> Maybe String+dropSpace (' ':y) = Just $ dropWhile (==' ') y+dropSpace "" = Just ""+dropSpace _ = Nothing+++interp :: Bool -> MD5Digest -> 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)+ $ Simple.interpret (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)++ , return $ return [ExprType True s ty []]+ ]++ , 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+ ]++ _ -> return [Error True $ + translate lang "The" ++ " :" ++ c ++ " " ++ translate lang "command is not supported" ++ "."]++ where++ catchE b m + = m `Simple.catchError_fixed` \e -> + return $ return $ map (Error b) $ showErr lang e++--------------------+++pprintData :: String -> String -> WrapData -> IO [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]+++pprint :: String -> Dynamic -> IO [Result]+pprint idi d+ | Just x <- fromDynamic d = ff x+ | Just x <- fromDynamic d = ff $ showFunc (x :: Double -> Double)+ | Just x <- fromDynamic d = ff $ showFunc (x :: Double -> Integer)+ | Just x <- fromDynamic d = ff $ showFunc $ fromIntegral . fromEnum . (x :: Double -> Bool)+ | Just x <- fromDynamic d = ff $ showFunc $ fromIntegral . fromEnum . (x :: Double -> Ordering)+ | Just x <- fromDynamic d = ff $ showFunc_ (x :: Integer -> Double)+ | Just x <- fromDynamic d = ff $ showFunc_ (x :: Integer -> Integer)+ | Just x <- fromDynamic d = ff $ showFunc_ $ fromIntegral . fromEnum . (x :: Integer -> Bool)+ | 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 []+ where+ ff = fmap g . render 10 (-16, -10) (16, 10) 0.5 1000 idi+ g (htm, err) = [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+ showFunc_ = displayDiscreteFun (-16,-10) (16,10)+ displayArc' = displayArc (-16,-10) (16,10) (0,1) ++------------------------++wrap2 :: String -> String -> String+wrap2 a b = "WrapData2 " ++ parens a ++ " " ++ parens b++----------------++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]+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 "" []]+ _ ->+ 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')]+++---------------------------------++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]+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 :: C.Answer -> (GenericData, GenericData) -> Result+showPair x (a, b) = Comparison (show (toDoc a')) x (show (toDoc b')) es+ where ([a', b'], es) = numberErrors [a, b]+++
+ Special.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, ViewPatterns, PatternGuards, NamedFieldPuns #-}++module Special+ ( SpecialTask (..), exerciseServer'+ ) where++import Smart+import QuickCheck+import Result+import Lang+import Html+import Qualify (qualify)++import ActiveHs.Base (WrapData2)++import Language.Haskell.Interpreter hiding (eval)+import Data.Digest.Pure.MD5 (MD5Digest)++import qualified Data.Text as T+import qualified Data.Text.IO as T+import Data.ByteString.UTF8 (fromString)++import Control.DeepSeq+import Control.Concurrent.MVar+import Control.Exception+import System.FilePath ((</>),takeFileName)+import System.Directory (getTemporaryDirectory)++import Control.Concurrent (threadDelay, forkIO, killThread)+import Prelude hiding (catch)+++---------------------------------------------------------------++timeout :: forall b. Int -> IO b -> IO b -> IO b+timeout delay error action = do+ v <- newEmptyMVar + t1 <- forkIO $ threadDelay delay >> error >>= putMVar v+ t2 <- forkIO $ action >>= putMVar v+ x <- takeMVar v+ killThread t1+ killThread t2+ return x++----------------------------++data SpecialTask+ = Eval+ | Compare String String+ | Compare2 T.Text [String] String+ | Check T.Text [String] [([String],String)] String String++exerciseServer' + :: String+ -> TaskChan+ -> Bool+ -> FilePath+ -> T.Text+ -> Language+ -> MD5Digest+ -> SpecialTask+ -> IO [Result]++exerciseServer' qualifier ch verbose fn sol lang m5 task = do++ let error = do+ logMsgWithImportance 5 (logger ch) $ fromString $ "Server error:" ++ show m5+ return [Error True "Server error."]++ action =+ do res <- eval task+ res `deepseq` return res+ `catch` \(e :: SomeException) -> -- ???+ return [Error True $ show e]++ timeout (10*1000000) error action++ where++ eval Eval+ = interp verbose m5 lang ch fn (T.unpack sol) $ \a -> return $ return []++ 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++ eval (Compare2 env funnames s) = do+ fn' <- tmpSaveHs (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)++ eval (Check env funnames is i j) = do+ fn' <- tmpSaveHs (show m5) $ env `T.append` sol+ 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]++tmpSaveHs :: String -> T.Text -> IO FilePath+tmpSaveHs x s = do+ tmpdir <- getTemporaryDirectory+ let tmp = tmpdir </> "GHCiServer_" ++ x ++ ".hs"+ T.writeFile tmp s+ return tmp++++
+ Specialize.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleInstances #-}+module Specialize + ( specialize+ ) where++import Data.List+import Data.Function++import Language.Haskell.Exts.Parser+import Language.Haskell.Exts.Pretty+import Language.Haskell.Exts.Syntax+import Language.Haskell.Exts.Extension++-----------------------------++specialize :: String -> Either String (String, String)+specialize a+ = case parseTypeWithMode (defaultParseMode {extensions = [FlexibleContexts], fixities = []}) a of+ ParseFailed loc s -> Left $ show s+ ParseOk t -> let++ (t',t'') = convert (split t)++ in Right (prettyPrint t', prettyPrint t'')++split :: Type -> ([(String, [String])], Type)+split (TyForall Nothing l t) + = ( map (\x -> (fst (head x), map snd x)) $ groupBy ((==) `on` fst) $ sort+ [(v,s) | ClassA (UnQual (Ident s)) [TyVar (Ident v)]<-l]+ , t+ )+split t + = ([], t)++convert :: ([(String, [String])], Type) -> (Type, Type)+convert (m, t) = (app True mm t, app False mm t) where mm = map resolve m++app :: Bool -> [(String, [[Char]])] -> Type -> Type+app b m t = f t where+ f (TyFun a b) = TyFun (f a) (f b)+ f (TyTuple bo l) = TyTuple bo $ map f l+ f (TyList t) = TyList (f t)+ f (TyParen t) = TyParen (f t)+ f (TyApp x t) = TyApp (f x) (f t)+ f (TyVar (Ident s)) = mkV $ head $ [y | (v,x)<-m, v==s, y<-ff x] ++ ff allT+ f t = t++ ff = if b then id else reverse++mkV :: String -> Type+mkV v = TyVar $ Ident v++resolve :: (String, [String]) -> (String, [String])+resolve (v, l) = (v, foldl1 intersect $ map res l)++allT :: [String]+allT = ["Double","Integer","Char","Bool","()"]++res :: String -> [String]+res x | x `elem` ["RealFrac", "Real", "RealFloat", "Floating", "Fractional"] = ["Double"]+res x | x `elem` ["Num"] = ["Double","Integer"]+res x | x `elem` ["Integral"] = ["Integer"]+res x | x `elem` ["Monad"] = ["[]","Maybe"]+res x | x `elem` ["Ord","Show","Eq","Enum"] = allT+res x = [] -- !!!++
+ activehs.cabal view
@@ -0,0 +1,92 @@+name: activehs+version: 0.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>+ .+ Developer's Documentation (partial): <http://pnyf.inf.elte.hu:8000/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.+ .+ Note that this software has many rough edges; you are welcome to+ work on it!+stability: alpha+license: BSD3+license-file: LICENSE+author: Péter Diviánszky+maintainer: divipp@gmail.com+cabal-version: >=1.6+build-type: Simple+data-files:+ copy/*.css, + copy/*.js, + copy/icon.ico, + template/*.template,+ doc/UsersGuide_en.lhs,+ doc/DevDoc_en.lhs,+ doc/watchserver.sh++source-repository head+ type: git+ location: git://github.com/divipp/ActiveHs++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+ Main-is: + Main.hs+ Other-modules:+ Paths_activehs,+ Parse,+ Converter,+ Args,+ Simple,+ Smart,+ Cache,+ Specialize,+ Qualify,+ Lang,+ Result,+ HoogleCustom,+ Html,+ QuickCheck,+ Special++ Build-Depends:+-- Agda >= 2.2 && < 2.3,+ hoogle >= 4.2 && < 4.3,+ dia-base >= 0.1 && < 0.2,+ dia-functions >= 0.2.1.1 && < 0.3,+ activehs-base >= 0.2 && < 0.3,+ data-pprint >= 0.2 && < 0.3,+ base >= 4.0 && < 4.4,+ QuickCheck >= 2.4 && < 2.5,+ array >= 0.3 && < 0.4,+ directory >= 1.1 && < 1.2,+ containers >= 0.4 && < 0.5,+ filepath >= 1.2 && < 1.3,+ text >= 0.11 && < 0.12,+ snap-core >= 0.5 && < 0.6,+ snap-server >= 0.5 && < 0.6,+ syb >= 0.2 && < 0.4,+ haskell-src-exts >= 1.9 && < 1.12,+ bytestring >= 0.9 && < 0.10,+ utf8-string >= 0.3 && < 0.4,+ xhtml >= 3000.2 && < 3000.3,+ pureMD5 >= 2.1 && < 2.2,+ deepseq >= 1.1 && < 1.2,+ split >= 0.1 && < 0.2,+ pandoc >= 1.8 && < 1.9,+ time >= 1.2 && < 1.4,+ old-time >= 1.0 && < 1.1,+ process >= 1.0 && < 1.1,+ hint >= 0.3.3.2 && < 0.4,+ simple-reflect >= 0.2 && < 0.3,+ mtl >= 2.0 && < 2.1,+ old-locale >= 1.0 && < 1.1,+ cmdargs >= 0.7 && < 0.9+
+ copy/common.css view
@@ -0,0 +1,205 @@++/* slides */++body.single_slide > * { display: none; visibility: hidden }+body.single_slide .current { display: block; visibility: visible }+body.single_slide div#TOC { display: none; visibility: hidden }+body.single_slide div.handout { display: none; visibility: hidden }+body.single_slide div#lang { display: block; visibility: visible }+++/* padding */++body {+ margin: auto;+ padding: 1em 1em 1em 1em;+ max-width: 50em; + line-height: 130%;+ background-color: white;+ color: black;+}++h1 {+ padding-top: 1.5em;+}++h2 {+ padding-top: 1em;+}++h3 {+ padding-top: 0.5em;+}++h1.cover {+ padding-top: 3em;+ padding-bottom: 2em;+ text-align: center;+ line-height: normal;+}++hr {+ height: 10px;+}+++/* margin */++div.indent, pre, table {+ margin-left: 5%;+ width: 95%;+}++div.indent, pre {+ 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;+}+++/* border */++h1, h2, h3 { + border-bottom: 1px dotted black;+}++h1.cover, input, textarea, hr {+ border-style: none;+}+++/* font sizes */++h1 { font-size: 130%; }+h1.cover { font-size: 200%; }+h2 { font-size: 110%; }+input, textarea { font-size: 100%; } /* monospace correction */+++/* font family, style, weight, text decoration */++h1, h2, h3 {+ font-weight: bold;+}++pre code, textarea, div.string {+ font-family: monospace;+ font-size: 130%;+}++pre.normal, pre.normal code, code, .error, input {+ font-family: sans-serif;+ font-size: 100%;+}+++.wait {+ font-style: italic;+}++a {+ text-decoration: none;+}++++div.serious {font-weight: bold;}+div.info {color: gray;}+++/* colors other than highlighting */++input { background-color: #eeeeee; }+textarea { background-color: #ffffba; }+hr { background-color: #f5f0ee; }+div.string span { background-color: yellow; }++a { color: #2a207a; }+h1 a, h2 a, h3 a { color: black; }+code { color: red; }+.wait { color: gray; }+.result { color: green; }+.type { color: #0080ff; }+.error { color: #a030a0; }+.comment { color: gray; float: right; }+++/* misc */++.result {+ word-wrap: break-word;+}++p.caption {+ display: none;+}++div#lang {+ position:fixed;+ z-index:1000;+ right: 1%;+ top: 1%;+}++div#info {+ display: none;+ position:fixed;+ z-index:1000;+ left: 40%;+ width: 20%;+ top: 40%;+ height: 20%; +}++.wait {+ padding: 10px;+ width: 8em;+ border: 1px solid grey;+}++/* search result colors */++code.search { color: black; }+code.search b { color: gray; }++.c0{background-color: #fcc;}+.c1{background-color: #cfc;}+.c2{background-color: #ccf;}+.c3{background-color: #ffc;}+.c4{background-color: #fcf;}+.c5{background-color: #cff;}+++/* highlighting css */++table.sourceCode, tr.sourceCode, td.lineNumbers, td.sourceCode, table.sourceCode + { margin: 0; padding: 0; border: 0; vertical-align: baseline; border: none; }+td.lineNumbers { border-right: 1px solid #AAAAAA; text-align: right; color: #AAAAAA; padding-right: 5px; padding-left: 5px; }+td.sourceCode { padding-left: 5px; }+pre.sourceCode span.kw { color: #007020; /* font-weight: bold; */ } +pre.sourceCode span.dt { color: #902000; }+pre.sourceCode span.dv { color: #40a070; }+pre.sourceCode span.bn { color: #40a070; }+pre.sourceCode span.fl { color: #40a070; }+pre.sourceCode span.ch { color: #4070a0; }+pre.sourceCode span.st { color: #4070a0; }+pre.sourceCode span.co { color: #60a0b0; /* font-style: italic; */ }+pre.sourceCode span.ot { color: #007020; }+pre.sourceCode span.al { color: red; /* font-weight: bold; */ }+pre.sourceCode span.fu { color: #06287e; }+pre.sourceCode span.re { }+pre.sourceCode span.er { color: red; /* font-weight: bold; */ }+
+ copy/common_en.js view
@@ -0,0 +1,357 @@++var t;+var waiting = 0;++function get(params, targetHtml) {+// alert('get: ' + params);+ var http = false;+ if (window.XMLHttpRequest) { // Mozilla, Safari,...+ http = new XMLHttpRequest();+ if (http.overrideMimeType) {+ http.overrideMimeType('text/html');+ }+ } else {+ if (window.ActiveXObject) { // IE+ try {+ http = new ActiveXObject("Msxml2.XMLHTTP");+ } catch (e) {+ try {+ http = new ActiveXObject("Microsoft.XMLHTTP");+ } catch (e) {}+ }+ }+ }+ if (!http) {+ targetHtml.innerHTML = '<span class="error">Client error.</span>';+ } else {++// alert('get ready: x ' );++ if (waiting == 0) {+ t = setTimeout("drawWarning(1);", 1000);+ };+ waiting = waiting + 1;++ http.onreadystatechange = function () {+ if (http.readyState == 4) {+ targetHtml.innerHTML = http.responseText;+ waiting = waiting - 1;+ if (waiting == 0) {+ clearTimeout(t);+ setTimeout("clearWarning();", 500);+ };+ }+ }++ http.open('POST', "exercise/", true);+ http.setRequestHeader("Content-type", "application/x-www-form-urlencoded");+ http.setRequestHeader("Content-length", params.length);+ http.setRequestHeader("Connection", "close");+ http.send(params);+ }+}++function drawWarning(n) {+ var r="Waiting."; + for (var a=0; a< n % 3; a++) r+='.';+ document.getElementById('info').style.display = "block";+ document.getElementById('info').innerHTML = '<div class="wait">' + r + '</div>';+ t = setTimeout('drawWarning(' + (n+1) + ');', 500);+}++function clearWarning() {+ document.getElementById('info').style.display = "none";+ document.getElementById('info').innerHTML = "";+}++function getPos(evt, obj) { //this is the main function+ var img_x;+ var img_y;+ var c;+ if (document.all) { // MSIE+ img_x = evt.offsetX;+ img_y = evt.offsetY;+ } else { // Netscape, etc.+ img_x = evt.pageX;+ img_y = evt.pageY;++ c = findPos(obj); // here I get the images position+ img_x -= c[0];+ img_y -= c[1];++// c = checkscroll(); // then I check the scrollbar+// img_x += c[0];+// img_y += c[1];+ }+ return [img_x,img_y];+}++function findPos(obj) {+ var curleft = curtop = 0;+ if (obj.offsetParent) {+ curleft = obj.offsetLeft;+ curtop = obj.offsetTop;+ while (obj = obj.offsetParent) {+ curleft += obj.offsetLeft;+ curtop += obj.offsetTop;+ }+ }+ return [curleft,curtop];+}++// még nem jó..+function findScrolled(obj) {+ var curleft = curtop = 0;+ if (obj) {+ curleft = obj.scrollLeft;+ curtop = obj.scrollTop;+ while (obj.tagName.toLowerCase () != "html") {+ obj = obj.parentNode;+ curleft += obj.scrollLeft;+ curtop += obj.scrollTop;+ }+ }+ return [curleft,curtop];+}++function findDiff(obj) {+ var c = findPos(obj);+ var d = findScrolled(obj);+ return [c[0]-d[0],c[1]-d[1]];+}++function yTop() {+ if(window.pageYOffset) {+ return window.pageYOffset;+ } else if(document.body.scrollTop) {+ return document.body.scrollTop;+ }+}++/*+function checkscroll() {+ var x;+ var y;+ if(window.pageXOffset) {+ x = window.pageXOffset;+ } else if(document.body.scrollLeft) {+ x = document.body.scrollLeft;+ }+ if(window.pageYOffset) {+ y = window.pageYOffset;+ } else if(document.body.scrollTop) {+ y = document.body.scrollTop;+ }++ if(x == undefined){+ x = 0;+ }+ if(y == undefined){+ y = 0;+ }+ return [x,y];+}+*/+function getData(obj) {+ return encodeURIComponent(document.getElementById('tarea' + obj).value);+}++function target(obj) {+ return document.getElementById('res' + obj);+}++function getOne(a, t, x) {+ get(a + "&lang=en&x=" + getData(x) + "&y=", target(t));+}++function getTwo(a, t, x, y) {+ get(a + "&lang=en&x=" + getData(x) + "&y=" + getData(y), target(t));+}++function resetForms() {+ var forms = document.getElementsByTagName("form");+ for(var index=0;index<forms.length;index++) {+ if (forms[index].className == 'resetinterpreter') { + forms[index].reset(); + }+ }+}+/*+var Black = "black";+var White = "white";+var Gray = "gray";+var Blue = "blue";+var Red = "red";+var Yellow = "yellow";+var Green = "green";+*/+function set(a,b,c) {+ document.getElementById(a).setAttribute(b,c);+}++function replace(a,b) {+ var q= document.getElementById(a);+ q.replaceChild(document.getElementById(b).cloneNode(true), q.firstChild);+}++// after w3c slidy, http://www.w3.org/Talks/Tools/Slidy2/++var slidy = {+ key_wanted: false,+ slide_number: 0, // integer slide count: 0, 1, 2, ...+ view_all: true, // true: view all slides + handouts++ show_slide: function () {+ window.scrollTo(0,0);+ set_class(document.getElementsByTagName('body')[0].children[slidy.slide_number], "current");+ },++ switch_slide: function (event, n) {+ if (slidy.view_all) {+ return true;+ } else {+ var x = document.getElementsByTagName('body')[0].children;+ if (n >= 0 && n < x.length && n != slidy.slide_number) {+ set_class(x[slidy.slide_number], "");+ slidy.slide_number = n;+ slidy.show_slide();+ }+ return slidy.cancel(event);+ }+ },++ // needed for Opera to inhibit default behavior+ // since Opera delivers keyPress even if keyDown+ // was cancelled+ key_press: function (event) {+ if (!event)+ event = window.event;++ if (!slidy.key_wanted)+ return slidy.cancel(event);++ return true;+ },++ // See e.g. http://www.quirksmode.org/js/events/keys.html for keycodes+ key_down: function (event) {+ var key, target, tag;++ slidy.key_wanted = true;++ if (!event)+ event = window.event;++ // kludge around NS/IE differences + if (window.event)+ {+ key = window.event.keyCode;+ target = window.event.srcElement;+ }+ else if (event.which)+ {+ key = event.which;+ target = event.target;+ }+ else+ return true; // Yikes! unknown browser++ // ignore event if key value is zero+ // as for alt on Opera and Konqueror+ if (!key)+ return true;++ if (slidy.special_element(target))+ return true;++ // check for concurrent control/command/alt key+ // but are these only present on mouse events?+ if (event.ctrlKey || event.altKey || event.metaKey)+ return true;++ if (key == 32 || key == 39) { // space bar, right arrow+ slidy.switch_slide(event, slidy.slide_number + 1);+ } else if (key == 37) { // left arrow+ slidy.switch_slide(event, slidy.slide_number - 1);+ } else if (key == 36) { // Home+ slidy.switch_slide(event, 0);+ } else if (key == 35) { // End+ slidy.switch_slide(event, document.getElementsByTagName('body')[0].children.length - 1);+ } else if (key == 65 && document.getElementsByTagName('body')[0].children.length > 3) { // A++ var x = document.getElementsByTagName('body')[0].children;++ if (slidy.view_all) {+ set_class(document.getElementsByTagName('body')[0], "single_slide");+ // var y = 0; //yTop();+ // slidy.slide_number = 0;+ // while (findDiff(x[slidy.slide_number])[1] < 0+ // && slidy.slide_number < x.length - 1) {+ // slidy.slide_number += 1;+ // }+ slidy.show_slide();+ } else {+ set_class(document.getElementsByTagName('body')[0], "");+ x[slidy.slide_number].scrollIntoView();+ // set_class(x[slidy.slide_number], "");+ }+ slidy.view_all = !slidy.view_all;+ return slidy.cancel(event);+ }+ return true;+ },++ special_element: function (e) {+ var tag = e.nodeName.toLowerCase();++ return e.onkeydown ||+ e.onclick ||+ tag == "a" ||+ tag == "embed" ||+ tag == "object" ||+ tag == "video" ||+ tag == "audio" ||+ tag == "input" ||+ tag == "textarea" ||+ tag == "select" ||+ tag == "option";+ },++ cancel: function (event) {+ if (event)+ {+ event.cancel = true;+ event.returnValue = false;++ if (event.preventDefault)+ event.preventDefault();+ }++ slidy.key_wanted = false;+ return false;+ },+};++function set_class(element, name) {+ if (typeof element.className != 'undefined') {+ element.className = name;+ } else {+ element.setAttribute("class", name);+ }+};++function add_listener(event, handler) {+ if (window.addEventListener)+ document.addEventListener(event, handler, false);+ else+ document.attachEvent("on"+event, handler);+};++// attach event listeners for initialization+function slidy_init() { + add_listener("keydown", slidy.key_down);+ add_listener("keypress", slidy.key_press);+};+++
+ copy/common_hu.js view
@@ -0,0 +1,357 @@++var t;+var waiting = 0;++function get(params, targetHtml) {+// alert('get: ' + params);+ var http = false;+ if (window.XMLHttpRequest) { // Mozilla, Safari,...+ http = new XMLHttpRequest();+ if (http.overrideMimeType) {+ http.overrideMimeType('text/html');+ }+ } else {+ if (window.ActiveXObject) { // IE+ try {+ http = new ActiveXObject("Msxml2.XMLHTTP");+ } catch (e) {+ try {+ http = new ActiveXObject("Microsoft.XMLHTTP");+ } catch (e) {}+ }+ }+ }+ if (!http) {+ targetHtml.innerHTML = '<span class="error">Kliens hiba.</span>';+ } else {++// alert('get ready: x ' );++ if (waiting == 0) {+ t = setTimeout("drawWarning(1);", 1000);+ };+ waiting = waiting + 1;++ http.onreadystatechange = function () {+ if (http.readyState == 4) {+ targetHtml.innerHTML = http.responseText;+ waiting = waiting - 1;+ if (waiting == 0) {+ clearTimeout(t);+ setTimeout("clearWarning();", 500);+ };+ }+ }++ http.open('POST', "exercise/", true);+ http.setRequestHeader("Content-type", "application/x-www-form-urlencoded");+ http.setRequestHeader("Content-length", params.length);+ http.setRequestHeader("Connection", "close");+ http.send(params);+ }+}++function drawWarning(n) {+ var r="Várakozás."; + for (var a=0; a< n % 3; a++) r+='.';+ document.getElementById('info').style.display = "block";+ document.getElementById('info').innerHTML = '<div class="wait">' + r + '</div>';+ t = setTimeout('drawWarning(' + (n+1) + ');', 500);+}++function clearWarning() {+ document.getElementById('info').style.display = "none";+ document.getElementById('info').innerHTML = "";+}++function getPos(evt, obj) { //this is the main function+ var img_x;+ var img_y;+ var c;+ if (document.all) { // MSIE+ img_x = evt.offsetX;+ img_y = evt.offsetY;+ } else { // Netscape, etc.+ img_x = evt.pageX;+ img_y = evt.pageY;++ c = findPos(obj); // here I get the images position+ img_x -= c[0];+ img_y -= c[1];++// c = checkscroll(); // then I check the scrollbar+// img_x += c[0];+// img_y += c[1];+ }+ return [img_x,img_y];+}++function findPos(obj) {+ var curleft = curtop = 0;+ if (obj.offsetParent) {+ curleft = obj.offsetLeft;+ curtop = obj.offsetTop;+ while (obj = obj.offsetParent) {+ curleft += obj.offsetLeft;+ curtop += obj.offsetTop;+ }+ }+ return [curleft,curtop];+}++// még nem jó..+function findScrolled(obj) {+ var curleft = curtop = 0;+ if (obj) {+ curleft = obj.scrollLeft;+ curtop = obj.scrollTop;+ while (obj.tagName.toLowerCase () != "html") {+ obj = obj.parentNode;+ curleft += obj.scrollLeft;+ curtop += obj.scrollTop;+ }+ }+ return [curleft,curtop];+}++function findDiff(obj) {+ var c = findPos(obj);+ var d = findScrolled(obj);+ return [c[0]-d[0],c[1]-d[1]];+}++function yTop() {+ if(window.pageYOffset) {+ return window.pageYOffset;+ } else if(document.body.scrollTop) {+ return document.body.scrollTop;+ }+}++/*+function checkscroll() {+ var x;+ var y;+ if(window.pageXOffset) {+ x = window.pageXOffset;+ } else if(document.body.scrollLeft) {+ x = document.body.scrollLeft;+ }+ if(window.pageYOffset) {+ y = window.pageYOffset;+ } else if(document.body.scrollTop) {+ y = document.body.scrollTop;+ }++ if(x == undefined){+ x = 0;+ }+ if(y == undefined){+ y = 0;+ }+ return [x,y];+}+*/+function getData(obj) {+ return encodeURIComponent(document.getElementById('tarea' + obj).value);+}++function target(obj) {+ return document.getElementById('res' + obj);+}++function getOne(a, t, x) {+ get(a + "&lang=hu&x=" + getData(x) + "&y=", target(t));+}++function getTwo(a, t, x, y) {+ get(a + "&lang=hu&x=" + getData(x) + "&y=" + getData(y), target(t));+}++function resetForms() {+ var forms = document.getElementsByTagName("form");+ for(var index=0;index<forms.length;index++) {+ if (forms[index].className == 'resetinterpreter') { + forms[index].reset(); + }+ }+}+/*+var Black = "black";+var White = "white";+var Gray = "gray";+var Blue = "blue";+var Red = "red";+var Yellow = "yellow";+var Green = "green";+*/+function set(a,b,c) {+ document.getElementById(a).setAttribute(b,c);+}++function replace(a,b) {+ var q= document.getElementById(a);+ q.replaceChild(document.getElementById(b).cloneNode(true), q.firstChild);+}++// after w3c slidy, http://www.w3.org/Talks/Tools/Slidy2/++var slidy = {+ key_wanted: false,+ slide_number: 0, // integer slide count: 0, 1, 2, ...+ view_all: true, // true: view all slides + handouts++ show_slide: function () {+ window.scrollTo(0,0);+ set_class(document.getElementsByTagName('body')[0].children[slidy.slide_number], "current");+ },++ switch_slide: function (event, n) {+ if (slidy.view_all) {+ return true;+ } else {+ var x = document.getElementsByTagName('body')[0].children;+ if (n >= 0 && n < x.length && n != slidy.slide_number) {+ set_class(x[slidy.slide_number], "");+ slidy.slide_number = n;+ slidy.show_slide();+ }+ return slidy.cancel(event);+ }+ },++ // needed for Opera to inhibit default behavior+ // since Opera delivers keyPress even if keyDown+ // was cancelled+ key_press: function (event) {+ if (!event)+ event = window.event;++ if (!slidy.key_wanted)+ return slidy.cancel(event);++ return true;+ },++ // See e.g. http://www.quirksmode.org/js/events/keys.html for keycodes+ key_down: function (event) {+ var key, target, tag;++ slidy.key_wanted = true;++ if (!event)+ event = window.event;++ // kludge around NS/IE differences + if (window.event)+ {+ key = window.event.keyCode;+ target = window.event.srcElement;+ }+ else if (event.which)+ {+ key = event.which;+ target = event.target;+ }+ else+ return true; // Yikes! unknown browser++ // ignore event if key value is zero+ // as for alt on Opera and Konqueror+ if (!key)+ return true;++ if (slidy.special_element(target))+ return true;++ // check for concurrent control/command/alt key+ // but are these only present on mouse events?+ if (event.ctrlKey || event.altKey || event.metaKey)+ return true;++ if (key == 32 || key == 39) { // space bar, right arrow+ slidy.switch_slide(event, slidy.slide_number + 1);+ } else if (key == 37) { // left arrow+ slidy.switch_slide(event, slidy.slide_number - 1);+ } else if (key == 36) { // Home+ slidy.switch_slide(event, 0);+ } else if (key == 35) { // End+ slidy.switch_slide(event, document.getElementsByTagName('body')[0].children.length - 1);+ } else if (key == 65 && document.getElementsByTagName('body')[0].children.length > 3) { // A++ var x = document.getElementsByTagName('body')[0].children;++ if (slidy.view_all) {+ set_class(document.getElementsByTagName('body')[0], "single_slide");+ // var y = 0; //yTop();+ // slidy.slide_number = 0;+ // while (findDiff(x[slidy.slide_number])[1] < 0+ // && slidy.slide_number < x.length - 1) {+ // slidy.slide_number += 1;+ // }+ slidy.show_slide();+ } else {+ set_class(document.getElementsByTagName('body')[0], "");+ x[slidy.slide_number].scrollIntoView();+ // set_class(x[slidy.slide_number], "");+ }+ slidy.view_all = !slidy.view_all;+ return slidy.cancel(event);+ }+ return true;+ },++ special_element: function (e) {+ var tag = e.nodeName.toLowerCase();++ return e.onkeydown ||+ e.onclick ||+ tag == "a" ||+ tag == "embed" ||+ tag == "object" ||+ tag == "video" ||+ tag == "audio" ||+ tag == "input" ||+ tag == "textarea" ||+ tag == "select" ||+ tag == "option";+ },++ cancel: function (event) {+ if (event)+ {+ event.cancel = true;+ event.returnValue = false;++ if (event.preventDefault)+ event.preventDefault();+ }++ slidy.key_wanted = false;+ return false;+ },+};++function set_class(element, name) {+ if (typeof element.className != 'undefined') {+ element.className = name;+ } else {+ element.setAttribute("class", name);+ }+};++function add_listener(event, handler) {+ if (window.addEventListener)+ document.addEventListener(event, handler, false);+ else+ document.attachEvent("on"+event, handler);+};++// attach event listeners for initialization+function slidy_init() { + add_listener("keydown", slidy.key_down);+ add_listener("keypress", slidy.key_press);+};+++
+ copy/icon.ico view
binary file changed (absent → 1150 bytes)
+ doc/DevDoc_en.lhs view
@@ -0,0 +1,244 @@+% ActiveHs Developer's Documentation++> module DevDoc_en where+>+> import ActiveHs.Base+> import MyPrelude+> import Prelude ()++| feltolni a githubra+| feltenni a hackagedbre+| feltenni a redditre+| írni levelet Ambrusnak, Gábornak és a srácnak++This is the developer's documentation of ActiveHs. To understand the terms used, [please+read the user's guide first](UsersGuide_en.xml).+++Main Components+===============++ActiveHs has five main components, static files, web server, converter, interpreter and libraries:++~~~~~~~~~ {.dot}+Node [shape = none]+xml [label = ".xml, .png"]+exercise [label = "exercise\nfiles"]++javascript [label = <<FONT POINT-SIZE="20.0" COLOR="black">static files</FONT><BR/>.js, .css>]+server [label = <<FONT POINT-SIZE="20.0" COLOR="black">web server</FONT>>]+converter [label = <<FONT POINT-SIZE="20.0" COLOR="black">converter</FONT>>]+interpreter [label = <<FONT POINT-SIZE="20.0" COLOR="black">interpreter</FONT>>]+libraries [label = <<FONT POINT-SIZE="20.0" COLOR="black">libraries</FONT>>]+converter -> xml++converter -> exercise++Node [color = darkgreen, fontcolor = darkgreen]+lhs [label = ".lhs"]+lhs -> converter+template [label = ".template"]+template -> converter++Node [color = "#606060", fontcolor = "#606060"]+Edge [color = "#606060"]++server -> xml+server -> exercise+javascript -> server [dir = back]+template -> javascript+libraries -> lhs [dir = back]+interpreter -> exercise [dir = none]++{rank = same; libraries; template; javascript; lhs}+lhs -> template [style = invis]+{rank = same; exercise; interpreter}+~~~~~~~~~++Green files are the user's input.++----------------------------------++**libraries**+: The ActiveHs base libraries contain SVG graphics support and some auxiliary declarations.+ The base libraries should be imported in the .lhs files.+**converter**+: The converter converts literate Haskell files with pandoc comments to xhtml files with+ the help of the pandoc library. The template files are used during this process.+ The template files may refer to the static files but these files are not needed during+ the conversion. + Inline latex and graphviz content in the comments will be converted to png files. + Exercises in the comments will be converted to exercise files. +**static files**+: Static files are javascript and css files served statically. + These files are responsible for the slideshow mode and the AJAX input fields for the exercises in the xml+ files.+**web server**+: The web server serves static files and .xml and .png files generated by the converter. + The web server also handles Haskell expression evaluation requests with the help of the interpreter and + with the help of the exercise files generated by the converter.+**interpreter**+: The interpreter is a specialized Haskell interpreter which can+ evaluate expressions, compare expressions, test definitions and check definitions (with quickcheck).+ The exercise files contain the information needed to perform these tasks.++++Module Hierarchy+================++The following diagram contains the Haskell source files of ActiveHs (boxed nodes),+the main dependencies between them (edges between boxes) and+the main external dependencies (unboxed nodes).++The converter component consists of two modules: `Parse` and `Compile` (top part). +The web server component consists of the `Main` module and some auxiliary modules (`Cache` and `Args`; middle part). +The interpreter component consists of the remaining modules (bottom part).++~~~~~~~~~ {.dot}+Graph [rankdir = RL]++Node [shape = box]+Simple -> Smart -> Special -> Main+Parse -> Compile -> Main++Node [shape = none]+hint -> Simple+snap -> Main+pandoc -> Parse++Node [color = "#606060", fontcolor = "#606060"]+Edge [color = "#606060"]++Node [shape = box]+Specialize -> Smart+HoogleCustom -> Smart+Result -> Special+QuickCheck -> Special+Qualify -> Special+Cache -> Main++Node [shape = none]+hoogle -> HoogleCustom+quickcheck -> QuickCheck+"data-pprint" -> Smart+"dia-functions" -> Smart++Node [color = gray, fontcolor = gray]+Edge [color = gray]++Node [shape = box]+Lang -> Smart+Html -> Result+Args -> Main+Smart -> Compile [constraint = false]++Node [shape = none]+cmdargs -> Args+xhtml -> Html+"haskell-src" -> Parse+"snap logger" -> Smart+~~~~~~~~~+++Web Server Component+====================++The web server component consists of the `Main` module and the `Cache` and `Args` auxiliary modules.++Schematic handling of requests:++~~~~~~~~~ {.dot}+Graph [rankdir = LR]+Node [shape = none]+request -> get+request -> post+get -> "simple fileserve"+get -> "generate file from .lhs & serve"+post -> "interpreter action, maybe from cache"+~~~~~~~~~++If a requested .xml file does not exists, but there is+a corresponding .lhs file, +or the .xml file exists but the corresponding .lhs+file is newer,+then first the converter will be invoked+on the .lhs file, then the .xml file will be served. ++There are four different post request corresponding to the four different interpreter+actions (see below).+In any case, the web server tries to serve a cached answer.+If there is no cached answer, the interpreter will be invoked, and the+answer will be cached and served.++The `Cache` module implements a very simple cache.++The `Args` module is responsible for the command-line arguments.+++Converter Component+===================++Conversion is done in two main phases which are implemented in the `Parse` and `Compile` modules. ++`Parse` phase:++1. Comments are filtered out.+1. Parsing with the lhs + markdown pandoc reader function.+1. Find and parse ActiveHs commands in pandoc's inner document format.++`Compile` phase:++1. ActiveHs commands are converted into the pandoc's inner document format. + During this process the interpreter component may be invoked.+1. .dot and .latex code blocks are filtered out and converted into .png by external shell commands+1. The xhtml file is produced by the corresponding padoc writer function.+++Interpreter Component+=====================++The interpreter is built bottom-up as follows:++1. `hint` package ++ The `hint` package provides a simplified interface to the GHC API.+2. `Simple` module ++ This module provides an even more simplified and somewhat managed interface to `hint`. + [The main ideas are described here.](Economic_en.xml)+3. `Smart` module++ This module adds more functionality to the interface of `Simple`. + Main features added:++ - Type inference with the `:t` command+ - Kind inference with the `:k` command+ - Hoogle search with the `:?` command, based on `HoogleCustom`+ - Hoogle information search with the `:i` command, based on `HoogleCustom`+ - Automatic command selection (in most cases you don't need `:t`, `:k`, `:?` or `:i`)+ - Type specialization, based on `Specialize` (needed for the next two features)+ - Prettyprint values, based on `data-pprint` ([look at this for exaples](Show_en.xml))+ - Display numeric functions, based on `dia-functions` ([look at this for exaples](FunctionGraphs_en.xml))+ - Display expressions with type `Diagram`, based on `dia-functions` ([look at this for exaples](Diagrams_en.xml))+ - Error logging, based on `snap` logger+ - Basic internationalization support+4. `Special` module++ This module provides 4 special modes on top of `Smart`:++ - Expression evaluation+ - Expression comparison: Decide whether an expression is equal to a reference implementation.+ - Testing definitions: Decide whether the value of an expression is the same with the + given and with the reference implementation.+ - Checking definitions: Decide whether a definition is equal functionally to a reference implementation. + This mode is built on quickcheck and the definition testing mode.+++++++++
+ doc/UsersGuide_en.lhs view
@@ -0,0 +1,475 @@+% AcitveHs User's Guide++> module UsersGuide_en where+>+> import ActiveHs.Base+> import MyPrelude+> import Prelude ()+++Introduction+=============++ActiveHs is a Haskell source code presentation tool, developed for+education purposes.++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.++Note that this software has many rough edges; you are welcome to+work on it!+++Typical Usage+=============++1. Installation+1. Start the `activehs` server near an .lhs file+1. Open http://localhost:8000/*Modulename*.xml in a browser+4. Modify the .lhs file(s) & reload the page+1. Interact with the page+1. Go back to 4. if needed+1. Present your sources as interactive xhtml slides+1. Make your activehs server accessible from the internet+++Installation+============++ActiveHs installation: ++1. `cabal update` +1. `cabal install activehs`++The activehs package depends on the pandoc and snap-server packages,+so they will be installed automatically. +However, I propose to install them manually with the following flags:++- cabal install pandoc -fhighlighting+- cabal install snap-server -flibev+++The following software components are optional, but should be installed separately:++- [Graphviz](http://www.graphviz.org/)+- [LaTeX](https://secure.wikimedia.org/wikipedia/en/wiki/LaTeX) and [dvipng](https://savannah.nongnu.org/projects/dvipng/)++***********************++I had some linker error during linking the `activehs` executable.+It was about an undefined symbol in the Hoogle library and+I have made a workaround about it.+++++Command-Line Options+====================++For basic usage you don't have to give any options;+just run `activehs` in a directory with .lhs files inside.++See `activehs --help` for more help on command-line options.++++++Markup Overview+===============++Only literate Haskell files are supported (with .lhs extension).++After the module name import the `ActiveHs.Base` module:++ > module Example where+ >+ > import ActiveHs.Base++Note that the module header and the import list should be in+the same code block (no empty lines between them)!+++Markup which can be used in top level comments:++- [pandoc/markdown](http://johnmacfarlane.net/pandoc/README.html#pandocs-markdown) + Use [setext-style headers](http://johnmacfarlane.net/pandoc/README.html#setext-style-headers)+ instead of [atx-style headers](http://johnmacfarlane.net/pandoc/README.html#atx-style-headers),+ because atx-style headers interfere with the GHC .lhs preprocessor.+- Graphviz and LaTeX code segments (only if graphviz and LaTeX + dvipng is installed)+- ActiveHs commands+++Graphviz Code Segments+======================++Example:++ ~~~~~ {.dot}+ A -> B -> C -> B+ A -> C+ ~~~~~++Output:++~~~~~ {.dot}+A -> B -> C -> B+A -> C+~~~~~+++Example:++ ~~~~~ {.neato}+ A -> B -> C -> B+ A -> C+ ~~~~~++Output:++~~~~~ {.neato}+A -> B -> C -> B+A -> C+~~~~~++You can use the `.dot`, `.neato`, `.twopi`, `.circo`, `.fdp`, `.dfdp` segment names.++See the [graphviz gallery](http://www.graphviz.org/Gallery.php) for more complex examples.+++LaTeX Code Segments+======================++LaTeX code segments will be converted into .png pictures.++Example:++ ~~~~~~ {.latex}+ \mbox{min}(x,y) = + \left\{\begin{array}{ll}+ x&\mbox{if }x\le y,+ y&\mbox{otherwise}.+ \end{array}\right.+ ~~~~~~++Output:++~~~~~~ {.latex}+\mbox{min}(x,y) = +\left\{\begin{array}{ll}+x&\mbox{if }x\le y, \\+y&\mbox{otherwise}.+\end{array}\right.+~~~~~~+++Slides+======++Pressing key ‘a’ in the browser switch between slide and normal mode.++Markup example:+++ First Slide+ ===========++ slide content++ *********++ remark+++ Second Slide+ ============++ slide content++ *********++ remark+++*************++Each level one header starts a new slide.++In slide mode the remarks are not visible.+Remarks are the content after the first horizontal rule after each level one header.++++++ActiveHs Commands Overview+==========================++Every ActiveHs command begins with a letter followed by a `>` character and a space.++ActiveHs commands:++---- -----------------------------------------------------+`E>` **E**valuation+`F>` **F**olded evaluation+`A>` **A**nswer: show just the evaluated expression+`R>` **R**eply hidden; one should guess it+`H>` **H**idden test case+---- -----------------------------------------------------+++Evaluation Command+==================++Example:++ E> [1..]++Output (interactive form):++E> [1..]++Example:++ E> sin . abs++Output:++E> sin . abs++Example:++ E> :t [1..]++Output:++E> :t [1..]+++*********************++You may use the following colon-commands, but these are applied automatically too:++- `:t` -- type inference+- `:k` -- kind inference+- `:?` -- hoogle search (in the database given by a command-line option)+- `:i` -- information by hoogle (in the database given by a command-line option)++For other features see these guides:++- [Prettyprinted values](Show_en.xml)+- [Displayed functions](FunctionGraphs_en.xml)+- [Diagrams](Diagrams_en.xml)+++Folded Evaluation and Answer Commands+=========================++Evaluation example:++ E> 1 + 1++Output:++E> 1 + 1++Folded evaluation example:++ F> 1 + 1++Output:++F> 1 + 1++Answer example:++ A> 1 + 1++Output:++A> 1 + 1++********************++Folded evaluation is the same as evaluation, but the result is not shown for the first time. ++Answer is the same as evaluation, but only the result is shown.++++++Reply Command+=========================================++Example:++ Give an expression which is equal to the number of seconds in a day!++ R> 60 * 60 * 24++Output:++Give an expression which is equal to the number of seconds in a day!++R> 60 * 60 * 24++*******************************++If the equality cannot be checked for several reason, you get a reasonable detailed answer. +[See the second half of this page.](Show_en.xml)++++Exercises+=========================++It is possible to give more complex exercises to the readers.++Example: ++ Define the function `inc` which increments a number.++ > inc :: Num a => a -> a+ > inc = (+1)++ E> inc 3+ E> inc (4+4)++Output:++Define the function `inc` which increments a number.++> inc :: Num a => a -> a+> inc = (+1)++E> inc 3+E> inc (4+4)++******************************++What happens here?++1. The definition of `inc` was replaced by a form in the output.+ ActiveHs do this if literate Haskell code is immediately followed+ by ActiveHs commands like `E>`.+1. The user fill in the form (define `inc` here) and click on `Check` below the form.+1. The server will check the form content.+ The test cases are derived from the ActiveHs commands immediately+ after the literate Haskell code. + For example, if the command is `E> inc 3`,+ then the test case will be `inc 3 == Original.inc 3`, where+ `inc` is the function defined by the user and `Original.inc` is+ the definition given in the .lhs file.+1. If a the test case fails, a from will appear with that test case. + For example, if the user defines `inc = (+2)`, then `E> inc 3` fails,+ and `5 /= 4` will be shown because `inc 3` is not equal to `Original.inc 3`.+1. If all tests cases succeeds, an empty form will be shown in which+ the user can enter more tests.+++Exercises / QuickCheck tests+=========================++It is possible to give QuickCheck tests in exercises with the `H>` (**H**idden test) command.++Example:++ Define a function `plus` which adds two numbers.++ > plus :: Int -> Int -> Int+ > plus a b = a + b++ H> QCInt a ;; QCInt b ;; plus a b++Output:++Define a function `plus` which adds two numbers.++> plus :: Int -> Int -> Int+> plus a b = a + b++H> QCInt a ;; QCInt b ;; plus a b++(Try to define ``plus a b = 10 `min` a + b``)++***********************++Syntax of QuickCheck tests: ++pattern~1~ `;;` pattern~2~ ;; ... ;; pattern~n~ ;; expression++`QCInt` is a constructor which helps type checking.+Definition of `QCInt` is in the `ActiveHs.Base` module:++~~~~~ {.haskell}+newtype QCInt = QCInt Int+ deriving (Show, Arbitrary)+~~~~~++`ActiveHs.Base` defines to other constructors `QCBool` and `QCNat`. +Definition of `QCNat`: ++~~~~~ {.haskell}+newtype QCNat = QCNat Int+ deriving (Show)++instance Arbitrary QCNat where+ ....+~~~~~++You can define your own helper-constructors. +Just put the definitions in a separate visible module and import that module+in the .lhs file.++++Customization+==============++You can customize the generated xml files with templates. +The template mechanism is the following:++1. The `actives` server decides the language of the .lhs file. + The language is guessed from the end of the filename, before the+ extension and after the last underline.+ For example, if the file name is `Overview_en.lsh`, then the+ language is `en`. + If the language cannot be guessed then the default language+ is used which is `en`. The default language can be+ changed by a command-line option.+1. The server use the template file named *language*`.template`,+ like `en.template`. You can give the directory to search+ template files in with a command-line argument. + If you do not specify a template directory,+ the distribution's directory will be used which+ contains the `en.template` and `hu.template` template files.+1. In the template file you give the skeleton of the generated+ xml files. For example, you can import any custom css files.+++Currently there is no decent way to internationalize the messages+of the `activehs` server.+There is built-in support for English and Hungarian though; see+the Lang.hs file in sources.+++Internet Access+===============++If your activehs server is accessible from the internet, I+advise the following:++- Regenerate all pages with a script before publishing them:++ for A in *.lhs; curl --url http://localhost:8000/${A%.lhs}.xml || exit 1; done;++- Run the `activehs` server with+ the `--static` flag which prevents it from regenerating pages accidentally.++- Use the `--magicname` flag, otherwise the exercise solutions+ may be guessed by the users.++- Run a script which obeys the `activehs` server.+ There is an example script in the distribution (doc/watchserver.sh).+
+ doc/watchserver.sh view
@@ -0,0 +1,46 @@+#!/bin/sh+# Example script to watch an activehs server+#+# Run this script regularly.+# For example in FreeBSD you can put a line into the crontab file:+# env EDITOR=ee crontab -e+# /1 * * * * /path-to-script/watchserver.sh+++export DOCUMENTROOT=********; # fill this in+export PATH=********; # fill this in+export LANG="en_US.UTF-8";++# Date+D=`date +"%d/%b/%Y:%H:%M:%S"`;+# Request for the server+E="lang=en&c=eval&f=Syntax.hs&x=id \"$D\"&y=";+# Send the request+F=`curl --silent --show-error --max-time 15 --connect-timeout 10 --retry 3 --retry-delay 1 --data "$E" http://localhost:8000/ 2>err.txt`;+# Correct answer (each time different to by-pass the cache mechanism in activehs)+G="<code class=\"result\">"$D"</code><code> :: </code><code class=\"type\">[Char]</code>";++restartserver () {+ if pgrep activehs >/dev/null; then killall -9 activehs; fi;+ sleep 0.1;+ cd $DOCUMENTROOT; activehs --static +RTS -N -I2 2>/dev/null &+}++if [ "$F" = "$G" ];+then+ # Memory usage by the server+ M=`ps -A -o %mem= -o command= | grep -o -e '\([0-9]\+\)[.,][0-9]\+[ ]\+activehs' | sed -e 's/,//' -e 's/\.//'`;+ N=${M%activehs};+ # Limit memory usage+ if [ "$N" -gt "300" ];+ then + echo RESTART `date` CAUSE: Mem $N >> $DOCUMENTROOT/log/startserver.log;+ restartserver;+ else true;+ fi;+else + echo RESTART `date` CAUSE: Answer $F `cat err.txt` >> $DOCUMENTROOT/log/startserver.log;+ restartserver;+fi;++
+ template/en.template view
@@ -0,0 +1,20 @@+<?xml version="1.0" encoding="utf-8"?>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html xmlns="http://www.w3.org/1999/xhtml" lang="en" xml:lang="en"> +<head>+<title>$pagetitle$</title>+<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+<meta name="generator" content="pandoc" />+<link rel="shortcut icon" href="icon.ico" />+<script src="common_en.js" charset="utf-8" type="text/javascript"></script> +<link rel="stylesheet" href="common.css" type="text/css" />+</head>+<body onload="javascript:resetForms(); javascript:slidy_init();">+<div><h1 class="cover">$title$</h1>+<div id="info"></div>+$toc$+</div>+$body$+</body>+</html>+
+ template/hu.template view
@@ -0,0 +1,20 @@+<?xml version="1.0" encoding="utf-8"?>+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html xmlns="http://www.w3.org/1999/xhtml" lang="hu" xml:lang="hu"> +<head>+<title>$pagetitle$</title>+<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+<meta name="generator" content="pandoc" />+<link rel="shortcut icon" href="icon.ico" />+<script src="common_hu.js" charset="utf-8" type="text/javascript"></script> +<link rel="stylesheet" href="common.css" type="text/css" />+</head>+<body onload="javascript:resetForms(); javascript:slidy_init();">+<div><h1 class="cover">$title$</h1>+<div id="info"></div>+$toc$+</div>+$body$+</body>+</html>+