diff --git a/Converter.hs b/Converter.hs --- a/Converter.hs +++ b/Converter.hs @@ -12,9 +12,14 @@ import Lang import Args -import Language.Haskell.Exts.Pretty -import Language.Haskell.Exts.Syntax +import qualified Language.Haskell.Exts.Pretty as HPty +import qualified Language.Haskell.Exts.Syntax as HSyn +{- Agda support (unfinished) +import qualified Agda.Syntax.Concrete as ASyn +import qualified Agda.Utils.Pretty as AUtil +-} + import Text.XHtml.Strict hiding (lang) import Text.Pandoc @@ -44,10 +49,11 @@ 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 + mainParse HaskellMode input >>= extract HaskellMode verbose ghci args what whenOutOfDate () output input2 $ do + -- watch object code (*.lagdai?) like in haskell mode? when verbose $ putStrLn $ output ++ " is out of date, regenerating" - mainParse True input2 >>= extract verbose ghci args what + mainParse AgdaMode input2 >>= extract AgdaMode verbose ghci args what -- return True where input = sourcedir what <.> "lhs" @@ -56,10 +62,10 @@ 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 +extract :: ParseMode -> Bool -> TaskChan -> Args -> Language -> Doc -> IO () +extract mode verbose ghci (Args {lang, templatedir, sourcedir, exercisedir, gendir, magicname}) what (Doc meta modu ss) = do - writeEx (what <.> "hs") [showEnv $ importsHiding []] + writeEx (what <.> ext) [showEnv $ importsHiding []] ss' <- zipWithM processBlock [1..] $ preprocessForSlides ss ht <- readFile' $ templatedir lang' ++ ".template" @@ -72,6 +78,10 @@ } where + ext = case mode of + HaskellMode -> "hs" + AgdaMode -> "agda" + lang' = case span (/= '_') . reverse $ what of (l, "") -> lang (l, _) | length l > 2 -> lang @@ -93,12 +103,13 @@ when verbose $ putStrLn $ "executing " ++ s system s - importsHiding funnames - = prettyPrint $ - Module loc (ModuleName "Main") directives Nothing Nothing + importsHiding funnames = case mode of + HaskellMode -> HPty.prettyPrint $ + HSyn.Module loc (HSyn.ModuleName "Main") directives Nothing Nothing ([mkImport modname funnames, mkImport_ ('X':magicname) modname] ++ imps) [] - where - (Module loc (ModuleName modname) directives _ _ imps _) = modu + AgdaMode -> "" + where + HaskellModule (HSyn.Module loc (HSyn.ModuleName modname) directives _ _ imps _) = modu mkCodeBlock l = [ CodeBlock ("", ["haskell"], []) $ intercalate "\n" l | not $ null l ] @@ -112,7 +123,7 @@ = return $ mkCodeBlock $ visihidden processBlock _ (Exercise _ visi hidden funnames is) = do - let i = show $ mkId $ unlines $ map printName funnames + let i = show $ mkId $ unlines funnames j = "_j" ++ i fn = what ++ "_" ++ i <.> "hs" (static_, inForm, rows) = if null hidden @@ -121,7 +132,7 @@ writeEx fn [ showEnv $ importsHiding funnames ++ "\n" ++ unlines static_ , unlines $ hidden, show $ map parseQuickCheck is, j, i - , show $ map printName funnames ] + , show funnames ] return $ mkCodeBlock static_ ++ showBlockSimple lang' fn i rows (intercalate "\n" inForm) @@ -235,21 +246,21 @@ ++ prelude ++ "\n{-# LINE 1 \"input\" #-}\n" -mkImport :: String -> [Name] -> ImportDecl +mkImport :: String -> [Name] -> HSyn.ImportDecl mkImport m d - = ImportDecl - { importLoc = undefined - , importModule = ModuleName m - , importQualified = False - , importSrc = False - , importPkg = Nothing - , importAs = Nothing - , importSpecs = Just (True, map IVar d) + = HSyn.ImportDecl + { HSyn.importLoc = undefined + , HSyn.importModule = HSyn.ModuleName m + , HSyn.importQualified = False + , HSyn.importSrc = False + , HSyn.importPkg = Nothing + , HSyn.importAs = Nothing + , HSyn.importSpecs = Just (True, map (HSyn.IVar . HSyn.Ident) d) } -mkImport_ :: String -> String -> ImportDecl +mkImport_ :: String -> String -> HSyn.ImportDecl mkImport_ magic m - = (mkImport m []) { importQualified = True, importAs = Just $ ModuleName magic } + = (mkImport m []) { HSyn.importQualified = True, HSyn.importAs = Just $ HSyn.ModuleName magic } ------------------ diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -12,7 +12,7 @@ import Result import Html -import Snap.Types +import Snap.Core import Snap.Http.Server (httpServe) import Snap.Http.Server.Config import Snap.Util.FileServe (getSafePath, serveDirectoryWith, simpleDirectoryConfig) @@ -52,8 +52,8 @@ 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")) + . setAccessLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir "access.log")) + . setErrorLog (if null logdir then ConfigNoLog else ConfigFileLog (logdir "error.log")) $ emptyConfig ) diff --git a/Parse.hs b/Parse.hs --- a/Parse.hs +++ b/Parse.hs @@ -1,8 +1,11 @@ {-# LANGUAGE RelaxedPolyRec, PatternGuards, ViewPatterns #-} module Parse - ( Doc (..) + ( ParseMode (..) + , Module (..) + , Doc (..) , BBlock (..) + , Name , Prompt , mainParse , getCommand @@ -12,24 +15,30 @@ import Text.Pandoc -import Language.Haskell.Exts.Parser -import Language.Haskell.Exts.Syntax +import AgdaHighlight -{- 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 qualified Language.Haskell.Exts.Parser as HPar +import qualified Language.Haskell.Exts.Syntax as HSyn +{- Agda support (unfinished) -} +import qualified Agda.Syntax.Parser as APar +import qualified Agda.Syntax.Concrete as ASyn + 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 ParseMode = HaskellMode | AgdaMode + deriving (Show, Enum, Eq) ---------------------------------- data structures +data Module + = HaskellModule HSyn.Module + | AgdaModule ASyn.Module + deriving (Show) data Doc = Doc @@ -54,60 +63,67 @@ 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 +type Name = String +----------------------------------- commandList, testCommandList :: String commandList = "AaRr" ++ testCommandList testCommandList = "EeFfH" +----------------------------------- +mainParse :: ParseMode -> FilePath -> IO Doc +mainParse mode s = do + c <- readFile s + case readMarkdown pState . unlines . concatMap preprocess . lines $ c of + Pandoc meta (CodeBlock ("",["sourceCode","literate","haskell"],[]) h: blocks) -> do + header <- parseModule mode $ h + fmap (Doc meta header) $ collectTests mode $ map (highlight . interpreter . Text) blocks + Pandoc meta blocks -> do + header <- parseModule mode $ "module Unknown where" + fmap (Doc meta header) $ collectTests mode $ map (highlight . interpreter . Text) blocks + where + parseModule :: ParseMode -> String -> IO Module + parseModule AgdaMode m = fmap AgdaModule (APar.parse APar.moduleParser m) + parseModule HaskellMode m = case HPar.parseModuleWithMode HPar.defaultParseMode m of + (HPar.ParseOk m) -> return $ HaskellModule m + parseError -> fail $ "parseHeader: " ++ show parseError + + preprocess (c:'>':' ':l) | c `elem` commandList + = ["~~~~~ {." ++ [c] ++ "}", dropWhile (==' ') l, "~~~~~", ""] + preprocess ('|':l) + = [] + -- drop lines ending with "--" + preprocess l | drop ((length l) - 2) l == "--" = [] + | otherwise = [l] + + pState = defaultParserState + { stateSmart = True + , stateStandalone = True + , stateLiterateHaskell = True + } + + interpreter :: BBlock -> BBlock + interpreter (Text (CodeBlock ("",[[x]],[]) e)) | x `elem` commandList + = OneLineExercise (toUpper x) (isUpper x) e + interpreter a = a + + highlight :: BBlock -> BBlock + highlight (Text (CodeBlock ("",["sourceCode","literate","haskell"],[]) code)) | mode == AgdaMode + = (Text (RawBlock "html" $ highlightAgdaAsXHtml code)) + highlight a = a + ------------------------------ -collectTests :: Bool -> [BBlock] -> IO [BBlock] -collectTests agda l = zipWithM f l $ tail $ tails l where +collectTests :: ParseMode -> [BBlock] -> IO [BBlock] +collectTests mode 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 + (visible, hidden, funnames) <- processLines mode isExercise h let exps = [snd $ getCommand e | (OneLineExercise _ _ e) <- takeWhile p l] @@ -118,13 +134,15 @@ f x _ = return x -processLines :: Bool -> Bool -> String -> IO ([String], [String], [Name]) ---processLines True = processAgdaLines -processLines _ = processHaskellLines +processLines :: ParseMode -> Bool -> String -> IO ([String], [String], [Name]) +processLines AgdaMode = processAgdaLines +processLines HaskellMode = processHaskellLines -{- Agda support (unfinished) +{- Agda support (unfinished) -} processAgdaLines :: Bool -> String -> IO ([String], [String], [Name]) processAgdaLines isExercise l_ = do + return ([], [], []) +{- let l = parts l_ @@ -153,27 +171,27 @@ 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 + x = zip l $ map (HPar.parseDeclWithMode HPar.defaultParseMode . 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 (HPar.ParseOk x) = case x of + HSyn.TypeSig _ a _ -> map printName a + HSyn.PatBind _ (HSyn.PVar a) _ _ _ -> [printName a] + HSyn.FunBind (HSyn.Match _ a _ _ _ _ :_) -> [printName a] + HSyn.TypeDecl _ a _ _ -> [printName a] + HSyn.DataDecl _ _ _ a _ x _ -> printName a: [printName n | HSyn.QualConDecl _ _ _ y<-x, n <- getN y] + _ -> [] getFName _ = [] - getN (ConDecl n _) = [n] - getN (InfixConDecl _ n _) = [n] - getN (RecDecl n l) = n: concatMap fst l + getN (HSyn.ConDecl n _) = [n] + getN (HSyn.InfixConDecl _ n _) = [n] + getN (HSyn.RecDecl n l) = n: concatMap fst l - isVisible (ParseOk (TypeSig _ _ _)) = True - isVisible (ParseOk (InfixDecl _ _ _ _)) = True + isVisible (HPar.ParseOk (HSyn.TypeSig _ _ _)) = True + isVisible (HPar.ParseOk (HSyn.InfixDecl _ _ _ _)) = True isVisible _ = not isExercise (visible, hidden) = partition (isVisible . snd) x @@ -204,10 +222,6 @@ parseQuickCheck s = case splitOn ";;" s of l -> (init l, last l) -printName :: Name -> String -printName (Ident x) = x -printName (Symbol x) = x - - - - +printName :: HSyn.Name -> Name +printName (HSyn.Ident x) = x +printName (HSyn.Symbol x) = x diff --git a/Qualify.hs b/Qualify.hs --- a/Qualify.hs +++ b/Qualify.hs @@ -20,7 +20,7 @@ -> [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 +qualify q ns x = case parseExpWithMode defaultParseMode x of ParseOk y -> Right $ prettyPrint $ runReader (trExp y) ns e -> Left $ show e where diff --git a/Smart.hs b/Smart.hs --- a/Smart.hs +++ b/Smart.hs @@ -49,7 +49,9 @@ 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" + -- log <- newLogger $ logfilebase ++ "_" ++ formatTime defaultTimeLocale "%Y-%m-%d-%H:%M:%S" ti ++ ".log" + -- colons are not supported in filenames under windows + 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 diff --git a/Specialize.hs b/Specialize.hs --- a/Specialize.hs +++ b/Specialize.hs @@ -15,7 +15,7 @@ specialize :: String -> Either String (String, String) specialize a - = case parseTypeWithMode (defaultParseMode {extensions = [FlexibleContexts], fixities = []}) a of + = case parseTypeWithMode (defaultParseMode {extensions = [FlexibleContexts]}) a of ParseFailed loc s -> Left $ show s ParseOk t -> let diff --git a/activehs.cabal b/activehs.cabal --- a/activehs.cabal +++ b/activehs.cabal @@ -1,27 +1,25 @@ name: activehs -version: 0.2.0.1 +version: 0.3 category: Education, Documentation synopsis: Haskell code presentation tool description: ActiveHs is a Haskell source code presentation tool, developed for education purposes. . - User's Guide: + User's Guide: . - Developer's Documentation (partial): + 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! - . - Changes since 0.2: Correct links and css in documentation. stability: alpha license: BSD3 license-file: LICENSE author: Péter Diviánszky -maintainer: divipp@gmail.com +maintainer: divip@aszt.inf.elte.hu cabal-version: >=1.6 build-type: Simple data-files: @@ -33,10 +31,6 @@ 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: @@ -59,36 +53,38 @@ Special Build-Depends: --- Agda >= 2.2 && < 2.3, + Agda, + highlighting-kate, 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, + activehs-base >= 0.2 && < 0.4, data-pprint >= 0.2 && < 0.3, - base >= 4.0 && < 4.4, + base >= 4.0 && < 4.6, QuickCheck >= 2.4 && < 2.5, - array >= 0.3 && < 0.4, + array >= 0.3 && < 0.5, directory >= 1.1 && < 1.2, containers >= 0.4 && < 0.5, - filepath >= 1.2 && < 1.3, + filepath >= 1.2 && < 1.4, text >= 0.11 && < 0.12, - snap-core >= 0.5 && < 0.6, - snap-server >= 0.5 && < 0.6, + snap-core >= 0.6 && < 0.8, + snap-server >= 0.6 && < 0.8, 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, + blaze-html >= 0.4 && < 0.5, pureMD5 >= 2.1 && < 2.2, - deepseq >= 1.1 && < 1.2, + deepseq >= 1.1 && < 1.4, 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, + pandoc >= 1.8 && < 1.10, + time >= 1.2 && < 1.5, + old-time >= 1.0 && < 1.2, + process >= 1.0 && < 1.2, 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 + cmdargs >= 0.7 && < 0.10