b79057a1e92c33cd5a40acf3e99f4ea3bcabbf7c
[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
19
20 import Parser
21 import SemSyn
22 import Type
23 import Shapify
24 import AST
25
26 import MyInterpret
27 import BundledCode
28 import JQuery
29
30 data PageInfo = PageInfo
31     { scrollX :: Maybe String
32     , scrollY :: Maybe String
33     , viewFunction :: String
34     , parseError :: Maybe String
35     , exMode  :: ExecMode
36     , outMode :: OutputMode
37     , showTypes :: Bool
38     , generatedModuleMB :: Maybe String
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 "+++
57                       "method described in the paper “" +++
58                       hotlink "http://doi.acm.org/10.1145/1291151.1291162"
59                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
60                       "” (ICFP'10) by " +++
61                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
62                         << "Kazutaka Matsuda" +++
63                       "."
64                 )
65                         
66         ) +++
67         form ! [method "POST",
68                 action "#",
69                 strAttr "onsubmit" "saveScroll()"
70             ] << (
71                 hidden "scrollx" (fromMaybe "0" scrollX) +++
72                 hidden "scrolly" (fromMaybe "0" scrollY) +++
73                 maindiv << (
74                          p << (
75                                 "Please enter the view function. (TODO: Elaborate this text)"
76                         ) +++
77
78                         p << (
79                                 concatHtml (map (\(name,thisCode) -> 
80                                         radio "load" name
81                                         ! (if thisCode == viewFunction then [checked] else [])
82                                         +++ name +++ " "
83                                 ) examples) +++
84                                 mkSubmit True Load +++
85                                 br +++
86                                 textarea ! [name "code", cols "120", rows "7"] << viewFunction
87                         ) 
88                         
89                 ) +++
90                 ( htmlMB parseError $ \err -> 
91                      maindiv << p << (
92                         "Can not parse your definition:" +++ br +++
93                         pre << show err +++ br +++
94                         mkSubmit True Check)
95                 ) +++
96                 -- p << astInfo mbAST +++
97                 maindiv ! [ identifier "output" ]<< (
98                         p << (
99                                 "You can calculate a derived put function with various options:" ) +++
100                         p << ( "Execution mode: " +++
101                                concatHtml (map (\mode -> 
102                                   radio "execMode" (show mode) 
103                                         ! (guard (mode == exMode) >> return checked)
104                                         +++ show mode +++ " "
105                                 ) [Normal, Shapify, ShapifyPlus]) +++ br +++
106                                "Output mode: " +++
107                                concatHtml (map (\mode -> 
108                                   radio "outputMode" (show mode) 
109                                         ! (guard (mode == outMode) >> return checked)
110                                         +++ show mode +++ " "
111                                 ) [PseudoCode, HaskellCode, ForwardCode]) +++ br +++
112                                "Show types " +++ checkbox "showTypes" "showTypes"
113                                         ! (guard showTypes >> return checked)
114                                         +++ br +++
115                                mkSubmit True BiDi
116                         ) +++
117                         ( htmlMB generatedModuleMB $ \ generatedModule -> 
118                             {- maybe noHtml outputErrors errors +++ -}
119                             p << ("Result:"+++ br +++
120                                 pre << generatedModule
121
122                             )
123
124                         )
125                 ) +++
126                 ( htmlMB playCodeMB $ \playCode -> maindiv << ( 
127                     p << (  "You can now play with the code. You can modify the " +++
128                             tt << "source" +++ " and calculate the view, or modify the " +++
129                             tt << "view" +++ " and calculate an updated souce." +++ br +++
130                             textarea ! [name "playCode", cols "120", rows "8" ] << playCode
131                     ) +++
132                     p << ( "Evaluate " +++
133                            mkSubmit True EvalGet +++ " " +++
134                            mkSubmit True EvalPut
135                     )
136                 )) +++
137                 ( htmlMB playErrorM $ \playError -> maindiv << ( 
138                     p << (
139                         strong << "An error occurred while evaluating your code:" +++ br +++
140                         pre << playError
141                         )
142                 ))
143         ) +++
144         maindiv << (
145                 p << (
146                 "The source code of this application and the underlying library can be found " +++
147                 hotlink "TODO" << "here"+++
148                 ".") +++
149                 p << ("© 2010 Joachim Breitner <" +++
150                       hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
151                       ">")
152                 )       
153         )
154        
155
156 cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
157
158 maindiv = thediv ! [theclass "main"]
159         
160 examples =
161         [ ("init", unlines
162                 [ "init (Nil)         = Nil"
163                 , "init (Cons(a,Nil)) = Nil"
164                 , "init (Cons(a,Cons(b,x))) = Cons(a,initWork(b,x))"
165                 , "initWork(a,Nil)       = Nil"
166                 , "initWork(a,Cons(b,x)) = Cons(a,initWork(b,x))"
167                 ])
168         , ("initHalf", unlines
169                 [ "initHalf(Nil)       = Nil"
170                 , "initHalf(Cons(a,x)) = Cons(a,initHalfWork(x,x))"
171                 , ""
172                 , "initHalfWork(xs, Nil)         = Nil"
173                 , "initHalfWork(xs, Cons(x,Nil)) = Nil"
174                 , "initHalfWork(Cons(a,x), Cons(b,Cons(c,y)))"
175                 , "                    = Cons(a,initHalfWork(x,y))"
176                 ])
177         , ("seive", unlines
178                 [ "seive (Nil)               = Nil"
179                 , "seive (Cons(a,Nil))       = Nil"
180                 , "seive (Cons(a,Cons(b,x))) = Cons(b,seive(x))"
181                 ])
182         , ("rev", unlines
183                 [ "reverse(xs) = rev(xs,Nil)"
184                 , "rev(Nil,y)       = y"
185                 , "rev(Cons(a,x),y) = rev(x,Cons(a,y))"
186                 ])
187         ]
188
189 defaultCode = fromJust (lookup "init" examples)
190         
191 outputErrors :: String -> Html
192 outputErrors s = 
193            p << (
194                 strong << "An error occurred:" +++ br +++
195                 pre << s
196                 )
197                 
198 mkSubmit active what = submit (submitId what) (submitLabel what)
199                        ! if active then [] else [disabled]
200
201 data Run = Get | Check | Load | BiDi | EvalPut | EvalGet
202
203
204 submitId Get = "get source"
205 submitId Check = "check"
206 submitId Load = "load"
207 submitId BiDi = "submitBiDi"
208 submitId EvalPut = "evalPut"
209 submitId EvalGet = "evalGet"
210
211 submitCode Get   = Just ("get source")
212 submitCode Check = Nothing
213 submitCode Load  = Nothing
214
215 submitLabel Check =   "Re-Parse definition"
216 submitLabel Load  =   "Load example"
217 submitLabel EvalGet = "view = get source"
218 submitLabel EvalPut = "result = put source view"
219 submitLabel BiDi =    "bidirectionalize"
220
221 main = runCGI (handleErrors cgiMain)
222
223 -- This function will not work in all casses, but in most.
224 delDefinition name code = unlines squashed
225   where filtered = filter (not . defines name) (lines code)
226         squash [] = []
227         squash ("":_) = [""]
228         squash ("\r":_) = [""]
229         squash ls = ls
230         squashed = concat $ map squash $ group $ filtered
231
232 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
233   where squashed = lines (delDefinition name code)
234         pad | last squashed == "" || last squashed == "\r" = []
235             | otherwise                                    = [""]
236         new_line = [name ++ " = " ++ def]
237         
238 defines "" (' ':_) = True
239 defines "" ('=':_) = True
240 defines "" "" = False
241 defines "" _   = False
242 defines _  ""  = False
243 defines (i:is) (x:xs) | i == x = defines is xs
244                       | i /= x = False
245
246 cgiMain = do
247     qs <- queryString
248     if qs == "jquery"
249      then jQueryMain
250      else formMain
251
252 jQueryMain = do
253         setHeader "Content-type" "text/javascript"
254         setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
255         setHeader "Cache-control" "max-age=36000000" -- 1000 h
256         outputFPS $ jQueryCode
257     
258 defaultPlayCode get = -- Are we only considering [Nat] here?
259         Just $ unlines
260             [ "get = " ++ get
261             , "put = " ++ get ++ "_B" 
262             , ""
263             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
264             ]
265
266 formMain = do
267         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
268
269         exMode  <- maybe Normal read <$> getInput "execMode"
270         outMode <- maybe HaskellCode read <$> getInput "outputMode"
271         showTypes <- isJust <$> getInput "showTypes"
272         
273         todo <- msum <$> sequence (
274             map (\what -> fmap (const what) <$> getInput (submitId what))
275             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
276         
277         code <- fromMaybe defaultCode <$> getInput "code"
278         
279         code <- case todo of
280             Just Load -> do loadWhat <- getInput "load"
281                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
282             _ -> return code
283         
284         let eAST = parseString code
285
286         let conf = defaultConfig { outputMode = outMode, execMode = exMode, isShowType = showTypes }
287         let parseError = either (Just . show) (const Nothing) eAST
288
289         let (genCodeM,getM) = case (todo,eAST) of
290                 (Just Load, _) -> (Nothing, Nothing)
291                 (Just _, Right ast) ->
292                     (  Just $ render $ case exMode of 
293                        Normal -> outputCode conf False ast (typeInference ast)
294                        Shapify -> outputCode conf False ast (shapify $ typeInference ast)
295                        ShapifyPlus -> outputCode conf True  ast (introNat $ shapify $ typeInference ast)
296                     ,  firstDeclaredName ast
297                     )
298                 _ -> (Nothing, Nothing)
299
300         pcM <- getInput "playCode" 
301         -- Playcode can only by used when the output is exMode
302         (playCode, playErrorM) <- if outMode /= HaskellCode then return (Nothing, Nothing) else
303             case (todo,getM,genCodeM,pcM) of
304             -- The user successfully generated code to play with, insert default playCode.
305             -- Do not use the user input, as he probably switched to a new example.
306             (Just BiDi, Just get, Just _, _) -> return (defaultPlayCode get, Nothing)
307             -- The user played with the code
308             (Just EvalGet, Just get, Just genCode, Just pc) -> do
309                 view <- liftIO $ evaluateWith genCode pc ("get source")
310                 case view of 
311                     Left err -> return $ (Just pc, Just err)
312                     Right dat -> return $ (\r -> (Just r, Nothing))
313                                         $ addDefiniton "view" dat 
314                                         $ delDefinition "result"
315                                         $ pc
316             (Just EvalGet, Just get, Just genCode, Nothing) -> do
317                 return (defaultPlayCode get, Nothing)
318             (Just EvalPut, Just get, Just genCode, Just pc) -> do
319                 view <- liftIO $ evaluateWith genCode pc ("put source view")
320                 case view of 
321                     Left err -> return $ (Just pc, Just err)
322                     Right dat -> return $ (\r -> (Just r, Nothing))
323                                         $ addDefiniton "result" dat 
324                                         $ pc
325             (Just EvalPut, Just get, Just _, Nothing) -> do
326                 return (defaultPlayCode get, Nothing)
327             _ -> return (Nothing, Nothing)
328
329         scrollX <- getInput "scrollx"
330         scrollY <- getInput "scrolly"
331
332         outputFPS $ fromString $ showHtml $ page $
333             PageInfo scrollX
334                      scrollY
335                      code
336                      parseError
337                      exMode
338                      outMode
339                      showTypes
340                      genCodeM
341                      playCode
342                      playErrorM
343
344 evaluateWith :: String -> String -> String -> IO (Either String String)
345 evaluateWith genCode playCode expr =
346     withinTmpDir $ do
347         BS.writeFile "BUtil.hs" bUtilCode
348         writeFile "Main.hs" $ "module Main where\n" ++ genCode
349         liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
350   where mods = 
351             [ "BUtil"
352             , "Main"
353             --, "Data.Maybe"
354             ]
355         imports = mods ++
356             [ "Data.Maybe"
357             ]
358
359 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode
360     where genCode' = unlines . filter (not . isPrefixOf "import") . lines $ genCode
361
362 astInfo (Left err) = maindiv << p << (
363         "Can not parse your definition:" +++ br +++
364         pre << show err +++ br +++
365         mkSubmit True Check)
366
367 astInfo (Right source) = maindiv << (
368         p << ("Definition parsed succesfully") +++
369         p << mkSubmit True Check
370         )
371
372 cssStyle = unlines 
373         [ "body { padding:0px; margin: 0px; }"
374         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
375         , "              background-color:#efefef;"
376         , "              border-bottom:1px solid black; }"
377         , "span.title { font-size:xx-large; font-weight:bold; }"
378         , "span.subtitle { padding-left:30px; font-size:large; }"
379         , "div.main { border:1px dotted black;"
380         , "                   padding:10px; margin:10px; }"
381         , "div.submain { padding:10px; margin:11px; }"
382         , "p.subtitle { font-size:large; font-weight:bold; }"
383         , "input.type { font-family:monospace; }"
384         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
385         , "span.mono { font-family:monospace; }"
386         , "pre { margin:10px; margin-left:20px; padding:10px;"
387         , "          border:1px solid black; }"
388         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
389         , "p { text-align:justify; }"
390         ]
391
392 jsCode = unlines 
393     [ "function saveScroll () {"
394     , "    $(\"#scrolly\").val($(\"html\").scrollTop());"
395     , "}"
396     , "function restoreScroll () {"
397     , "    $(\"html\").scrollTop($(\"#scrolly\").val());"
398     , "}"
399     ]
400
401 htmlMB Nothing  f = noHtml
402 htmlMB (Just x) f = f x
403
404 readOnly = emptyAttr "readonly"
405
406
407 firstDeclaredName (AST []) = Nothing
408 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
409
410 {-
411  - Temp-Dir functions taken from XMonad/Lock.hs and simplified
412  -}
413 withinTmpDir :: IO a -> IO a
414 withinTmpDir job = do
415   absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
416   formerdir <- getCurrentDirectory
417   bracket (create_directory absolute_name 0)
418           (\dir -> do setCurrentDirectory formerdir
419                       rmRecursive dir)
420           (const job)
421     where newname name 0 = name
422           newname name n = name ++ "-" ++ show n
423           create_directory :: FilePath -> Int -> IO FilePath
424           create_directory name n
425               = do createDirectory $ newname name n
426                    setCurrentDirectory $ newname name n
427                    getCurrentDirectory
428                 `catch` (\e -> if isAlreadyExistsError e
429                                then create_directory name (n+1)
430                                else throwIO e)
431
432 rmRecursive :: FilePath -> IO ()
433 rmRecursive d =
434     do isd <- isDirectory <$> getSymbolicLinkStatus d
435        if not isd
436           then removeFile d
437           else when isd $ do conts <- actual_dir_contents
438                              withCurrentDirectory d $
439                                mapM_ rmRecursive conts
440                              removeDirectory d
441     where actual_dir_contents = -- doesn't include . or ..
442               do c <- getDirectoryContents d
443                  return $ filter (/=".") $ filter (/="..") c
444
445 withCurrentDirectory :: FilePath -> IO r -> IO r
446 withCurrentDirectory name m =
447     bracket
448         (do cwd <- getCurrentDirectory
449             when (name /= "") (setCurrentDirectory name)
450             return cwd)
451         (\oldwd -> setCurrentDirectory oldwd)
452         (const m)
453