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