activehs 0.2.0.1 → 0.3
raw patch · 7 files changed
+150/−127 lines, 7 filesdep +Agdadep +blaze-htmldep +highlighting-katedep ~activehs-basedep ~arraydep ~base
Dependencies added: Agda, blaze-html, highlighting-kate
Dependency ranges changed: activehs-base, array, base, cmdargs, deepseq, filepath, old-time, pandoc, process, snap-core, snap-server, time
Files
- Converter.hs +36/−25
- Main.hs +3/−3
- Parse.hs +87/−73
- Qualify.hs +1/−1
- Smart.hs +3/−1
- Specialize.hs +1/−1
- activehs.cabal +19/−23
Converter.hs view
@@ -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 } ------------------
Main.hs view
@@ -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 )
Parse.hs view
@@ -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
Qualify.hs view
@@ -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
Smart.hs view
@@ -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
Specialize.hs view
@@ -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
activehs.cabal view
@@ -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: <http://pnyf.inf.elte.hu/fp/UsersGuide_en.xml>+ User's Guide: <http://pnyf.inf.elte.hu:8000/UsersGuide_en.xml> .- Developer's Documentation (partial): <http://pnyf.inf.elte.hu/fp/DevDoc_en.xml>+ Developer's Documentation (partial): <http://pnyf.inf.elte.hu:8000/DevDoc_en.xml> . The software is in prototype phase, although it already served more than 700 000 user requests at Eötvös Loránd University Budapest, Hungary. . Note that this software has many rough edges; you are welcome to work on it!- .- 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