diff --git a/Args.hs b/Args.hs
new file mode 100644
--- /dev/null
+++ b/Args.hs
@@ -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
+
+
+
diff --git a/Cache.hs b/Cache.hs
new file mode 100644
--- /dev/null
+++ b/Cache.hs
@@ -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
+
+
+
diff --git a/Converter.hs b/Converter.hs
new file mode 100644
--- /dev/null
+++ b/Converter.hs
@@ -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 "
"] ++ c
+ ++ [Text $ rawHtml "
"] ++ 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
+
+
+--------------------
+
+
+
diff --git a/HoogleCustom.hs b/HoogleCustom.hs
new file mode 100644
--- /dev/null
+++ b/HoogleCustom.hs
@@ -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
+
+
diff --git a/Html.hs b/Html.hs
new file mode 100644
--- /dev/null
+++ b/Html.hs
@@ -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, "');"]
+
+
diff --git a/LICENSE b/LICENSE
new file mode 100644
--- /dev/null
+++ b/LICENSE
@@ -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.
+
diff --git a/Lang.hs b/Lang.hs
new file mode 100644
--- /dev/null
+++ b/Lang.hs
@@ -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ó: "]
+ ]
+
diff --git a/Main.hs b/Main.hs
new file mode 100644
--- /dev/null
+++ b/Main.hs
@@ -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 "Page not found."
+ 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 "Too long request."
+ 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
+
+
diff --git a/Parse.hs b/Parse.hs
new file mode 100644
--- /dev/null
+++ b/Parse.hs
@@ -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
+
+
+
+
diff --git a/Qualify.hs b/Qualify.hs
new file mode 100644
--- /dev/null
+++ b/Qualify.hs
@@ -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
+-}
+
diff --git a/QuickCheck.hs b/QuickCheck.hs
new file mode 100644
--- /dev/null
+++ b/QuickCheck.hs
@@ -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
+
+
diff --git a/Result.hs b/Result.hs
new file mode 100644
--- /dev/null
+++ b/Result.hs
@@ -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
+
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Simple.hs b/Simple.hs
new file mode 100644
--- /dev/null
+++ b/Simple.hs
@@ -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
+
+
+
diff --git a/Smart.hs b/Smart.hs
new file mode 100644
--- /dev/null
+++ b/Smart.hs
@@ -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]
+
+
+
diff --git a/Special.hs b/Special.hs
new file mode 100644
--- /dev/null
+++ b/Special.hs
@@ -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
+
+
+
+
diff --git a/Specialize.hs b/Specialize.hs
new file mode 100644
--- /dev/null
+++ b/Specialize.hs
@@ -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 = [] -- !!!
+
+
diff --git a/activehs.cabal b/activehs.cabal
new file mode 100644
--- /dev/null
+++ b/activehs.cabal
@@ -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:
+ .
+ Developer's Documentation (partial):
+ .
+ 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
+
diff --git a/copy/common.css b/copy/common.css
new file mode 100644
--- /dev/null
+++ b/copy/common.css
@@ -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; */ }
+
diff --git a/copy/common_en.js b/copy/common_en.js
new file mode 100644
--- /dev/null
+++ b/copy/common_en.js
@@ -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 = 'Client error.';
+ } 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 = '
' + r + '
';
+ 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= 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);
+};
+
+
+
diff --git a/copy/common_hu.js b/copy/common_hu.js
new file mode 100644
--- /dev/null
+++ b/copy/common_hu.js
@@ -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 = 'Kliens hiba.';
+ } 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 = '
' + r + '
';
+ 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= 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);
+};
+
+
+
diff --git a/copy/icon.ico b/copy/icon.ico
new file mode 100644
Binary files /dev/null and b/copy/icon.ico differ
diff --git a/doc/DevDoc_en.lhs b/doc/DevDoc_en.lhs
new file mode 100644
--- /dev/null
+++ b/doc/DevDoc_en.lhs
@@ -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 = <static files .js, .css>]
+server [label = <web server>]
+converter [label = <converter>]
+interpreter [label = <interpreter>]
+libraries [label = <libraries>]
+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.
+
+
+
+
+
+
+
+
+
diff --git a/doc/UsersGuide_en.lhs b/doc/UsersGuide_en.lhs
new file mode 100644
--- /dev/null
+++ b/doc/UsersGuide_en.lhs
@@ -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).
+
diff --git a/doc/watchserver.sh b/doc/watchserver.sh
new file mode 100644
--- /dev/null
+++ b/doc/watchserver.sh
@@ -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=""$D" :: [Char]";
+
+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;
+
+
diff --git a/template/en.template b/template/en.template
new file mode 100644
--- /dev/null
+++ b/template/en.template
@@ -0,0 +1,20 @@
+
+
+
+
+$pagetitle$
+
+
+
+
+
+
+
+