Use renderCode
[darcs-mirror-sem_syn.git] / b18n-combined-cgi.hs
1 {-# LANGUAGE RecordWildCards #-}
2 import Network.CGI
3 import Text.XHtml
4 import Data.Maybe
5 import Data.List
6 import Data.ByteString.Lazy.UTF8 (fromString)
7 import qualified Data.ByteString.Lazy as BS
8 import Control.Monad
9 import Control.Applicative ((<$>),(<*>))
10 import Text.PrettyPrint.HughesPJ (render)
11 import System.IO
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
19
20
21 import Parser
22 import SemSyn
23 import Type
24 import Shapify
25 import AST
26
27 import MyInterpret
28 import BundledCode
29 import JQuery
30
31 data PageInfo = PageInfo
32     { config :: Config
33     , scrollX :: Maybe String
34     , scrollY :: Maybe String
35     , viewFunction :: String
36     , astError :: Maybe String
37     , generatedModuleMB :: Maybe String
38     , showCode :: Bool
39     , playCodeMB :: Maybe String
40     , playErrorM :: Maybe String
41     } 
42
43 page (PageInfo {..}) =
44        header << (
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 
49        ) +++
50        body ! [ strAttr "onload" "restoreScroll()" ] << (
51         thediv ! [theclass "top"] << (
52                 thespan ! [theclass "title"] << "(Combining) Syntatic and Semantic Bidirectionalization" +++
53                 thespan ! [theclass "subtitle"] << "Prototype implementation"
54         ) +++
55         maindiv << (
56                 p << "This tool allows you to experiment with the bidirectionalization methods described in the following papers: " +++
57                 ulist << (
58                     li << (
59                       "“" +++
60                       hotlink "http://doi.acm.org/10.1145/1291151.1291162"
61                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
62                       "” (ICFP'07) by " +++
63                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
64                         << "Kazutaka Matsuda" +++ ", " +++
65                       "Zhenjiang Hu, " +++
66                       "Keisuke Nakano, " +++
67                       "Makoto Hamana and " +++
68                       "Masato Takeichi."
69                     ) +++
70                     li << (
71                       "“" +++
72                       hotlink "http://doi.acm.org/10.1145/1480881.1480904"
73                         << "Bidirectionalization for free! (Pearl)" +++
74                       "” (POPL'09) by " +++
75                       hotlink "http://www.iai.uni-bonn.de/~jv/"
76                         << "Janis Voigtländer"
77                     ) +++
78                     li << (
79                       "“" +++
80                       hotlink ""
81                         << "TBT" +++
82                       "” (ICFP'10)"
83                     )
84                 )
85         ) +++
86         form ! [method "post",
87                 action "#",
88                 strAttr "onsubmit" "saveScroll()"
89             ] << (
90                 hidden "scrollx" (fromMaybe "0" scrollX) +++
91                 hidden "scrolly" (fromMaybe "0" scrollY) +++
92                 hidden "showCode" (show showCode) +++
93                 maindiv << (
94                          p << (
95                                 "Please enter the view function. (TODO: Elaborate this text)"
96                         ) +++
97
98                         p << (
99                                 concatHtml (map (\(name,thisCode) -> 
100                                         radio "loadCode" name
101                                         ! (if thisCode == viewFunction then [checked] else [])
102                                         +++ name +++ " "
103                                 ) examples) +++
104                                 mkSubmit True Load +++
105                                 br +++
106                                 textarea ! [name "code", cols "120", rows "7"] << viewFunction
107                         ) 
108                         
109                 ) +++
110                 ( htmlMB astError $ \err -> 
111                      maindiv << p << (
112                         "There was an error with the view function:" +++ br +++
113                         pre << err +++ br +++
114                         mkSubmit True Check)
115                 ) +++
116                 -- p << astInfo mbAST +++
117                 maindiv ! [ identifier "output" ]<< (
118                         p << (
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]) +++ br +++
126                                mkSubmit True BiDi
127                         ) +++
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" +++ ")"
134                                 ) +++ ":" +++ br +++
135                                 pre ! [identifier "genCode" ] << generatedModule
136
137                             )
138
139                         )
140                 ) +++
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
148                     ) +++
149                     p << ( "Evaluate " +++
150                            mkSubmit True EvalGet +++ " " +++
151                            mkSubmit True EvalPut
152                     )
153                 )) +++
154                 ( htmlMB playErrorM $ \playError -> maindiv << ( 
155                     p << (
156                         strong << "An error occurred while evaluating your code:" +++ br +++
157                         pre << playError
158                         )
159                 ))
160         ) +++
161         maindiv << (
162             p << (
163                 "The source code of this application and the underlying library can be found " +++
164                 hotlink "TODO" << "here"+++
165                 ". " +++
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!”"
169             ) +++
170             p << ("© 2010 Joachim Breitner <" +++
171                 hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
172               ">")
173             )   
174         )
175        
176
177 cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
178
179 maindiv = thediv ! [theclass "main"]
180         
181 examples =
182         [ ("init", unlines
183                 [ "init []      = []"
184                 , "init [a]     = []"
185                 , "init (a:b:x) = a:initWork b x"
186                 , "initWork a []    = []"
187                 , "initWork a (b:x) = a:initWork b x"
188                 ])
189         , ("initHalf", unlines
190                 [ "initHalf []    = []"
191                 , "initHalf (a:x) = a:initHalfWork x x"
192                 , ""
193                 , "initHalfWork xs  []  = []"
194                 , "initHalfWork xs  [x] = []"
195                 , "initHalfWork (a:x) (b:c:y)"
196                 , "                    = a:initHalfWork x y"
197                 ])
198         , ("sieve", unlines
199                 [ "sieve []      = []"
200                 , "sieve [a]     = []"
201                 , "sieve (a:b:x) = b:sieve x"
202                 ])
203         , ("rev", unlines
204                 [ "reverse xs = rev xs []"
205                 , "rev []    y = y"
206                 , "rev (a:x) y = rev x (a:y)"
207                 ])
208         ]
209
210 defaultCode = fromJust (lookup "init" examples)
211         
212 outputErrors :: String -> Html
213 outputErrors s = 
214            p << (
215                 strong << "An error occurred:" +++ br +++
216                 pre << s
217                 )
218                 
219 mkSubmit active what = submit (submitId what) (submitLabel what)
220                        ! if active then [] else [disabled]
221
222 data Run = Get | Check | Load | BiDi | EvalPut | EvalGet
223
224
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"
231
232 submitCode Get   = Just ("get source")
233 submitCode Check = Nothing
234 submitCode Load  = Nothing
235
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"
241
242 main = runCGI (handleErrors cgiMain)
243
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)
247         squash [] = []
248         squash ("":_) = [""]
249         squash ("\r":_) = [""]
250         squash ls = ls
251         squashed = concat $ map squash $ group $ filtered
252
253 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
254   where squashed = lines (delDefinition name code)
255         pad | last squashed == "" || last squashed == "\r" = []
256             | otherwise                                    = [""]
257         new_line = [name ++ " = " ++ def]
258         
259 defines "" (' ':_) = True
260 defines "" ('=':_) = True
261 defines "" "" = False
262 defines "" _   = False
263 defines _  ""  = False
264 defines (i:is) (x:xs) | i == x = defines is xs
265                       | i /= x = False
266
267 cgiMain = do
268     qs <- queryString
269     if qs == "jquery"
270      then jQueryMain
271      else formMain
272
273 jQueryMain = do
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
278     
279 defaultPlayCode (Config{..}) get =
280         Just $ unlines
281             [ "get s = Main." ++ get ++ " s"
282             , "put s v = " ++ put
283             , ""
284             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
285             ]
286     where put = case b18nMode of
287             SyntacticB18n -> get ++ "_140_B s v"
288             SemanticB18n -> get ++ "_B s v"
289             CombinedB18n ->
290                 "fromMaybe (error \"Could not handle shape change.\") $ " ++
291                  get ++ "_Bbd rear 42 s v"
292
293 formMain = do
294         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
295
296         conf <- do
297             b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode"
298             return $ defaultConfig
299                 { isHaskellify = True
300                 , b18nMode = b18nMode'
301                 , execMode = ShapifyPlus
302                 }
303         
304         todo <- msum <$> sequence (
305             map (\what -> fmap (const what) <$> getInput (submitId what))
306             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
307         
308         code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code"
309
310         code <- case todo of
311             Just Load -> do loadWhat <- getInput "loadCode"
312                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
313             _ -> return code
314         
315         let eAST = parseString code
316
317
318         let astError = either (Just . show) checkBidirectionalizability eAST
319
320         let (genCodeM,getM) = case (todo,eAST) of
321                 (Just Load, _) -> (Nothing, Nothing)
322                 (Just _, Right ast) ->
323                     (  Just $ render $ renderCode conf ast
324                     ,  firstDeclaredName ast
325                     )
326                 _ -> (Nothing, Nothing)
327
328         showCode <- maybe False read <$> getInput "showCode"
329
330         pcM <- getInput "playCode" 
331         -- Playcode can only by used when the output is exMode
332         (playCode, playErrorM) <- -- if outMode /= HaskellCode then return (Nothing, Nothing) else
333             case (todo,getM,genCodeM,pcM) of
334             -- The user successfully generated code to play with, insert default playCode.
335             -- Do not use the user input, as he probably switched to a new example.
336             (Just BiDi, Just get, Just _, _) ->
337                 return (defaultPlayCode conf get, Nothing)
338             -- The user played with the code
339             (Just EvalGet, Just get, Just genCode, Just pc) -> do
340                 view <- liftIO $ evaluateWith genCode pc ("get source")
341                 case view of 
342                     Left err -> return $ (Just pc, Just err)
343                     Right dat -> return $ (\r -> (Just r, Nothing))
344                                         $ addDefiniton "view" dat 
345                                         $ delDefinition "result"
346                                         $ pc
347             (Just EvalGet, Just get, Just genCode, Nothing) -> do
348                 return (defaultPlayCode conf get, Nothing)
349             (Just EvalPut, Just get, Just genCode, Just pc) -> do
350                 view <- liftIO $ evaluateWith genCode pc ("put source view")
351                 case view of 
352                     Left err -> return $ (Just pc, Just err)
353                     Right dat -> return $ (\r -> (Just r, Nothing))
354                                         $ addDefiniton "result" dat 
355                                         $ pc
356             (Just EvalPut, Just get, Just _, Nothing) -> do
357                 return (defaultPlayCode conf get, Nothing)
358             _ -> return (Nothing, Nothing)
359
360         scrollX <- getInput "scrollx"
361         scrollY <- getInput "scrolly"
362
363         outputFPS $ fromString $ showHtml $ page $
364             PageInfo conf
365                      scrollX
366                      scrollY
367                      code
368                      astError
369                      genCodeM
370                      showCode
371                      playCode
372                      playErrorM
373
374 evaluateWith :: String -> String -> String -> IO (Either String String)
375 evaluateWith genCode playCode expr =
376     withinTmpDir $ do
377         BS.writeFile "BUtil.hs" bUtilCode
378         writeFile "Main.hs" $ "module Main where\n" ++ genCode
379         liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
380   where mods = 
381             [ "BUtil"
382             , "Main"
383             --, "Data.Maybe"
384             ]
385         imports = mods ++
386             [ "Data.Maybe"
387             , "Prelude"
388             ]
389
390 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode
391     where genCode' = unlines . filter (not . isPrefixOf "import") . lines $ genCode
392
393 astInfo (Left err) = maindiv << p << (
394         "Can not parse your definition:" +++ br +++
395         pre << show err +++ br +++
396         mkSubmit True Check)
397
398 astInfo (Right source) = maindiv << (
399         p << ("Definition parsed succesfully") +++
400         p << mkSubmit True Check
401         )
402
403 cssStyle = unlines 
404         [ "body { padding:0px; margin: 0px; }"
405         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
406         , "              background-color:#efefef;"
407         , "              border-bottom:1px solid black; }"
408         , "span.title { font-size:xx-large; font-weight:bold; }"
409         , "span.subtitle { padding-left:30px; font-size:large; }"
410         , "div.main { border:1px dotted black;"
411         , "                   padding:10px; margin:10px; }"
412         , "div.submain { padding:10px; margin:11px; }"
413         , "p.subtitle { font-size:large; font-weight:bold; }"
414         , "input.type { font-family:monospace; }"
415         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
416         , "span.mono { font-family:monospace; }"
417         , "pre { margin:10px; margin-left:20px; padding:10px;"
418         , "          border:1px solid black; }"
419         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
420         , "p { text-align:justify; }"
421         ]
422
423 jsCode = unlines 
424     [ "function saveScroll () {"
425     , "    $('#scrolly').val($('html').scrollTop());"
426     , "}"
427     , "function restoreScroll () {"
428     , "    $('html').scrollTop($('#scrolly').val());"
429     , "}"
430     , "$(document).ready(function () {"
431     , "   $('#hideShow').show();"
432     , "   if ($('#showCode').val() == 'False')"
433     , "     { $('#genCode').hide(); };"
434     , "   $('#hideShow a').click(function () {"
435     , "      $('#showCode').val("
436     , "         $('#genCode').is(':visible') ? 'False' : 'True'"
437     , "      );"
438     , "      $('#genCode').toggle('slow');"
439     , "   })"
440     , "})"
441     ]
442
443 htmlMB Nothing  f = noHtml
444 htmlMB (Just x) f = f x
445
446 readOnly = emptyAttr "readonly"
447
448
449 firstDeclaredName (AST []) = Nothing
450 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
451
452 {-
453  - Temp-Dir functions taken from XMonad/Lock.hs and simplified.
454  - It also changes TMP so that hint’s temporary files are stored within this directory
455  -}
456 withinTmpDir :: IO a -> IO a
457 withinTmpDir job = do
458   absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
459   formerdir <- getCurrentDirectory
460   formerTMP <- getEnv "TMPDIR"
461   bracket (do dir <- create_directory absolute_name 0
462               setEnv "TMPDIR" dir True  
463               return dir
464           )
465           (\dir -> do setCurrentDirectory formerdir
466                       maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP
467                       rmRecursive dir)
468           (const job)
469     where newname name 0 = name
470           newname name n = name ++ "-" ++ show n
471           create_directory :: FilePath -> Int -> IO FilePath
472           create_directory name n
473               = do createDirectory $ newname name n
474                    setCurrentDirectory $ newname name n
475                    getCurrentDirectory
476                 `catch` (\e -> if isAlreadyExistsError e
477                                then create_directory name (n+1)
478                                else throwIO e)
479
480 rmRecursive :: FilePath -> IO ()
481 rmRecursive d =
482     do isd <- isDirectory <$> getSymbolicLinkStatus d
483        if not isd
484           then removeFile d
485           else when isd $ do conts <- actual_dir_contents
486                              withCurrentDirectory d $
487                                mapM_ rmRecursive conts
488                              removeDirectory d
489     where actual_dir_contents = -- doesn't include . or ..
490               do c <- getDirectoryContents d
491                  return $ filter (/=".") $ filter (/="..") c
492
493 withCurrentDirectory :: FilePath -> IO r -> IO r
494 withCurrentDirectory name m =
495     bracket
496         (do cwd <- getCurrentDirectory
497             when (name /= "") (setCurrentDirectory name)
498             return cwd)
499         (\oldwd -> setCurrentDirectory oldwd)
500         (const m)
501