Make MyInterpret more configurable WRT loaded modules
[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 Control.Monad
8 import Control.Applicative ((<$>),(<*>))
9 import Text.PrettyPrint.HughesPJ (render)
10 import System.IO
11 import Text.ParserCombinators.Parsec (ParseError)
12
13
14 import Parser
15 import SemSyn
16 import Type
17 import Shapify
18 import AST
19
20 import MyInterpret
21 import JQuery
22
23 data PageInfo = PageInfo
24     { scrollX :: Maybe String
25     , scrollY :: Maybe String
26     , viewFunction :: String
27     , parseError :: Maybe String
28     , exMode  :: ExecMode
29     , outMode :: OutputMode
30     , showTypes :: Bool
31     , generatedModuleMB :: Maybe String
32     , playCodeMB :: Maybe String
33     } 
34
35 page (PageInfo {..}) =
36        header << (
37         thetitle << "Combining Syntatic and Semantic Bidirectionalization" +++
38         style ! [ thetype "text/css" ] << cdata cssStyle +++
39         script ! [ thetype "text/javascript", src "?jquery" ] << noHtml +++
40         script ! [ thetype "text/javascript" ] << cdata jsCode 
41        ) +++
42        body ! [ strAttr "onload" "restoreScroll()" ] << (
43         thediv ! [theclass "top"] << (
44                 thespan ! [theclass "title"] << "Combining Syntatic and Semantic Bidirectionalization" +++
45                 thespan ! [theclass "subtitle"] << "Prototype implementation"
46         ) +++
47         maindiv << (
48                 p << ("This tool allows you to experiment with the "+++
49                       "method described in the paper “" +++
50                       hotlink "http://doi.acm.org/10.1145/1291151.1291162"
51                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
52                       "” (ICFP'10) by " +++
53                       hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
54                         << "Kazutaka Matsuda" +++
55                       "."
56                 )
57                         
58         ) +++
59         form ! [method "POST",
60                 action "#",
61                 strAttr "onsubmit" "saveScroll()"
62             ] << (
63                 hidden "scrollx" (fromMaybe "0" scrollX) +++
64                 hidden "scrolly" (fromMaybe "0" scrollY) +++
65                 maindiv << (
66                          p << (
67                                 "Please enter the view function. (TODO: Elaborate this text)"
68                         ) +++
69
70                         p << (
71                                 concatHtml (map (\(name,thisCode) -> 
72                                         radio "load" name
73                                         ! (if thisCode == viewFunction then [checked] else [])
74                                         +++ name +++ " "
75                                 ) examples) +++
76                                 mkSubmit True Load +++
77                                 br +++
78                                 textarea ! [name "code", cols "120", rows "7"] << viewFunction
79                         ) 
80                         
81                 ) +++
82                 ( htmlMB parseError $ \err -> 
83                      maindiv << p << (
84                         "Can not parse your definition:" +++ br +++
85                         pre << show err +++ br +++
86                         mkSubmit True Check)
87                 ) +++
88                 -- p << astInfo mbAST +++
89                 maindiv ! [ identifier "output" ]<< (
90                         p << (
91                                 "You can calculate a derived put function with various options:" ) +++
92                         p << ( "Execution mode: " +++
93                                concatHtml (map (\mode -> 
94                                   radio "execMode" (show mode) 
95                                         ! (guard (mode == exMode) >> return checked)
96                                         +++ show mode +++ " "
97                                 ) [Normal, Shapify, ShapifyPlus]) +++ br +++
98                                "Output mode: " +++
99                                concatHtml (map (\mode -> 
100                                   radio "outputMode" (show mode) 
101                                         ! (guard (mode == outMode) >> return checked)
102                                         +++ show mode +++ " "
103                                 ) [PseudoCode, HaskellCode, ForwardCode]) +++ br +++
104                                "Show types " +++ checkbox "showTypes" "showTypes"
105                                         ! (guard showTypes >> return checked)
106                                         +++ br +++
107                                mkSubmit True BiDi
108                         ) +++
109                         ( htmlMB generatedModuleMB $ \ generatedModule -> 
110                             {- maybe noHtml outputErrors errors +++ -}
111                             p << ("Result:"+++ br +++
112                                 textarea ! [name "gencode", cols "120"
113                                            , rows (show (1 + length (lines generatedModule)))
114                                            , readOnly
115                                            ] << generatedModule
116
117                             )
118
119                         )
120                 ) +++
121                 ( htmlMB playCodeMB $ \playCode -> maindiv << ( 
122                     p << (  "You can now play with the code. You can modify the " +++
123                             tt << "source" +++ " and calculate the view, or modify the " +++
124                             tt << "view" +++ " and calculate an updated souce." +++ br +++
125                             textarea ! [name "playCode", cols "120", rows "8" ] << playCode
126                     ) +++
127                     p << ( "Evaluate " +++
128                            mkSubmit True EvalGet +++ " " +++
129                            mkSubmit True EvalPut
130                     )
131                 ))
132         ) +++
133         maindiv << (
134                 p << (
135                 "The source code of this application and the underlying library can be found " +++
136                 hotlink "TODO" << "here"+++
137                 ".") +++
138                 p << ("© 2010 Joachim Breitner <" +++
139                       hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
140                       ">")
141                 )       
142         )
143        
144
145 cdata s = primHtml ("<![CDATA[\n"++ s ++ "\n]]>")
146
147 maindiv = thediv ! [theclass "main"]
148         
149 examples =
150         [ ("init", unlines
151                 [ "get (a) = init (a)"
152                 , "init (Nil)         = Nil"
153                 , "init (Cons(a,Nil)) = Nil"
154                 , "init (Cons(a,Cons(b,x))) = Cons(a,initWork(b,x))"
155                 , "initWork(a,Nil)       = Nil"
156                 , "initWork(a,Cons(b,x)) = Cons(a,initWork(b,x))"
157                 ])
158         , ("initHalf", unlines
159                 [ "get (a) = initHalf (a)"
160                 , "initHalf(Nil)       = Nil"
161                 , "initHalf(Cons(a,x)) = Cons(a,initHalfWork(x,x))"
162                 , ""
163                 , "initHalfWork(xs, Nil)         = Nil"
164                 , "initHalfWork(xs, Cons(x,Nil)) = Nil"
165                 , "initHalfWork(Cons(a,x), Cons(b,Cons(c,y)))"
166                 , "                    = Cons(a,initHalfWork(x,y))"
167                 ])
168         , ("seive", unlines
169                 [ "get (a) = seive (a)"
170                 , "seive (Nil)               = Nil"
171                 , "seive (Cons(a,Nil))       = Nil"
172                 , "seive (Cons(a,Cons(b,x))) = Cons(b,seive(x))"
173                 ])
174         , ("rev", unlines
175                 [ "get (a) = reverse (a)"
176                 , "reverse(xs) = rev(xs,Nil)"
177                 , "rev(Nil,y)       = y"
178                 , "rev(Cons(a,x),y) = rev(x,Cons(a,y))"
179                 ])
180         ]
181
182 defaultCode = fromJust (lookup "init" examples)
183         
184 outputErrors :: String -> Html
185 outputErrors s = 
186            p << (
187                 strong << "An error occurred:" +++ br +++
188                 pre << s
189                 )
190                 
191 mkSubmit active what = submit (submitId what) (submitLabel what)
192                        ! if active then [] else [disabled]
193
194 data Run = Get | Check | Load | BiDi | EvalPut | EvalGet
195
196
197 submitId Get = "get source"
198 submitId Check = "check"
199 submitId Load = "load"
200 submitId BiDi = "submitBiDi"
201 submitId EvalPut = "evalPut"
202 submitId EvalGet = "evalGet"
203
204 submitCode Get   = Just ("get source")
205 submitCode Check = Nothing
206 submitCode Load  = Nothing
207
208 submitLabel Check =   "Re-Parse definition"
209 submitLabel Load  =   "Load example"
210 submitLabel EvalGet = "view = get source"
211 submitLabel EvalPut = "result = put source view"
212 submitLabel BiDi =    "bidirectionalize"
213
214 main = runCGI (handleErrors cgiMain)
215
216 -- This function will not work in all casses, but in most.
217 delDefinition name code = unlines squashed
218   where filtered = filter (not . defines name) (lines code)
219         squash [] = []
220         squash ("":_) = [""]
221         squash ("\r":_) = [""]
222         squash ls = ls
223         squashed = concat $ map squash $ group $ filtered
224
225 addDefiniton name def code = unlines (squashed ++ pad ++ new_line)
226   where squashed = lines (delDefinition name code)
227         pad | last squashed == "" || last squashed == "\r" = []
228             | otherwise                                    = [""]
229         new_line = [name ++ " = " ++ def]
230         
231 defines "" (' ':_) = True
232 defines "" ('=':_) = True
233 defines "" "" = False
234 defines "" _   = False
235 defines _  ""  = False
236 defines (i:is) (x:xs) | i == x = defines is xs
237                       | i /= x = False
238
239 cgiMain = do
240     qs <- queryString
241     if qs == "jquery"
242      then jQueryMain
243      else formMain
244
245 jQueryMain = do
246         setHeader "Content-type" "text/javascript"
247         setHeader "Expires" "Fri, 01 Jan 2100 00:00:00 +0100"
248         setHeader "Cache-control" "max-age=36000000" -- 1000 h
249         outputFPS $ jQueryCode
250     
251
252 formMain = do
253         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
254
255         exMode  <- maybe Normal read <$> getInput "execMode"
256         outMode <- maybe HaskellCode read <$> getInput "outputMode"
257         showTypes <- isJust <$> getInput "showTypes"
258         
259         todo <- msum <$> sequence (
260             map (\what -> fmap (const what) <$> getInput (submitId what))
261             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
262         
263         code <- fromMaybe defaultCode <$> getInput "code"
264         
265         code <- case todo of
266             Just Load -> do loadWhat <- getInput "load"
267                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
268             _ -> return code
269         
270         let mbAST = parseString code
271
272         let conf = defaultConfig { outputMode = outMode, execMode = exMode, isShowType = showTypes }
273         let parseError = either (Just . show) (const Nothing) mbAST
274
275         let genCode = case (todo,mbAST) of
276                 (Just Load, _) -> Nothing
277                 (Just _, Right ast) -> Just $ render $ case exMode of 
278                        Normal -> outputCode conf False ast (typeInference ast)
279                        Shapify -> outputCode conf False ast (shapify $ typeInference ast)
280                        ShapifyPlus -> outputCode conf True  ast (introNat $ shapify $ typeInference ast)
281                 _ -> Nothing
282
283         let defaultPlayCode = Just $ "default code"
284
285         playCode <- case (todo,genCode) of
286             -- The user successfully generated code to play with, insert default playCode.
287             -- Do not use the user input, as he probably switched to a new example.
288             (Just BiDi, Just _) -> return defaultPlayCode
289             -- The user played with the code
290             (Just EvalGet, Just _) -> (`mplus` defaultPlayCode) <$> getInput "playCode"
291             (Just EvalPut, Just _) -> (`mplus` defaultPlayCode) <$> getInput "playCode"
292             (_, _ ) -> return Nothing
293
294         scrollX <- getInput "scrollx"
295         scrollY <- getInput "scrolly"
296
297         outputFPS $ fromString $ showHtml $ page $
298             PageInfo scrollX
299                      scrollY
300                      code
301                      parseError
302                      exMode
303                      outMode
304                      showTypes
305                      genCode
306                      playCode
307
308 astInfo (Left err) = maindiv << p << (
309         "Can not parse your definition:" +++ br +++
310         pre << show err +++ br +++
311         mkSubmit True Check)
312
313 astInfo (Right source) = maindiv << (
314         p << ("Definition parsed succesfully"
315 {-              "Your definitions have the following types: " +++
316                 pre << ("get :: " ++ getType ++ "\n"++
317                         "source :: " ++ sourceType) +++
318                 "Therefore, an updater can be derived by " +++
319                 case (canBff, canBffEq, canBffOrd) of
320                         (True, _, _) -> 
321                                 tt << "bff" +++ ", " +++
322                                 tt << "bff_Eq" +++ ", and " +++
323                                 tt << "bff_Ord" +++ "."
324                         (False, True, _) -> 
325                                 tt << "bff_Eq" +++ " and " +++
326                                 tt << "bff_Ord" +++ "."
327                         (False, False, True) -> 
328                                 tt << "bff_Ord" +++ " only."
329                         (False, False, False) -> 
330                                 "none of the " +++ tt << "bff" +++ " functions."
331 -}                                
332         ) +++
333         p << mkSubmit True Check
334         )
335
336 cssStyle = unlines 
337         [ "body { padding:0px; margin: 0px; }"
338         , "div.top { margin:0px; padding:10px; margin-bottom:20px;"
339         , "              background-color:#efefef;"
340         , "              border-bottom:1px solid black; }"
341         , "span.title { font-size:xx-large; font-weight:bold; }"
342         , "span.subtitle { padding-left:30px; font-size:large; }"
343         , "div.main { border:1px dotted black;"
344         , "                   padding:10px; margin:10px; }"
345         , "div.submain { padding:10px; margin:11px; }"
346         , "p.subtitle { font-size:large; font-weight:bold; }"
347         , "input.type { font-family:monospace; }"
348         , "input[type=\"submit\"] { font-family:monospace; background-color:#efefef; }"
349         , "span.mono { font-family:monospace; }"
350         , "pre { margin:10px; margin-left:20px; padding:10px;"
351         , "          border:1px solid black; }"
352         , "textarea { margin:10px; margin-left:20px; padding:10px;  }"
353         , "p { text-align:justify; }"
354         ]
355
356 jsCode = unlines 
357     [ "function saveScroll () {"
358     , "    $(\"#scrolly\").val($(\"html\").scrollTop());"
359     , "}"
360     , "function restoreScroll () {"
361     , "    $(\"html\").scrollTop($(\"#scrolly\").val());"
362     , "}"
363     ]
364
365 htmlMB Nothing  f = noHtml
366 htmlMB (Just x) f = f x
367
368 readOnly = emptyAttr "readonly"