MagicHaskeller 0.9.6.4.6 → 0.9.6.4.7
raw patch · 9 files changed
+163/−104 lines, 9 filesdep +timedep −old-time
Dependencies added: time
Dependencies removed: old-time
Files
- Backend.hs +4/−0
- CGI.lhs +2/−1
- MagicHaskeller.cabal +9/−8
- MagicHaskeller/CGI.lhs +36/−27
- MagicHaskeller/ExpToHtml.hs +2/−16
- MagicHaskeller/GetTime.hs +5/−4
- MagicHaskeller/SimpleServer.hs +51/−48
- MagicHaskeller/VersionInfo.hs +21/−0
- changelog.txt +33/−0
+ Backend.hs view
@@ -0,0 +1,4 @@+import MagicHaskeller.SimpleServer+import MagicHaskeller.VersionInfo++main = main' $ "MagicHaskeller/MagicExceller backend server version " ++ versionInfo
CGI.lhs view
@@ -9,6 +9,7 @@ module Main(main) where import MagicHaskeller.CGI import Network.CGI+import MagicHaskeller.VersionInfo -main = main' runCGI+main = main' versionInfo runCGI \end{code}
MagicHaskeller.cabal view
@@ -1,5 +1,5 @@ Name: MagicHaskeller-Version: 0.9.6.4.6+Version: 0.9.6.4.7 Cabal-Version: >= 1.8 License: BSD3 License-file: LICENSE @@ -16,7 +16,7 @@ Build-Type: Simple Category: Language data-files: ExperimIOP.hs MagicHaskeller/predicates MagicHaskeller/predicatesAug2014 MagicHaskeller.conf MagicHaskeller/predicatesServed-Extra-source-files: xlmap+Extra-source-files: xlmap changelog.txt -- Tested-with: GHC == 6.12.1 Tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.4 @@ -45,7 +45,7 @@ -- Flag Benchmark Library- Build-depends: old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable+ Build-depends: time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable Exposed-modules: MagicHaskeller, Control.Monad.Search.Combinatorial, Control.Monad.Search.Best, MagicHaskeller.ProgGen, MagicHaskeller.ProgGenSF, MagicHaskeller.ProgGenSFIORef, MagicHaskeller.Expression, MagicHaskeller.LibTH, MagicHaskeller.Analytical, MagicHaskeller.Options, MagicHaskeller.Classification, MagicHaskeller.GetTime, MagicHaskeller.Minimal, MagicHaskeller.IOGenerator, MagicHaskeller.FastRatio, MagicHaskeller.LibExcel Other-modules: MagicHaskeller.MemoToFiles, MagicHaskeller.ShortString, @@ -57,8 +57,8 @@ MagicHaskeller.ExprStaged, MagicHaskeller.Combinators, MagicHaskeller.ReadDynamic, MagicHaskeller.MyDynamic, MagicHaskeller.ClassifyDM, MagicHaskeller.ProgramGenerator, MagicHaskeller.Analytical.FMExpr, MagicHaskeller.Analytical.Parser, MagicHaskeller.Analytical.Syntax, MagicHaskeller.Analytical.UniT, MagicHaskeller.Analytical.Synthesize,- MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged- Paths_MagicHaskeller+ MagicHaskeller.ExpToHtml, MagicHaskeller.FMType, MagicHaskeller.NearEq, MagicHaskeller.ClassLib, MagicHaskeller.LibExcelStaged,+ Paths_MagicHaskeller, MagicHaskeller.VersionInfo Extensions: CPP, TemplateHaskell cpp-options: -DCHTO -DCABAL @@ -84,8 +84,9 @@ Build-depends: network < 2.6, network-uri < 2.6 Executable MagicHaskeller- Main-is: MagicHaskeller/SimpleServer.hs- Build-depends: MagicHaskeller, old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, process, monad-par, transformers, abstract-par, ghc-paths, ghc+ Main-is: Backend.hs+ Build-depends: MagicHaskeller, time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, process, monad-par, transformers, abstract-par, ghc-paths, ghc+ Other-modules: MagicHaskeller.SimpleServer GHC-options: -threaded -feager-blackholing -rtsopts -- In my experience we should never use -O2 here --- it causes memory leak when compiled with GHC 7.6.3. Extensions: CPP, TemplateHaskell@@ -116,7 +117,7 @@ -- Non-UNIX servers cannot use mueval, which means the functionality of generating input/output examples is not available. Executable MagicHaskeller.cgi Main-is: CGI.lhs- Build-depends: old-time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable,+ Build-depends: time, template-haskell, base >= 4 && < 5, syb, containers, array, random, directory, bytestring, mtl, html, pretty, hashable, MagicHaskeller, cgi, hint, extensible-exceptions, haskell-src Other-modules: MagicHaskeller.CGI
MagicHaskeller/CGI.lhs view
@@ -78,7 +78,7 @@ languageToTitle LExcel = "MagicExceller Server" languageToTitle LJavaScript = "MagicJavaScripter" -firstlines config showAbsents predicate =+firstlines verInfo config showAbsents predicate = "<HTML>" ++ " <HEAD>" ++ " <TITLE> " ++ configToTitle config ++ " </TITLE>" ++@@ -95,16 +95,24 @@ " .absent a:link {color: #4477cc;} \n" ++ " .absent a:visited {color: #807780;} \n" ++ " --> \n" ++- " </style> \n" +++ " </style> \n" ++ dragStart ++ " </HEAD>" ++ " <BODY>" ++ " <H1> " ++ configToTitle config ++ " </H1>" ++- " <div id='version' align='right'>(CGI frontend version " ++ versionInfo ++ ")</div>" +++ " <div id='version' align='right'>(CGI frontend version " ++ verInfo ++ ")</div>" ++ " Specify a function f by writing a predicate as a boolean-valued expression. You will get functions generalizing the specification.<BR>" ++ predicateBox (myPath config) "90" showAbsents predicate ++ (case computerLanguage config of LHaskell -> "Help, examples, etc. <a href='/~skata/MagicHaskeller.html'>in English</a> / <a href='/~skata/MagicHaskeller-j.html'>in Japanese</a>" LExcel -> "Help, examples, etc. <a href='/~skata/MagicExceller.html?lang=en'>in English</a> / <a href='/~skata/MagicExceller.html?lang=ja'>in Japanese</a>")+dragStart =+ " <script type=\"text/javascript\"> \n" +++ " <!-- \n" +++ " function dragStart(event) {" +++ " event.dataTransfer.setData('text/plain', event.target.textContent || event.target.innerText || '');" +++ " } \n" +++ " //--> \n" +++ " </script>\n" -- We want to show the following button only when Javascript is enabled. absentButton True = " <script type=\"text/javascript\"> \n" ++@@ -224,19 +232,19 @@ unavailable config = detailsHead config ++ "<p>We are sorry, but this functionality is not provided by the CGI frontend built for non-UNIX servers.</p>" ++ lastLines False -main = main' runCGI-main' run = do +main = main' "(Version unknown)" runCGI+main' verInfo run = do progName <- getProgName let configFileName = maybe (dropWhileEnd (/='.') progName ++ "conf") id mbConfigFileName config <- do str <- readFile configFileName return $ readUrk str `catch` \(SomeException _) -> do hPutStrLn stderr $ "Warning: could not read the config file" ++ shows configFileName ". Using the default." return defaultConfig- run (handleErrors (cgiMain $ config{myPath = myPath config ++ progName}))+ run (handleErrors (cgiMain verInfo $ config{myPath = myPath config ++ progName})) simpleMain = do progName <- getProgName runCGI (handleErrors $ simpleCgiMain $ defaultConfig{myPath = myPath defaultConfig ++ progName})-cgiMain, simpleCgiMain :: Config -> CGI CGIResult-cgiMain config+cgiMain :: String -> Config -> CGI CGIResult+cgiMain verInfo config = let myPathName = myPath config in do -- firstlines <- liftIO $ readFile "firstlines" mbXL <- getInput "xl"@@ -246,10 +254,10 @@ let showAbsents = isJust mbAbsent mbPred <- getInput "predicate" case mbPred of- Just command@(':':xs) | not $ all (`elem` "!@#$%&*+./<=>?\\^|-~:") xs -> passCommand config showAbsents command -- Just pass it if it is a command. (But be careful about any danger.) + Just command@(':':xs) | not $ all (`elem` "!@#$%&*+./<=>?\\^|-~:") xs -> passCommand verInfo config showAbsents command -- Just pass it if it is a command. (But be careful about any danger.) -- If unknown commands are also passed without any checking, the backend server must check them and print an error message when necessary. Just predicate - | all isSpace predicate -> defaultPage config+ | all isSpace predicate -> defaultPage verInfo config | otherwise -> do let qBox = queryBox myPathName (show $ length predicate `max` 10) showAbsents predicate predBox = qBox "Synthesize f"@@ -261,7 +269,7 @@ outputNothing _ -> do setHeader "Content-type" "text/html" if faru predicate- then organizeSynthesis config showAbsents predicate useJS+ then organizeSynthesis verInfo config showAbsents predicate useJS else #ifdef UNIX case fixCandidate predicate of@@ -302,7 +310,7 @@ #else output $ unavailable config #endif- Nothing -> defaultPage config+ Nothing -> defaultPage verInfo config -- blameQuery predBox = "I'm afraid that the expression " ++ predBox ++ " you provided is an invalid Haskell expression, or has an unexpected type." ++ ghcComplaint -- blameSuggestion candidate = "I'm afraid that your candidate expression<br>" ++ candidate ++ "<br>is either invalid as a Haskell expression or inconsistent with the type of the predicate."@@ -412,9 +420,9 @@ \end{code} \begin{code}-showError config predicate message = output $ firstlines config False predicate ++ message ++ lastLines False+showError verInfo config predicate message = output $ firstlines verInfo config False predicate ++ message ++ lastLines False -organizeSynthesis config showAbsents predicate useJS = do+organizeSynthesis verInfo config showAbsents predicate useJS = do mbIns <- getInput "inputs" mbOut <- getInput "output" let augPred@@ -426,16 +434,16 @@ case review augPred of Nothing -> - showError config augPred+ showError verInfo config augPred "<br><br>Error: <b>let</b> expressions and <b>where</b> clauses are prohibited here. You can still use <b>case</b> expressions without <b>where</b> clauses for non-recursive bindings.<br>" Just (predi, corrected) -> if needSignature config then case addSignature predi of- [] -> showError config augPred "<br><br>lex error<br>"- [sigPred] -> organizeSynthesis' config True showAbsents predi sigPred useJS- else organizeSynthesis' config corrected showAbsents predi predi useJS+ [] -> showError verInfo config augPred "<br><br>lex error<br>"+ [sigPred] -> organizeSynthesis' verInfo config True showAbsents predi sigPred useJS+ else organizeSynthesis' verInfo config corrected showAbsents predi predi useJS -organizeSynthesis' config corrected showAbsents predicate sigPred useJS = do+organizeSynthesis' verInfo config corrected showAbsents predicate sigPred useJS = do mbPage <- readInput "page" mbDepth <- readInput "depth" @@ -463,16 +471,16 @@ case takeNFORMs (pagesize config) (dropNFORMs (pred pg * pagesize config) result) of (True, sc) -> sc ++ next (myPath config) (succ pg) showAbsents predicate (False,sc) -> sc- output $ firstlines config showAbsents predicate ++ body ++ lastLines useJS+ output $ firstlines verInfo config showAbsents predicate ++ body ++ lastLines useJS -passCommand config showAbsents command = do+passCommand verInfo config showAbsents command = do result <- liftIO $ synthesize config command- output $ firstlines config showAbsents command ++ "<p>" ++ result ++ lastLines False+ output $ firstlines verInfo config showAbsents command ++ "<p>" ++ result ++ lastLines False -defaultPage :: Config -> CGI CGIResult-defaultPage config = do +defaultPage :: String -> Config -> CGI CGIResult+defaultPage verInfo config = do setHeader "Content-type" "text/html"- showError config "" ""+ showError verInfo config "" "" stringToHtmlStringBr = concatMap (\c -> case c of {'\n' -> "<br>";_->[c]}) . stringToHtmlString @@ -601,13 +609,14 @@ hGetContents handle -- just for testing and debugging+simpleCgiMain :: Config -> CGI CGIResult simpleCgiMain config = do -- firstlines <- liftIO $ readFile "firstlines" setHeader "Content-type" "text/html; charset=EUC-JP" mbPred <- getInput "predicate" case mbPred of Just predicate -> do result <- liftIO $ synthesize config predicate- output $ firstlines config False predicate ++ unlines (take 3 $ lines result) ++ lastLines False- Nothing -> output $ firstlines config False examplePredicate ++ lastLines False+ output $ firstlines "" config False predicate ++ unlines (take 3 $ lines result) ++ lastLines False+ Nothing -> output $ firstlines "" config False examplePredicate ++ lastLines False readUrk :: Read a => String -> a readUrk xs = case reads xs of [(v,ys)] | all isSpace ys -> v
MagicHaskeller/ExpToHtml.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE CPP, TemplateHaskell #-} module MagicHaskeller.ExpToHtml(QueryOptions(..), defaultQO, - versionInfo, mhVersion, ghcVersion, review, expToPlainString, expSigToString, refer, pprnn, annotateFree, annotateString, Language(..)) where import Language.Haskell.TH as TH@@ -18,24 +17,11 @@ import Data.List((\\)) import Control.Monad(mplus) -#ifdef CABAL-import Paths_MagicHaskeller(version)-import Data.Version(showVersion)-#endif- -- Maybe QueryOptions should be put in a new module. data QueryOptions = Q {depth :: Int, absents :: Bool} deriving (Read, Show) defaultQO = Q {depth = 7, absents = False} -versionInfo, mhVersion, ghcVersion :: String-versionInfo = mhVersion ++ " built with GHC-" ++ ghcVersion-#ifdef CABAL-mhVersion = showVersion version-#else-mhVersion = ""-#endif-ghcVersion = case __GLASGOW_HASKELL__ `divMod` 100 of (b,s) -> shows b $ '.' : show s data Language = LHaskell | LExcel | LJavaScript deriving (Read, Show, Eq)@@ -87,8 +73,8 @@ mkButton lang predStr sig expr | usesBlackListed expr = body ++ "<br>" | otherwise = "<FORM"++ (if isAbsent expr then " class='absent'" else "") ++">" -- ++body++" <input type='submit' value='Exemplify'>"- ++"<input type='submit' value='Exemplify'> f = "++body- ++"<input type=hidden name='predicate' value='" ++ concatMap escapeHTML predStr ++ "'><input type=hidden name='candidate' value='" ++ concatMap escapeHTML pprExp ++ sig ++ "'></FORM>"+ ++"<input type='submit' value='Exemplify'> f = <span draggable='True' ondragstart='dragStart(event)'>"++body+ ++"</span><input type=hidden name='predicate' value='" ++ concatMap escapeHTML predStr ++ "'><input type=hidden name='candidate' value='" ++ concatMap escapeHTML pprExp ++ sig ++ "'></FORM>" where pprExp = pprnn expr body = annotateString lang pprExp -- <FORM>でやる場合、 <br>をつけると改行しすぎ。
MagicHaskeller/GetTime.hs view
@@ -3,7 +3,8 @@ -- module MagicHaskeller.GetTime where import System.CPUTime-import System.Time -- better than Time in Haskell98 Library in that the former supports pretty printing TimeDiff.+-- import System.Time -- better than Time in Haskell98 Library in that the former supports pretty printing TimeDiff.+import Data.Time import System.IO import Control.Monad(liftM2) @@ -16,12 +17,12 @@ batchRun (io:ios) = liftM2 (:) (fmap snd $ time io) (batchRun ios) time :: IO a -> IO (a, Integer)-time act = do beginCT <- getClockTime+time act = do beginCT <- getCurrentTime begin <- getCPUTime result <- act end <- getCPUTime- endCT <- getClockTime- hPutStrLn stderr (showZero (timeDiffToString (diffClockTimes endCT beginCT)) ++ " in real,")+ endCT <- getCurrentTime+ hPutStrLn stderr (show (diffUTCTime endCT beginCT) ++ " in real,") -- hPutStrLn stderr (shows (end-begin) " plusminus " ++ shows cpuTimePrecision " picoseconds spent.") hPutStrLn stderr (showCPUTime (end-begin) ++ " seconds in CPU time spent.") return (result, end-begin)
MagicHaskeller/SimpleServer.hs view
@@ -1,5 +1,7 @@ -- Do not forget -threaded! --+module MagicHaskeller.SimpleServer(main') where+ import MagicHaskeller.LibTH import MagicHaskeller.LibExcel @@ -25,12 +27,13 @@ import Data.Char(isAlphaNum, isSpace) import Text.Html(stringToHtmlString) -import MagicHaskeller.ExpToHtml(QueryOptions(..), defaultQO, versionInfo, expToPlainString, expSigToString, Language(..))+import MagicHaskeller.ExpToHtml(QueryOptions(..), defaultQO, expToPlainString, expSigToString, Language(..)) import Unsafe.Coerce import MagicHaskeller.GetTime-import System.Time+-- import System.Time+import Data.Time import System.Console.GetOpt import System.Environment@@ -165,18 +168,16 @@ procFlag st (ParallelTraining fp) = st{parallelTraining = Just fp} procFlag st (PostProcessor pp) = st{postprocessor = pp} -versionString = "MagicHaskeller/MagicExceller backend server version " ++ versionInfo--main :: IO ()-main = do+main' :: String -> IO ()+main' versionString = do (flags,args) <- readOpts- let stat = procFlags flags+ let so = procFlags flags hPutStrLn stderr versionString qhandle <- openFile queryOut AppendMode- beginCT <- getClockTime+ beginCT <- getCurrentTime hPutStrLn stderr ("started at " ++ show beginCT) - pgf <- case (functionSet stat, memoSize stat) of + pgf <- case (functionSet so, memoSize so) of (PGFull, Nothing) -> liftIO mkPgFull (PGFull, Just sz) -> return $ pgfulls !! sz (PGWithDoubleRatio, Nothing) -> return $ pgWithDoubleRatio@@ -192,28 +193,29 @@ hscEnv <- prepareGHCAPI ["MagicHaskeller.Minimal","MagicHaskeller.FastRatio"] -- (Fast)Ratio must be here if Ratio is referred by the default declaration. #if __GLASGOW_HASKELL__ >= 706- hscEnv <- case defaultTypes stat of Nothing -> return hscEnv- Just def -> declareDefaults hscEnv def+ hscEnv <- case defaultTypes so of Nothing -> return hscEnv+ Just def -> declareDefaults hscEnv def #endif- case (parallelTraining stat, sequentialTraining stat) of+ let stat = (versionString, qhandle, so, pgf, hscEnv)+ case (parallelTraining so, sequentialTraining so) of (Just fp, Just fs) -> do -- In this case, we make sure sequantial training starts after all the parallel training processes have finished. (The sequential training will be done for testing and benchmarking purposes.)- trainPara stat pgf hscEnv fp- trainSeq qhandle stat pgf hscEnv fs+ trainPara stat fp+ trainSeq stat fs (Just fp, Nothing) -> do -- In this case, every synthesis should be done in parallel. The service is started while training, but we prefer to be notified when all the training processes finish.- forkIO $ trainPara stat pgf hscEnv fp+ forkIO $ trainPara stat fp return ()- (Nothing, Just fs) -> trainSeq qhandle stat pgf hscEnv fs+ (Nothing, Just fs) -> trainSeq stat fs (Nothing, Nothing) -> return () hSetBuffering qhandle LineBuffering- case howToServe stat of + case howToServe so of Network pid -> withSocketsDo $ do #ifdef UNIX installHandler sigPIPE Ignore Nothing -- as suggested by /usr/share/doc/libghc6-network-doc/html/Network.html #endif socket <- listenOn pid- loop qhandle stat pgf hscEnv socket- STDIO -> interactive qhandle stat pgf hscEnv+ loop stat socket+ STDIO -> interactive stat PS -> do pgn <- getProgName system $ "ps u -C "++pgn return () -- stopGlobalPool@@ -235,14 +237,14 @@ yield if (i>0) then waitUntil0 mv else return i -loop qh so pgf hscEnv socket = do+loop stat socket = do (handle, hostname, _portnum) <- accept socket hPutStr stderr $ "Connection from " ++ hostname ++ ".\n" tid <- forkIO $ do hSetBuffering handle LineBuffering- answerHIO qh so pgf hscEnv handle handle+ answerHIO stat handle handle hPutStrLn stderr "closing" hClose handle- loop qh so pgf hscEnv socket+ loop stat socket {- pgfの計算を入れんといかん． -- same as main, with option `--interactive --no-training'@@ -252,7 +254,7 @@ interactive qhandle defaultSO pgf hscEnv -} -interactive qh so pgf hscEnv = sequence_ $ repeat $ hPutStrLn stderr "\\f -> ?" >> answerHIO qh so pgf hscEnv stdin stdout+interactive stat = sequence_ $ repeat $ hPutStrLn stderr "\\f -> ?" >> answerHIO stat stdin stdout tryOpening fp onException onSuccess = do r <- try $ openFile fp ReadMode@@ -267,10 +269,10 @@ #endif Right h -> onSuccess h -trainSeq qh d pgf hscEnv fp = do+trainSeq stat fp = do tryOpening fp (\e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained sequentially beforehand.")) (\h -> do time $ do- processTrainers qh (preferPlain d) pgf hscEnv h+ processTrainers (preferPlain stat) h hPutStrLn stderr "In total," return ()) hPutStrLn stderr "performing GC..."@@ -280,40 +282,41 @@ gcStatsAvailable <- getGCStatsEnabled when gcStatsAvailable $ getGCStats >>= print #endif-processTrainers qh so pgf hscEnv h = do- (r,t) <- time $ try (answerHIO qh so pgf hscEnv h stdout)+processTrainers stat h = do+ (r,t) <- time $ try (answerHIO stat h stdout) case r of Left e | isEOFError e -> do hClose h return t | otherwise -> error ("While training:\n" ++ show e)- Right () -> fmap (+t) $ processTrainers qh so pgf hscEnv h+ Right () -> fmap (+t) $ processTrainers stat h -trainPara so pgf hscEnv fp = do+trainPara stat fp = tryOpening fp (\e -> hPutStrLn stderr ("An exception occurred while opening `"++fp++"'. The learner has not been trained in parallel beforehand.")) (\h -> do cs <- hGetContents h- beginCT <- getClockTime- runParIO $ trainParaPar (preferPlain so) pgf hscEnv $ lines cs+ beginCT <- getCurrentTime+ runParIO $ trainParaPar (preferPlain stat) $ lines cs -- trainParaIO (preferPlain so) pgf hscEnv $ lines cs- endParaCT <- getClockTime+ endParaCT <- getCurrentTime hPutStrLn stderr "All the training processes have finished."- hPutStrLn stderr $ showZero (timeDiffToString $ diffClockTimes endParaCT beginCT) ++ " have passed since the training started.")-trainParaIO so pgf hscEnv css = do + hPutStrLn stderr $ show (diffUTCTime endParaCT beginCT) ++ " have passed since the training started.")+trainParaIO stat css = do numUnfinished <- newMVar (length css)- mapM_ (processTrainerPara (preferPlain so) pgf hscEnv numUnfinished) css+ mapM_ (processTrainerPara (preferPlain stat) numUnfinished) css waitUntil0 numUnfinished-processTrainerPara so pgf hscEnv numUnfinished line = do+processTrainerPara stat numUnfinished line = do mid <- myThreadId- forkIO $ ((answerSIO so pgf hscEnv line >>= \(_,k) -> k `seq` modifyMVar_ numUnfinished (return . pred))+ forkIO $ ((answerSIO stat line >>= \(_,k) -> k `seq` modifyMVar_ numUnfinished (return . pred)) `Control.Exception.catch` \exception -> throwTo mid (exception::SomeException) ) return ()-preferPlain so = case format so of DefaultFormat -> so{format=ForcePlain}- _ -> so+preferPlain (vs, qh, so, pgf, he) = (vs, qh, preferPlain' so, pgf, he)+preferPlain' so = case format so of DefaultFormat -> so{format=ForcePlain}+ _ -> so -trainParaPar :: ServerOptions -> ProgGenSF -> HscEnv -> [String] -> ParIO ()-trainParaPar so pgf hscEnv css = do ivks <- mapM (\line -> spawn $ liftIO $ fmap snd $ answerSIO so pgf hscEnv line) css- ks <- mapM get ivks- sum ks `seq` return ()+trainParaPar :: (String, Handle, ServerOptions, ProgGenSF, HscEnv) -> [String] -> ParIO ()+trainParaPar stat css = do ivks <- mapM (\line -> spawn $ liftIO $ fmap snd $ answerSIO stat line) css+ ks <- mapM get ivks+ sum ks `seq` return () filterCompile :: GhcMonad m => String -> String -> m (ProgGenSF -> Bool -> [[Exp]]) filterCompile postprocessor predStr = fmap unsafeCoerce (compileExpr ("f1EF " ++ postprocessor ++ " (\\f -> "++predStr++")")) -- :: m GHC.HValue)@@ -344,8 +347,8 @@ -- stdinとstdoutで動作確認できるように，inとoutを分ける．-answerHIO :: Handle -> ServerOptions -> ProgGenSF -> HscEnv -> Handle -> Handle -> IO ()-answerHIO qhandle so pgf hscEnv ihandle ohandle = do+answerHIO :: (String, Handle, ServerOptions, ProgGenSF, HscEnv) -> Handle -> Handle -> IO ()+answerHIO (versionString, qhandle, so, pgf, hscEnv) ihandle ohandle = do inp <- hGetLine ihandle -- hGetContents ihandleだと，最後に改行文字を入れちゃった時面倒．あと，hGetContentsの方がだいぶ遅いみたい． case lex inp of [(":",rest)] -> if filter (not . isSpace) rest == "version" then hPutStrLn ohandle versionString else hPutStrLn ohandle $ inp ++ " : command unknown" _ -> do@@ -353,11 +356,11 @@ [] -> (so, inp) putStrLn ("the predicate is "++pred) hPutStrLn qhandle pred- (out,_) <- answerSIO so' pgf hscEnv pred+ (out,_) <- answerSIO (versionString, qhandle, so', pgf, hscEnv) pred hPutStrLn ohandle out -answerSIO :: ServerOptions -> ProgGenSF -> HscEnv -> String -> IO (String, Int)-answerSIO so pgf hscEnv pred = do+answerSIO :: (a, b, ServerOptions, ProgGenSF, HscEnv) -> String -> IO (String, Int)+answerSIO (_, _, so, pgf, hscEnv) pred = do cmpd <- runGhc (Just libdir) $ setSession hscEnv >> compileOrFail (postprocessor so) pred case cmpd of Left (funIO, sig) -> do let e2s = case howToServe so of
+ MagicHaskeller/VersionInfo.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+{-# OPTIONS_GHC -fforce-recomp #-}+-- Recompilation is needed to obtain the correct build time.+module MagicHaskeller.VersionInfo where+import Data.Time+import Language.Haskell.TH+#ifdef CABAL+import Paths_MagicHaskeller(version)+import Data.Version(showVersion)+#endif++versionInfo, mhVersion, ghcVersion, now :: String+versionInfo = mhVersion ++ " built with GHC-" ++ ghcVersion ++ " at " ++ now+#ifdef CABAL+mhVersion = showVersion version+#else+mhVersion = ""+#endif+ghcVersion = case __GLASGOW_HASKELL__ `divMod` 100 of (b,s) -> shows b $ '.' : show s++now = $(runIO getCurrentTime >>= \t -> return (LitE $ StringL $ show t)) -- This requires the -fforce-recomp flag in order to be correct.
+ changelog.txt view
@@ -0,0 +1,33 @@+0.9.6.4.7:+ * Add this changelog.txt+ * Implement copy by drag-and-drop+ * Add the build time to versionInfo, which is shown in the CGI frontend and by the :version command+ * Use the time package instead of old-time, and use UTC++0.9.6.4.6:+ * Fix the stupid bug of regarding Int as RealFrac, which crept into 0.9.6.4+ * Enable documentation of language constructs, such as let, in, if, then, else, etc., when typed in as a word.+ * Fix documentation of operators starting with `:', which used to cause the `command unknown' error++0.9.6.4.5:+ * Fix and support ProgGen again++0.9.6.4.4:+ * Support hscolour, by converting Japanese comments into UTF-8+ * Use optLevel 2 (corresponding to -O2) when compiling the query to the server+ * Remove -O2, -fvia-C, and Flag GHC7 from the .cabal file++0.9.6.4.3:+ * Fix indentation in the Cabal file, which caused the wrong dependency+ * Suppress warnings+ * Add package description++0.9.6.4.2:+ * Support GHC 7.10+ * Bundle the `predicates' files++0.9.6.4.1:+ * Make buildable with Windows++0.9.6.4:+ * many changes, which may be itemized here in the future