Indent cabal install command line
[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 System.Directory
14 import Prelude hiding ( catch )
15 import Control.Exception
16 import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )
17 import System.Posix.Env
18
19
20 import Parser
21 import SemSyn
22 import AST
23
24 import MyInterpret
25 import BundledCode
26 import JQuery
27
28 {-------------------------
29  - Types (Logic/Presentation interface
30  -------------------------}
31
32 data PageInfo = PageInfo
33     { config :: Config
34     , scrollX :: Maybe String
35     , scrollY :: Maybe String
36     , viewFunction :: String
37     , astError :: Maybe String
38     , generatedModuleMB :: Maybe String
39     , showCode :: Bool
40     , playCodeMB :: Maybe String
41     , playErrorM :: Maybe String
42     } 
43
44 data Run = Get | Check | Load | BiDi | EvalPut | EvalGet
45
46 {-------------------------
47  - Default and example data
48  -------------------------}
49
50 examples :: [(String, String)]
51 examples =
52         [ ("init", unlines
53                 [ "init []      = []"
54                 , "init [a]     = []"
55                 , "init (a:b:x) = a:initWork b x"
56                 , ""
57                 , "initWork a []    = []"
58                 , "initWork a (b:x) = a:initWork b x"
59                 ])
60         , ("tail", unlines
61                 [ "tail []     = []"
62                 , "tail (x:xs) = xs"
63                 ])
64         , ("sieve", unlines
65                 [ "sieve []      = []"
66                 , "sieve [a]     = []"
67                 , "sieve (a:b:x) = b:sieve x"
68                 ])
69         , ("halve", unlines
70                 [ "halve []    = []"
71                 , "halve (a:x) = a:halveWork x x"
72                 , ""
73                 , "halveWork xs    []      = []"
74                 , "halveWork xs    [x]     = []"
75                 , "halveWork (a:x) (b:c:y) = a:halveWork x y"
76                 ])
77         , ("rev", unlines
78                 [ "reverse []     = []"
79                 , "reverse (x:xs) = rev xs [x]"
80                 , ""
81                 , "rev []    y = y"
82                 , "rev (a:x) y = rev x (a:y)"
83                 ])
84         ]
85
86 defaultPlayCode :: Config -> String -> Maybe String
87 defaultPlayCode (Config{ b18nMode = SyntacticB18n}) get =
88         Just $ unlines
89             [ "get s = Main." ++ get ++ " s"
90             , "put s v = " ++ get ++ "_B s v"
91             , ""
92             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
93             ]
94 defaultPlayCode (Config{ b18nMode = SemanticB18n}) get =
95         Just $ unlines
96             [ "get s = Main." ++ get ++ " s"
97             , "put s v = " ++ get ++ "_B s v"
98             , ""
99             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
100             ]
101 defaultPlayCode (Config{ b18nMode = CombinedB18n}) get =
102         Just $ unlines
103             [ "get s = Main." ++ get ++ " s"
104             , "put s v = fromMaybe (error \"Could not handle shape change.\") $ " ++
105                  get ++ "_Bbd bias default_value s v"
106             , "bias = rear         -- or another option, e.g., front, middle, borders"
107             , "default_value = 42  -- or another value of the element type of source"
108             , ""
109             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
110             ]
111
112 defaultCode :: String
113 defaultCode = fromJust (lookup "init" examples)
114
115 {-------------------------
116  - Program logic
117  -------------------------}
118
119 -- This function will not work in all casses, but in most.
120 delDefinition :: String -> String -> String
121 delDefinition name code = unlines squashed
122   where filtered = filter (not . defines name) (lines code)
123         squash [] = []
124         squash ("":_) = [""]
125         squash ("\r":_) = [""]
126         squash ls = ls
127         squashed = concat $ map squash $ group $ filtered
128
129 addDefinition :: String -> String -> String -> String
130 addDefinition name def code = unlines (squashed ++ pad ++ new_line)
131   where squashed = lines (delDefinition name code)
132         pad | last squashed == "" || last squashed == "\r" = []
133             | otherwise                                    = [""]
134         new_line = [name ++ " = " ++ def]
135         
136 defines :: String -> String -> Bool
137 defines "" (' ':_) = True
138 defines "" ('=':_) = True
139 defines "" "" = False
140 defines "" _   = False
141 defines _  ""  = False
142 defines (i:is) (x:xs) | i == x    = defines is xs
143                       | otherwise = False
144
145 formMain :: CGI CGIResult
146 formMain = do
147         setHeader "Content-type" "text/html; charset=UTF-8"
148
149         conf <- do
150             b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode"
151             return $ adjustConfig $ defaultConfig
152                 { isHaskellify = True
153                 , b18nMode = b18nMode'
154                 }
155         
156         todo <- msum <$> sequence (
157             map (\what -> fmap (const what) <$> getInput (submitId what))
158             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
159         
160         code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code"
161
162         code <- case todo of
163             Just Load -> do loadWhat <- getInput "loadCode"
164                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
165             _ -> return code
166         
167         let eAST = parseString code
168
169
170         let astError = either (Just . show) checkBidirectionalizability eAST
171
172         let (genCodeM,getM) = case (todo,eAST) of
173                 (Just Load, _) -> (Nothing, Nothing)
174                 (Just _, Right ast) ->
175                     (  Just $ render $ renderCode conf ast
176                     ,  firstDeclaredName ast
177                     )
178                 _ -> (Nothing, Nothing)
179
180         showCode <- maybe False read <$> getInput "showCode"
181
182         pcM <- getInput "playCode" 
183         (playCode, playErrorM) <-
184             case (todo,getM,genCodeM,pcM) of
185             -- The user successfully generated code to play with, insert default playCode.
186             -- Do not use the user input, as he probably switched to a new example.
187             (Just BiDi, Just get, Just _, _) ->
188                 return (defaultPlayCode conf get, Nothing)
189             -- The user played with the code
190             (Just EvalGet, Just get, Just genCode, Just pc) -> do
191                 view <- liftIO $ evaluateWith genCode pc ("get source")
192                 case view of 
193                     Left err -> return $ (Just pc, Just err)
194                     Right dat -> return $ (\r -> (Just r, Nothing))
195                                         $ addDefinition "view" dat 
196                                         $ delDefinition "result"
197                                         $ pc
198             (Just EvalGet, Just get, Just genCode, Nothing) -> do
199                 return (defaultPlayCode conf get, Nothing)
200             (Just EvalPut, Just get, Just genCode, Just pc) -> do
201                 view <- liftIO $ evaluateWith genCode pc ("put source view")
202                 case view of 
203                     Left err -> return $ (Just pc, Just err)
204                     Right dat -> return $ (\r -> (Just r, Nothing))
205                                         $ addDefinition "result" dat 
206                                         $ pc
207             (Just EvalPut, Just get, Just _, Nothing) -> do
208                 return (defaultPlayCode conf get, Nothing)
209             _ -> return (Nothing, Nothing)
210
211         scrollX <- getInput "scrollx"
212         scrollY <- getInput "scrolly"
213
214         outputFPS $ fromString $ showHtml $ page $
215             PageInfo conf
216                      scrollX
217                      scrollY
218                      code
219                      astError
220                      genCodeM
221                      showCode
222                      playCode
223                      playErrorM
224
225 evaluateWith :: String -> String -> String -> IO (Either String String)
226 evaluateWith genCode playCode expr =
227     withinTmpDir $ do
228         BS.writeFile "BUtil.hs" bUtilCode
229         writeFile "Main.hs" $ "module Main where\n" ++ genCode
230         liftIO $ catchInterpreterErrors $ simpleInterpret mods imports playCode expr
231   where mods = 
232             [ "BUtil"
233             , "Main"
234             --, "Data.Maybe"
235             ]
236         imports = mods ++
237             [ "Data.Maybe"
238             , "Prelude"
239             ]
240
241 {-------------------------
242  - CGI Interface
243  -------------------------}
244
245 main :: IO ()
246 main = runCGI (handleErrors cgiMain)
247
248 cgiMain :: CGI CGIResult
249 cgiMain = do
250     qs <- queryString
251     if qs == "jquery"
252      then jQueryMain
253      else formMain
254
255 jQueryMain :: CGI CGIResult
256 jQueryMain = do
257         setHeader "Content-type" "text/javascript"
258         setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
259         setHeader "Cache-control" "max-age=36000000" -- 1000 h
260         outputFPS $ jQueryCode
261     
262
263 {-------------------------
264  - HTML generation
265  -------------------------}
266
267 submitId :: Run -> String
268 submitId Get = "get source"
269 submitId Check = "check"
270 submitId Load = "load"
271 submitId BiDi = "submitBiDi"
272 submitId EvalPut = "evalPut"
273 submitId EvalGet = "evalGet"
274
275 submitLabel :: Run -> String
276 submitLabel Check =   "Re-Parse definition"
277 submitLabel Load  =   "Load example"
278 submitLabel EvalGet = "view = get source"
279 submitLabel EvalPut = "result = put source view"
280 submitLabel BiDi =    "bidirectionalize"
281
282 b18nModeName :: B18nMode -> String
283 b18nModeName SemanticB18n = "Semantic bidir. (POPL’09)"
284 b18nModeName SyntacticB18n = "Syntactic bidir. (ICFP’07)"
285 b18nModeName CombinedB18n = "Combined bidir. (ICFP’10)"
286
287 mkSubmit :: Bool -> Run -> Html
288 mkSubmit active what = submit (submitId what) (submitLabel what)
289                        ! if active then [] else [disabled]
290
291 page :: PageInfo -> Html
292 page (PageInfo {..}) =
293        header << (
294         thetitle << "(Combining) Syntactic and Semantic Bidirectionalization" +++
295         style ! [ thetype "text/css" ] << cdata cssStyle +++
296         script ! [ thetype "text/javascript", src "?jquery" ] << noHtml +++
297         script ! [ thetype "text/javascript" ] << cdata jsCode 
298        ) +++
299        body ! [ strAttr "onload" "restoreScroll()" ] << (
300         thediv ! [theclass "top"] << (
301                 thespan ! [theclass "title"] << "(Combining) Syntactic and Semantic Bidirectionalization" +++
302                 thespan ! [theclass "subtitle"] << "Prototype implementation"
303         ) +++
304         maindiv << (
305                 p << "This tool allows you to experiment with the bidirectionalization methods described in the following papers: " +++
306                 ulist << (
307                     li << (
308                       "“" +++
309                       hotlink "http://doi.acm.org/10.1145/1291151.1291162"
310                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
311                       "” (ICFP’07) by " +++
312                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
313                         << "Kazutaka Matsuda" +++ ", " +++
314                       "Zhenjiang Hu, " +++
315                       "Keisuke Nakano, " +++
316                       "Makoto Hamana, and " +++
317                       "Masato Takeichi."
318                     ) +++
319                     li << (
320                       "“" +++
321                       hotlink "http://doi.acm.org/10.1145/1480881.1480904"
322                         << "Bidirectionalization for free! (Pearl)" +++
323                       "” (POPL’09) by " +++
324                       hotlink "http://www.iai.uni-bonn.de/~jv/"
325                         << "Janis Voigtländer"
326                     ) +++
327                     li << (
328                       "“" +++
329                       hotlink "http://www.iai.uni-bonn.de/~jv/icfp10.pdf"
330                         << "Combining Syntactic and Semantic Bidirectionalization" +++
331                       "” (ICFP’10) by " +++
332                       "Janis Voigtländer" +++ ", " +++
333                       "Zhenjiang Hu, " +++
334                       "Kazutaka Matsuda" +++ ", and " +++
335                       "Meng Wang"
336                     )
337                 ) +++
338                 p << (
339                   "(For a stand-alone version on command line, which is also able to " +++
340                   "show intermediate steps in the transformations, see " +++
341                   hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/b18n-combined/desc.html" << "here" +++ ". " +++
342                   "For the technique from POPL’09 alone, a "+++
343                   hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi"
344                     << "separate web interface" +++
345                   " offering more features is also available.)"
346                 )
347         ) +++
348         form ! [method "post",
349                 action "#",
350                 strAttr "onsubmit" "saveScroll()"
351             ] << (
352                 hidden "scrollx" (fromMaybe "0" scrollX) +++
353                 hidden "scrolly" (fromMaybe "0" scrollY) +++
354                 hidden "showCode" (show showCode) +++
355                 maindiv << (
356                          p << (
357                                 "Please enter the view function. The first function "+++
358                                 "defined will be assumed to be your view function. You "+++
359                                 "can use the first-order functional language from the "+++
360                                 "ICFP’07 paper, in Haskell syntax. The view function must "+++
361                                 "have type " +++ tt << "[a] -> [a]" +++ ". You can also load "+++
362                                 "some predefined examples."
363                         ) +++
364
365                         p << (
366                                 concatHtml (map (\(name,thisCode) -> 
367                                         radio "loadCode" name
368                                         ! (if thisCode == viewFunction then [checked] else [])
369                                         +++ name +++ " "
370                                 ) examples) +++
371                                 mkSubmit True Load +++
372                                 br +++
373                                 textarea ! [name "code", cols "120", rows "7"] << viewFunction
374                         ) 
375                         
376                 ) +++
377                 ( case astError of 
378                   Just err -> 
379                      maindiv << p << (
380                         "There was an error with the view function:" +++ br +++
381                         pre << err +++ br +++
382                         mkSubmit True Check +++
383                         p << (
384                             "The "+++
385                             hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi"
386                              << "purely semantic bidirectionalization technique" +++
387                             " (POPL’09) may still be able to handle your view function. "+++
388                             "For the combined technique (ICFP’10) it may be possible " +++
389                             "to recover applicability by using some program transformation "+++
390                             "techniques as discussed in Section 7 of the paper."
391                         )
392                      )
393                   Nothing -> 
394                     maindiv ! [ identifier "output" ]<< (
395                         p << ( "You can try all three bidirectionalization methods." ) +++
396                         p << (  concatHtml (map (\mode -> 
397                                   radio "b18nMode" (show mode) 
398                                         ! (guard (mode == b18nMode config) >> return checked)
399                                         +++ b18nModeName mode +++ " "
400                                 ) [SyntacticB18n, SemanticB18n, CombinedB18n]) +++ " " +++
401                                mkSubmit True BiDi
402                         ) +++
403                         ( htmlMB generatedModuleMB $ \ generatedModule -> 
404                             p << ("Result Code" +++
405                                 thespan ! [ identifier "hideShow"
406                                           , thestyle "display:none"] << (
407                                     " (" +++ hotlink "javascript:" << "Hide/Show" +++ ")"
408                                 ) +++ ":" +++ br +++
409                                 pre ! [identifier "genCode" ] << generatedModule
410
411                             )
412
413                         )
414                     ) +++
415                     ( htmlMB playCodeMB $ \playCode -> maindiv << ( 
416                         p << (  "You can now play with the code. You can modify the " +++
417                                 tt << "source" +++ " and calculate the " +++
418                                 tt << "view" +++ ", or modify the " +++
419                                 tt << "view" +++ " and calculate an updated "+++
420                                 tt << "source" +++ "." +++ br +++
421                                 textarea ! [name "playCode", cols "120", rows "12" ] << playCode
422                         ) +++
423                         p << ( "Evaluate " +++
424                                mkSubmit True EvalGet +++ " " +++
425                                mkSubmit True EvalPut
426                         )
427                     )) +++
428                     ( htmlMB playErrorM $ \playError -> maindiv << ( 
429                         p << (
430                             strong << "An error occurred while evaluating your code:" +++ br +++
431                             pre << playError
432                             )
433                     ))
434                 ) 
435         ) +++
436         maindiv << (
437             p << (
438                 "The source code of this application and the underlying library can be found " +++
439                 hotlink "http://hackage.haskell.org/package/bidirectionalization-combined" << "on hackage" +++
440                 ". " +++
441                 "The code for the web interface is based on " +++
442                 hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi" << 
443                     "the demo interface from “Bidirectionalization for free!”"
444             ) +++
445             p << ("© 2010 Kazutaka Matsuda, Joachim Breitner <" +++
446                 hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
447               ">")
448             )   
449         )
450        
451 cdata :: String -> Html
452 cdata s = primHtml $
453     -- "<!--//--><![CDATA[//><!--\n" ++
454     s
455     -- ++"\n//--><!]]>"
456
457 maindiv :: Html -> Html
458 maindiv = thediv ! [theclass "main"]
459
460 {-------------------------
461  - Static Web code
462  -------------------------}
463
464 cssStyle :: String
465 cssStyle = unlines 
466         [ "body { padding:0px; margin: 0px; }"
467         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
468         , "              background-color:#efefef;"
469         , "              border-bottom:1px solid black; }"
470         , "span.title { font-size:xx-large; font-weight:bold; }"
471         , "span.subtitle { padding-left:30px; font-size:large; }"
472         , "div.main { border:1px dotted black;"
473         , "                   padding:10px; margin:10px; }"
474         , "div.submain { padding:10px; margin:11px; }"
475         , "p.subtitle { font-size:large; font-weight:bold; }"
476         , "input.type { font-family:monospace; }"
477         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
478         , "span.mono { font-family:monospace; }"
479         , "pre { margin:10px; margin-left:20px; padding:10px;"
480         , "          border:1px solid black; }"
481         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
482         , "p { text-align:justify; }"
483         ]
484
485 jsCode :: String
486 jsCode = unlines 
487     [ "function saveScroll () {"
488     , "    $('#scrolly').val($('html').scrollTop());"
489     , "}"
490     , "function restoreScroll () {"
491     , "    $('html').scrollTop($('#scrolly').val());"
492     , "}"
493     , "$(document).ready(function () {"
494     , "   $('#hideShow').show();"
495     , "   if ($('#showCode').val() == 'False')"
496     , "     { $('#genCode').hide(); };"
497     , "   $('#hideShow a').click(function () {"
498     , "      $('#showCode').val("
499     , "         $('#genCode').is(':visible') ? 'False' : 'True'"
500     , "      );"
501     , "      $('#genCode').toggle('slow');"
502     , "   })"
503     , "})"
504     ]
505
506 {-------------------------
507  - Utility functions
508  -------------------------}
509
510 htmlMB :: Maybe t -> (t -> Html) -> Html
511 htmlMB Nothing  _ = noHtml
512 htmlMB (Just x) f = f x
513
514 firstDeclaredName :: AST -> Maybe String
515 firstDeclaredName (AST []) = Nothing
516 firstDeclaredName (AST (Decl n _ _ _:_)) = Just (show n)
517
518 {-
519  - Temp-Dir functions taken from XMonad/Lock.hs and simplified.
520  - It also changes TMP so that hint’s temporary files are stored within this directory
521  -}
522 withinTmpDir :: IO a -> IO a
523 withinTmpDir job = do
524   absolute_name <- (++ "/sem_syn.cgi") <$> getTemporaryDirectory
525   formerdir <- getCurrentDirectory
526   formerTMP <- getEnv "TMPDIR"
527   bracket (do dir <- create_directory absolute_name 0
528               setEnv "TMPDIR" dir True  
529               return dir
530           )
531           (\dir -> do setCurrentDirectory formerdir
532                       maybe (unsetEnv "TMPDIR") (\p -> setEnv "TMPDIR" p True) formerTMP
533                       rmRecursive dir)
534           (const job)
535     where newname name 0 = name
536           newname name n = name ++ "-" ++ show n
537           create_directory :: FilePath -> Int -> IO FilePath
538           create_directory name n
539               = do createDirectory $ newname name n
540                    setCurrentDirectory $ newname name n
541                    getCurrentDirectory
542                 `catch` (\e -> if isAlreadyExistsError e
543                                then create_directory name (n+1)
544                                else throwIO e)
545
546 rmRecursive :: FilePath -> IO ()
547 rmRecursive d =
548     do isd <- isDirectory <$> getSymbolicLinkStatus d
549        if not isd
550           then removeFile d
551           else when isd $ do conts <- actual_dir_contents
552                              withCurrentDirectory d $
553                                mapM_ rmRecursive conts
554                              removeDirectory d
555     where actual_dir_contents = -- doesn't include . or ..
556               do c <- getDirectoryContents d
557                  return $ filter (/=".") $ filter (/="..") c
558
559 withCurrentDirectory :: FilePath -> IO r -> IO r
560 withCurrentDirectory name m =
561     bracket
562         (do cwd <- getCurrentDirectory
563             when (name /= "") (setCurrentDirectory name)
564             return cwd)
565         (\oldwd -> setCurrentDirectory oldwd)
566         (const m)
567