{-# LANGUAGE RecordWildCards #-} import Network.CGI import Text.XHtml import Data.Maybe import Data.List import Data.ByteString.Lazy.UTF8 (fromString) import qualified Data.ByteString.Lazy as BS import Control.Monad import Control.Applicative ((<$>)) import Text.PrettyPrint.HughesPJ (render) import System.IO import System.IO.Error hiding ( catch ) import System.Directory import Prelude hiding ( catch ) import Control.Exception import System.Posix.Files ( isDirectory, getSymbolicLinkStatus ) import System.Posix.Env import Parser import SemSyn import AST import MyInterpret import BundledCode import JQuery {------------------------- - Types (Logic/Presentation interface -------------------------} data PageInfo = PageInfo { config :: Config , scrollX :: Maybe String , scrollY :: Maybe String , viewFunction :: String , astError :: Maybe String , generatedModuleMB :: Maybe String , showCode :: Bool , playCodeMB :: Maybe String , playErrorM :: Maybe String } data Run = Get | Check | Load | BiDi | EvalPut | EvalGet {------------------------- - Default and example data -------------------------} examples :: [(String, String)] examples = [ ("init", unlines [ "init [] = []" , "init [a] = []" , "init (a:b:x) = a:initWork b x" , "" , "initWork a [] = []" , "initWork a (b:x) = a:initWork b x" ]) , ("tail", unlines [ "tail [] = []" , "tail (x:xs) = xs" ]) , ("sieve", unlines [ "sieve [] = []" , "sieve [a] = []" , "sieve (a:b:x) = b:sieve x" ]) , ("halve", unlines [ "halve [] = []" , "halve (a:x) = a:halveWork x x" , "" , "halveWork xs [] = []" , "halveWork xs [x] = []" , "halveWork (a:x) (b:c:y) = a:halveWork x y" ]) , ("rev", unlines [ "reverse [] = []" , "reverse (x:xs) = rev xs [x]" , "" , "rev [] y = y" , "rev (a:x) y = rev x (a:y)" ]) ] defaultPlayCode :: Config -> String -> Maybe String defaultPlayCode (Config{ b18nMode = SyntacticB18n}) get = Just $ unlines [ "get s = Main." ++ get ++ " s" , "put s v = " ++ get ++ "_B s v" , "" , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]" ] defaultPlayCode (Config{ b18nMode = SemanticB18n}) get = Just $ unlines [ "get s = Main." ++ get ++ " s" , "put s v = " ++ get ++ "_B s v" , "" , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]" ] defaultPlayCode (Config{ b18nMode = CombinedB18n}) get = Just $ unlines [ "get s = Main." ++ get ++ " s" , "put s v = fromMaybe (error \"Could not handle shape change.\") $ " ++ get ++ "_Bbd bias default_value s v" , "bias = rear -- or another option, e.g., front, middle, borders" , "default_value = 42 -- or another value of the element type of source" , "" , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]" ] defaultCode :: String defaultCode = fromJust (lookup "init" examples) {------------------------- - Program logic -------------------------} -- This function will not work in all casses, but in most. delDefinition :: String -> String -> String delDefinition name code = unlines squashed where filtered = filter (not . defines name) (lines code) squash [] = [] squash ("":_) = [""] squash ("\r":_) = [""] squash ls = ls squashed = concat $ map squash $ group $ filtered addDefinition :: String -> String -> String -> String addDefinition name def code = unlines (squashed ++ pad ++ new_line) where squashed = lines (delDefinition name code) pad | last squashed == "" || last squashed == "\r" = [] | otherwise = [""] new_line = [name ++ " = " ++ def] defines :: String -> String -> Bool defines "" (' ':_) = True defines "" ('=':_) = True defines "" "" = False defines "" _ = False defines _ "" = False defines (i:is) (x:xs) | i == x = defines is xs | otherwise = False formMain :: CGI CGIResult formMain = do setHeader "Content-type" "text/html; charset=UTF-8" conf <- do b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode" return $ adjustConfig $ defaultConfig { isHaskellify = True , b18nMode = b18nMode' } todo <- msum <$> sequence ( map (\what -> fmap (const what) <$> getInput (submitId what)) [ BiDi, Get, Check, Load, EvalPut, EvalGet]) code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code" code <- case todo of Just Load -> do loadWhat <- getInput "loadCode" return $ fromMaybe code $ loadWhat >>= flip lookup examples _ -> return code let eAST = parseString code let astError = either (Just . show) checkBidirectionalizability eAST let (genCodeM,getM) = case (todo,eAST) of (Just Load, _) -> (Nothing, Nothing) (Just _, Right ast) -> ( Just $ render $ renderCode conf ast , firstDeclaredName ast ) _ -> (Nothing, Nothing) showCode <- maybe False read <$> getInput "showCode" pcM <- getInput "playCode" (playCode, playErrorM) <- case (todo,getM,genCodeM,pcM) of -- The user successfully generated code to play with, insert default playCode. -- Do not use the user input, as he probably switched to a new example. (Just BiDi, Just get, Just _, _) -> return (defaultPlayCode conf get, Nothing) -- The user played with the code (Just EvalGet, Just get, Just genCode, Just pc) -> do view <- liftIO $ evaluateWith genCode pc ("get source") case view of Left err -> return $ (Just pc, Just err) Right dat -> return $ (\r -> (Just r, Nothing)) $ addDefinition "view" dat $ delDefinition "result" $ pc (Just EvalGet, Just get, Just genCode, Nothing) -> do return (defaultPlayCode conf get, Nothing) (Just EvalPut, Just get, Just genCode, Just pc) -> do view <- liftIO $ evaluateWith genCode pc ("put source view") case view of Left err -> return $ (Just pc, Just err) Right dat -> return $ (\r -> (Just r, Nothing)) $ addDefinition "result" dat $ pc (Just EvalPut, Just get, Just _, Nothing) -> do return (defaultPlayCode conf get, Nothing) _ -> return (Nothing, Nothing) scrollX <- getInput "scrollx" scrollY <- getInput "scrolly" outputFPS $ fromString $ showHtml $ page $ PageInfo conf scrollX scrollY code astError genCodeM showCode playCode playErrorM evaluateWith :: String -> String -> String -> IO (Either String String) evaluateWith genCode playCode expr = withinTmpDir $ do BS.writeFile "BUtil.hs" bUtilCode writeFile "Main.hs" $ "module Main where\n" ++ genCode liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr where mods = [ "BUtil" , "Main" --, "Data.Maybe" ] imports = mods ++ [ "Data.Maybe" , "Prelude" ] {------------------------- - CGI Interface -------------------------} main :: IO () main = runCGI (handleErrors cgiMain) cgiMain :: CGI CGIResult cgiMain = do qs <- queryString if qs == "jquery" then jQueryMain else formMain jQueryMain :: CGI CGIResult jQueryMain = do setHeader "Content-type" "text/javascript" setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100" setHeader "Cache-control" "max-age=36000000" -- 1000 h outputFPS $ jQueryCode {------------------------- - HTML generation -------------------------} submitId :: Run -> String submitId Get = "get source" submitId Check = "check" submitId Load = "load" submitId BiDi = "submitBiDi" submitId EvalPut = "evalPut" submitId EvalGet = "evalGet" submitLabel :: Run -> String submitLabel Check = "Re-Parse definition" submitLabel Load = "Load example" submitLabel EvalGet = "view = get source" submitLabel EvalPut = "result = put source view" submitLabel BiDi = "bidirectionalize" b18nModeName :: B18nMode -> String b18nModeName SemanticB18n = "Semantic bidir. (POPL’09)" b18nModeName SyntacticB18n = "Syntactic bidir. (ICFP’07)" b18nModeName CombinedB18n = "Combined bidir. (ICFP’10)" mkSubmit :: Bool -> Run -> Html mkSubmit active what = submit (submitId what) (submitLabel what) ! if active then [] else [disabled] page :: PageInfo -> Html page (PageInfo {..}) = header << ( thetitle << "(Combining) Syntactic and Semantic Bidirectionalization" +++ style ! [ thetype "text/css" ] << cdata cssStyle +++ script ! [ thetype "text/javascript", src "?jquery" ] << noHtml +++ script ! [ thetype "text/javascript" ] << cdata jsCode ) +++ body ! [ strAttr "onload" "restoreScroll()" ] << ( thediv ! [theclass "top"] << ( thespan ! [theclass "title"] << "(Combining) Syntactic and Semantic Bidirectionalization" +++ thespan ! [theclass "subtitle"] << "Prototype implementation" ) +++ maindiv << ( p << "This tool allows you to experiment with the bidirectionalization methods described in the following papers: " +++ ulist << ( li << ( "“" +++ hotlink "http://doi.acm.org/10.1145/1291151.1291162" << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++ "” (ICFP’07) by " +++ hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/" << "Kazutaka Matsuda" +++ ", " +++ "Zhenjiang Hu, " +++ "Keisuke Nakano, " +++ "Makoto Hamana, and " +++ "Masato Takeichi." ) +++ li << ( "“" +++ hotlink "http://doi.acm.org/10.1145/1480881.1480904" << "Bidirectionalization for free! (Pearl)" +++ "” (POPL’09) by " +++ hotlink "http://www.iai.uni-bonn.de/~jv/" << "Janis Voigtländer" ) +++ li << ( "“" +++ hotlink "http://www.iai.uni-bonn.de/~jv/icfp10.pdf" << "Combining Syntactic and Semantic Bidirectionalization" +++ "” (ICFP’10) by " +++ "Janis Voigtländer" +++ ", " +++ "Zhenjiang Hu, " +++ "Kazutaka Matsuda" +++ ", and " +++ "Meng Wang" ) ) +++ p << ( "(For a stand-alone version on command line, which is also able to " +++ "show intermediate steps in the transformations, see " +++ hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/b18n-combined/desc.html" << "here" +++ ". " +++ "For the technique from POPL’09 alone, a "+++ hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi" << "separate web interface" +++ " offering more features is also available.)" ) ) +++ form ! [method "post", action "#", strAttr "onsubmit" "saveScroll()" ] << ( hidden "scrollx" (fromMaybe "0" scrollX) +++ hidden "scrolly" (fromMaybe "0" scrollY) +++ hidden "showCode" (show showCode) +++ maindiv << ( p << ( "Please enter the view function. The first function "+++ "defined will be assumed to be your view function. You "+++ "can use the first-order functional language from the "+++ "ICFP’07 paper, in Haskell syntax. The view function must "+++ "have type " +++ tt << "[a] -> [a]" +++ ". You can also load "+++ "some predefined examples." ) +++ p << ( concatHtml (map (\(name,thisCode) -> radio "loadCode" name ! (if thisCode == viewFunction then [checked] else []) +++ name +++ " " ) examples) +++ mkSubmit True Load +++ br +++ textarea ! [name "code", cols "120", rows "7"] << viewFunction ) ) +++ ( case astError of Just err -> maindiv << p << ( "There was an error with the view function:" +++ br +++ pre << err +++ br +++ mkSubmit True Check +++ p << ( "The "+++ hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi" << "purely semantic bidirectionalization technique" +++ " (POPL’09) may still be able to handle your view function. "+++ "For the combined technique (ICFP’10) it may be possible " +++ "to recover applicability by using some program transformation "+++ "techniques as discussed in Section 7 of the paper." ) ) Nothing -> maindiv ! [ identifier "output" ]<< ( p << ( "You can try all three bidirectionalization methods." ) +++ p << ( concatHtml (map (\mode -> radio "b18nMode" (show mode) ! (guard (mode == b18nMode config) >> return checked) +++ b18nModeName mode +++ " " ) [SyntacticB18n, SemanticB18n, CombinedB18n]) +++ " " +++ mkSubmit True BiDi ) +++ ( htmlMB generatedModuleMB $ \ generatedModule -> p << ("Result Code" +++ thespan ! [ identifier "hideShow" , thestyle "display:none"] << ( " (" +++ hotlink "javascript:" << "Hide/Show" +++ ")" ) +++ ":" +++ br +++ pre ! [identifier "genCode" ] << generatedModule ) ) ) +++ ( htmlMB playCodeMB $ \playCode -> maindiv << ( p << ( "You can now play with the code. You can modify the " +++ tt << "source" +++ " and calculate the " +++ tt << "view" +++ ", or modify the " +++ tt << "view" +++ " and calculate an updated "+++ tt << "source" +++ "." +++ br +++ textarea ! [name "playCode", cols "120", rows "12" ] << playCode ) +++ p << ( "Evaluate " +++ mkSubmit True EvalGet +++ " " +++ mkSubmit True EvalPut ) )) +++ ( htmlMB playErrorM $ \playError -> maindiv << ( p << ( strong << "An error occurred while evaluating your code:" +++ br +++ pre << playError ) )) ) ) +++ maindiv << ( p << ( "The source code of this application and the underlying library can be found " +++ hotlink "http://hackage.haskell.org/package/bidirectionalization-combined" << "on hackage" +++ ". " +++ "The code for the web interface is based on " +++ hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi" << "the demo interface from “Bidirectionalization for free!”" ) +++ p << ("© 2010 Kazutaka Matsuda, Joachim Breitner <" +++ hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++ ">") ) ) cdata :: String -> Html cdata s = primHtml $ -- "" maindiv :: Html -> Html maindiv = thediv ! [theclass "main"] {------------------------- - Static Web code -------------------------} cssStyle :: String cssStyle = unlines [ "body { padding:0px; margin: 0px; }" , "div.top { margin:0px; padding:10px; margin-bottom:20px;" , " background-color:#efefef;" , " border-bottom:1px solid black; }" , "span.title { font-size:xx-large; font-weight:bold; }" , "span.subtitle { padding-left:30px; font-size:large; }" , "div.main { border:1px dotted black;" , " padding:10px; margin:10px; }" , "div.submain { padding:10px; margin:11px; }" , "p.subtitle { font-size:large; font-weight:bold; }" , "input.type { font-family:monospace; }" , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }" , "span.mono { font-family:monospace; }" , "pre { margin:10px; margin-left:20px; padding:10px;" , " border:1px solid black; }" , "textarea { margin:10px; margin-left:20px; padding:10px; }" , "p { text-align:justify; }" ] jsCode :: String jsCode = unlines [ "function saveScroll () {" , " $('#scrolly').val($('html').scrollTop());" , "}" , "function restoreScroll () {" , " $('html').scrollTop($('#scrolly').val());" , "}" , "$(document).ready(function () {" , " $('#hideShow').show();" , " if ($('#showCode').val() == 'False')" , " { $('#genCode').hide(); };" , " $('#hideShow a').click(function () {" , " $('#showCode').val(" , " $('#genCode').is(':visible') ? 'False' : 'True'" , " );" , " $('#genCode').toggle('slow');" , " })" , "})" ] {------------------------- - Utility functions -------------------------} htmlMB :: Maybe t -> (t -> Html) -> Html htmlMB Nothing _ = noHtml htmlMB (Just x) f = f x firstDeclaredName :: AST -> Maybe String firstDeclaredName (AST []) = Nothing firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n) {- - Temp-Dir functions taken from XMonad/Lock.hs and simplified. - It also changes TMP so that hint’s temporary files are stored within this directory -} withinTmpDir :: IO a -> IO a withinTmpDir job = do absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory formerdir <- getCurrentDirectory formerTMP <- getEnv "TMPDIR" bracket (do dir <- create_directory absolute_name 0 setEnv "TMPDIR" dir True return dir ) (\dir -> do setCurrentDirectory formerdir maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP rmRecursive dir) (const job) where newname name 0 = name newname name n = name ++ "-" ++ show n create_directory :: FilePath -> Int -> IO FilePath create_directory name n = do createDirectory $ newname name n setCurrentDirectory $ newname name n getCurrentDirectory `catch` (\e -> if isAlreadyExistsError e then create_directory name (n+1) else throwIO e) rmRecursive :: FilePath -> IO () rmRecursive d = do isd <- isDirectory <$> getSymbolicLinkStatus d if not isd then removeFile d else when isd $ do conts <- actual_dir_contents withCurrentDirectory d $ mapM_ rmRecursive conts removeDirectory d where actual_dir_contents = -- doesn't include . or .. do c <- getDirectoryContents d return $ filter (/=".") $ filter (/="..") c withCurrentDirectory :: FilePath -> IO r -> IO r withCurrentDirectory name m = bracket (do cwd <- getCurrentDirectory when (name /= "") (setCurrentDirectory name) return cwd) (\oldwd -> setCurrentDirectory oldwd) (const m)