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