1 {-# LANGUAGE RecordWildCards #-}
6 import Data.ByteString.Lazy.UTF8 (fromString)
7 import qualified Data.ByteString.Lazy as BS
9 import Control.Applicative ((<$>),(<*>))
10 import Text.PrettyPrint.HughesPJ (render)
12 import System.IO.Error hiding ( catch )
13 import Text.ParserCombinators.Parsec (ParseError)
14 import System.Directory
15 import Prelude hiding ( catch )
16 import Control.Exception
17 import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )
18 import System.Posix.Env
31 data PageInfo = PageInfo
33 , scrollX :: Maybe String
34 , scrollY :: Maybe String
35 , viewFunction :: String
36 , parseError :: Maybe String
37 , generatedModuleMB :: Maybe String
39 , playCodeMB :: Maybe String
40 , playErrorM :: Maybe String
43 page (PageInfo {..}) =
45 thetitle << "(Combining) Syntatic and Semantic Bidirectionalization" +++
46 style ! [ thetype "text/css" ] << cdata cssStyle +++
47 script ! [ thetype "text/javascript", src "?jquery" ] << noHtml +++
48 script ! [ thetype "text/javascript" ] << cdata jsCode
50 body ! [ strAttr "onload" "restoreScroll()" ] << (
51 thediv ! [theclass "top"] << (
52 thespan ! [theclass "title"] << "(Combining) Syntatic and Semantic Bidirectionalization" +++
53 thespan ! [theclass "subtitle"] << "Prototype implementation"
56 p << "This tool allows you to experiment with the bidirectionalization methods described in the following papers: " +++
60 hotlink "http://doi.acm.org/10.1145/1291151.1291162"
61 << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
63 hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
64 << "Kazutaka Matsuda" +++ ", " +++
66 "Keisuke Nakano, " +++
67 "Makoto Hamana and " +++
72 hotlink "http://doi.acm.org/10.1145/1480881.1480904"
73 << "Bidirectionalization for free! (Pearl)" +++
75 hotlink "http://www.iai.uni-bonn.de/~jv/"
76 << "Janis Voigtländer"
86 form ! [method "post",
88 strAttr "onsubmit" "saveScroll()"
90 hidden "scrollx" (fromMaybe "0" scrollX) +++
91 hidden "scrolly" (fromMaybe "0" scrollY) +++
92 hidden "showCode" (show showCode) +++
95 "Please enter the view function. (TODO: Elaborate this text)"
99 concatHtml (map (\(name,thisCode) ->
100 radio "loadCode" name
101 ! (if thisCode == viewFunction then [checked] else [])
104 mkSubmit True Load +++
106 textarea ! [name "code", cols "120", rows "7"] << viewFunction
110 ( htmlMB parseError $ \err ->
112 "Can not parse your definition:" +++ br +++
113 pre << show err +++ br +++
116 -- p << astInfo mbAST +++
117 maindiv ! [ identifier "output" ]<< (
119 "You can calculate a derived put function with various options:" ) +++
120 p << ( "Output mode: " +++
121 concatHtml (map (\mode ->
122 radio "b18nMode" (show mode)
123 ! (guard (mode == b18nMode config) >> return checked)
124 +++ show mode +++ " "
125 ) [SyntacticB18n, SemanticB18n, CombinedB18n, NoB18n]) +++ br +++
128 ( htmlMB generatedModuleMB $ \ generatedModule ->
129 {- maybe noHtml outputErrors errors +++ -}
130 p << ("Result Code" +++
131 thespan ! [ identifier "hideShow"
132 , thestyle "display:none"] << (
133 " (" +++ hotlink "javascript:" << "Hide/Show" +++ ")"
135 pre ! [identifier "genCode" ] << generatedModule
141 ( htmlMB playCodeMB $ \playCode -> maindiv << (
142 p << ( "You can now play with the code. You can modify the " +++
143 tt << "source" +++ " and calculate the " +++
144 tt << "view" +++ ", or modify the " +++
145 tt << "view" +++ " and calculate an updated "+++
146 tt << "source" +++ "." +++ br +++
147 textarea ! [name "playCode", cols "120", rows "8" ] << playCode
149 p << ( "Evaluate " +++
150 mkSubmit True EvalGet +++ " " +++
151 mkSubmit True EvalPut
154 ( htmlMB playErrorM $ \playError -> maindiv << (
156 strong << "An error occurred while evaluating your code:" +++ br +++
163 "The source code of this application and the underlying library can be found " +++
164 hotlink "TODO" << "here"+++
166 "The code for the web interface is based on " +++
167 hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi" <<
168 "the demo interface from “Bidirectionalization for free!”"
170 p << ("© 2010 Joachim Breitner <" +++
171 hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
177 cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
179 maindiv = thediv ! [theclass "main"]
185 , "init (a:b:x) = a:initWork b x"
186 , "initWork a [] = []"
187 , "initWork a (b:x) = a:initWork b x"
189 , ("initHalf", unlines
191 , "initHalf (a:x) = a:initHalfWork x x"
193 , "initHalfWork xs [] = []"
194 , "initHalfWork xs [x] = []"
195 , "initHalfWork (a:x) (b:c:y)"
196 , " = a:initHalfWork x y"
201 , "sieve (a:b:x) = b:sieve x"
204 [ "reverse xs = rev xs []"
206 , "rev (a:x) y = rev x (a:y)"
210 defaultCode = fromJust (lookup "init" examples)
212 outputErrors :: String -> Html
215 strong << "An error occurred:" +++ br +++
219 mkSubmit active what = submit (submitId what) (submitLabel what)
220 ! if active then [] else [disabled]
222 data Run = Get | Check | Load | BiDi | EvalPut | EvalGet
225 submitId Get = "get source"
226 submitId Check = "check"
227 submitId Load = "load"
228 submitId BiDi = "submitBiDi"
229 submitId EvalPut = "evalPut"
230 submitId EvalGet = "evalGet"
232 submitCode Get = Just ("get source")
233 submitCode Check = Nothing
234 submitCode Load = Nothing
236 submitLabel Check = "Re-Parse definition"
237 submitLabel Load = "Load example"
238 submitLabel EvalGet = "view = get source"
239 submitLabel EvalPut = "result = put source view"
240 submitLabel BiDi = "bidirectionalize"
242 main = runCGI (handleErrors cgiMain)
244 -- This function will not work in all casses, but in most.
245 delDefinition name code = unlines squashed
246 where filtered = filter (not . defines name) (lines code)
249 squash ("\r":_) = [""]
251 squashed = concat $ map squash $ group $ filtered
253 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
254 where squashed = lines (delDefinition name code)
255 pad | last squashed == "" || last squashed == "\r" = []
257 new_line = [name ++ " = " ++ def]
259 defines "" (' ':_) = True
260 defines "" ('=':_) = True
261 defines "" "" = False
264 defines (i:is) (x:xs) | i == x = defines is xs
274 setHeader "Content-type" "text/javascript"
275 setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
276 setHeader "Cache-control" "max-age=36000000" -- 1000 h
277 outputFPS $ jQueryCode
279 defaultPlayCode (Config{..}) get =
281 [ "get s = Main." ++ get ++ " s"
282 , "put s v = " ++ put
284 , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
286 where put | b18nMode == SyntacticB18n =
288 | b18nMode == SemanticB18n =
290 | b18nMode == CombinedB18n =
291 "fromMaybe (error \"Could not handle shape change.\") $ " ++
292 get ++ "_Bbd rear 42 s v"
295 setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
298 b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode"
299 return $ defaultConfig
300 { isHaskellify = True
301 , b18nMode = b18nMode'
302 , execMode = ShapifyPlus
305 todo <- msum <$> sequence (
306 map (\what -> fmap (const what) <$> getInput (submitId what))
307 [ BiDi, Get, Check, Load, EvalPut, EvalGet])
309 code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code"
312 Just Load -> do loadWhat <- getInput "loadCode"
313 return $ fromMaybe code $ loadWhat >>= flip lookup examples
316 let eAST = parseString code
319 let parseError = either (Just . show) (const Nothing) eAST
321 let (genCodeM,getM) = case (todo,eAST) of
322 (Just Load, _) -> (Nothing, Nothing)
323 (Just _, Right ast) ->
325 outputCode conf True ast (introNat $ shapify $ typeInference ast)
326 , firstDeclaredName ast
328 _ -> (Nothing, Nothing)
330 showCode <- maybe False read <$> getInput "showCode"
332 pcM <- getInput "playCode"
333 -- Playcode can only by used when the output is exMode
334 (playCode, playErrorM) <- -- if outMode /= HaskellCode then return (Nothing, Nothing) else
335 case (todo,getM,genCodeM,pcM) of
336 -- The user successfully generated code to play with, insert default playCode.
337 -- Do not use the user input, as he probably switched to a new example.
338 (Just BiDi, Just get, Just _, _) ->
339 return (defaultPlayCode conf get, Nothing)
340 -- The user played with the code
341 (Just EvalGet, Just get, Just genCode, Just pc) -> do
342 view <- liftIO $ evaluateWith genCode pc ("get source")
344 Left err -> return $ (Just pc, Just err)
345 Right dat -> return $ (\r -> (Just r, Nothing))
346 $ addDefiniton "view" dat
347 $ delDefinition "result"
349 (Just EvalGet, Just get, Just genCode, Nothing) -> do
350 return (defaultPlayCode conf get, Nothing)
351 (Just EvalPut, Just get, Just genCode, Just pc) -> do
352 view <- liftIO $ evaluateWith genCode pc ("put source view")
354 Left err -> return $ (Just pc, Just err)
355 Right dat -> return $ (\r -> (Just r, Nothing))
356 $ addDefiniton "result" dat
358 (Just EvalPut, Just get, Just _, Nothing) -> do
359 return (defaultPlayCode conf get, Nothing)
360 _ -> return (Nothing, Nothing)
362 scrollX <- getInput "scrollx"
363 scrollY <- getInput "scrolly"
365 outputFPS $ fromString $ showHtml $ page $
376 evaluateWith :: String -> String -> String -> IO (Either String String)
377 evaluateWith genCode playCode expr =
379 BS.writeFile "BUtil.hs" bUtilCode
380 writeFile "Main.hs" $ "module Main where\n" ++ genCode
381 liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
392 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode
393 where genCode' = unlines . filter (not . isPrefixOf "import") . lines $ genCode
395 astInfo (Left err) = maindiv << p << (
396 "Can not parse your definition:" +++ br +++
397 pre << show err +++ br +++
400 astInfo (Right source) = maindiv << (
401 p << ("Definition parsed succesfully") +++
402 p << mkSubmit True Check
406 [ "body { padding:0px; margin: 0px; }"
407 , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
408 , " background-color:#efefef;"
409 , " border-bottom:1px solid black; }"
410 , "span.title { font-size:xx-large; font-weight:bold; }"
411 , "span.subtitle { padding-left:30px; font-size:large; }"
412 , "div.main { border:1px dotted black;"
413 , " padding:10px; margin:10px; }"
414 , "div.submain { padding:10px; margin:11px; }"
415 , "p.subtitle { font-size:large; font-weight:bold; }"
416 , "input.type { font-family:monospace; }"
417 , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
418 , "span.mono { font-family:monospace; }"
419 , "pre { margin:10px; margin-left:20px; padding:10px;"
420 , " border:1px solid black; }"
421 , "textarea { margin:10px; margin-left:20px; padding:10px; }"
422 , "p { text-align:justify; }"
426 [ "function saveScroll () {"
427 , " $('#scrolly').val($('html').scrollTop());"
429 , "function restoreScroll () {"
430 , " $('html').scrollTop($('#scrolly').val());"
432 , "$(document).ready(function () {"
433 , " $('#hideShow').show();"
434 , " if ($('#showCode').val() == 'False')"
435 , " { $('#genCode').hide(); };"
436 , " $('#hideShow a').click(function () {"
437 , " $('#showCode').val("
438 , " $('#genCode').is(':visible') ? 'False' : 'True'"
440 , " $('#genCode').toggle('slow');"
445 htmlMB Nothing f = noHtml
446 htmlMB (Just x) f = f x
448 readOnly = emptyAttr "readonly"
451 firstDeclaredName (AST []) = Nothing
452 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
455 - Temp-Dir functions taken from XMonad/Lock.hs and simplified.
456 - It also changes TMP so that hint’s temporary files are stored within this directory
458 withinTmpDir :: IO a -> IO a
459 withinTmpDir job = do
460 absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
461 formerdir <- getCurrentDirectory
462 formerTMP <- getEnv "TMPDIR"
463 bracket (do dir <- create_directory absolute_name 0
464 setEnv "TMPDIR" dir True
467 (\dir -> do setCurrentDirectory formerdir
468 maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP
471 where newname name 0 = name
472 newname name n = name ++ "-" ++ show n
473 create_directory :: FilePath -> Int -> IO FilePath
474 create_directory name n
475 = do createDirectory $ newname name n
476 setCurrentDirectory $ newname name n
478 `catch` (\e -> if isAlreadyExistsError e
479 then create_directory name (n+1)
482 rmRecursive :: FilePath -> IO ()
484 do isd <- isDirectory <$> getSymbolicLinkStatus d
487 else when isd $ do conts <- actual_dir_contents
488 withCurrentDirectory d $
489 mapM_ rmRecursive conts
491 where actual_dir_contents = -- doesn't include . or ..
492 do c <- getDirectoryContents d
493 return $ filter (/=".") $ filter (/="..") c
495 withCurrentDirectory :: FilePath -> IO r -> IO r
496 withCurrentDirectory name m =
498 (do cwd <- getCurrentDirectory
499 when (name /= "") (setCurrentDirectory name)
501 (\oldwd -> setCurrentDirectory oldwd)