Remove ShowType button
[darcs-mirror-sem_syn.git] / b18n-combined-cgi.hs
index 777430a..1116f8e 100644 (file)
@@ -49,20 +49,39 @@ page (PageInfo {..}) =
        ) +++
        body ! [ strAttr "onload" "restoreScroll()" ] << (
        thediv ! [theclass "top"] << (
-               thespan ! [theclass "title"] << "Combining Syntatic and Semantic Bidirectionalization" +++
+               thespan ! [theclass "title"] << "(Combining) Syntatic and Semantic Bidirectionalization" +++
                thespan ! [theclass "subtitle"] << "Prototype implementation"
        ) +++
        maindiv << (
-               p << ("This tool allows you to experiment with the "+++
-                      "method described in the paper “" +++
+               p << "This tool allows you to experiment with the bidirectionalization methods described in the following papers: " +++
+                ulist << (
+                    li << (
+                      "“" +++
                      hotlink "http://doi.acm.org/10.1145/1291151.1291162"
                         << "Bidirectionalization transformation based on automatic derivation of view complement functions" +++
-                     "” (ICFP'10) by " +++
+                     "” (ICFP'07) by " +++
                      hotlink "http://www.kb.ecei.tohoku.ac.jp/~kztk/"
-                        << "Kazutaka Matsuda" +++
-                     "."
+                        << "Kazutaka Matsuda" +++ ", " +++
+                      "Zhenjiang Hu, " +++
+                      "Keisuke Nakano, " +++
+                      "Makoto Hamana and " +++
+                      "Masato Takeichi."
+                    ) +++
+                    li << (
+                      "“" +++
+                     hotlink "http://doi.acm.org/10.1145/1480881.1480904"
+                        << "Bidirectionalization for free! (Pearl)" +++
+                     "” (POPL'09) by " +++
+                     hotlink "http://www.iai.uni-bonn.de/~jv/"
+                        << "Janis Voigtländer"
+                    ) +++
+                    li << (
+                      "“" +++
+                     hotlink ""
+                        << "TBT" +++
+                     "” (ICFP'10)"
+                    )
                )
-                       
        ) +++
         form ! [method "post",
                 action "#",
@@ -98,26 +117,17 @@ page (PageInfo {..}) =
                maindiv ! [ identifier "output" ]<< (
                        p << (
                                "You can calculate a derived put function with various options:" ) +++
-                       p << ( "Execution mode: " +++
-                              concatHtml (map (\mode -> 
-                                 radio "execMode" (show mode) 
-                                       ! (guard (mode == execMode config) >> return checked)
-                                       +++ show mode +++ " "
-                                ) [Normal, Shapify, ShapifyPlus]) +++ br +++
-                              "Output mode: " +++
+                       p << ( "Output mode: " +++
                               concatHtml (map (\mode -> 
                                  radio "b18nMode" (show mode) 
                                        ! (guard (mode == b18nMode config) >> return checked)
                                        +++ show mode +++ " "
                                 ) [SyntacticB18n, SemanticB18n, CombinedB18n, NoB18n]) +++ br +++
-                              "Show types " +++ checkbox "showTypes" "showTypes"
-                                        ! (guard (isShowType config) >> return checked)
-                                        +++ br +++
                               mkSubmit True BiDi
                        ) +++
                         ( htmlMB generatedModuleMB $ \ generatedModule -> 
                             {- maybe noHtml outputErrors errors +++ -}
-                            p << ("Result" +++
+                            p << ("Result Code" +++
                                 thespan ! [ identifier "hideShow"
                                           , thestyle "display:none"] << (
                                     " (" +++ hotlink "javascript:" << "Hide/Show" +++ ")"
@@ -130,8 +140,10 @@ page (PageInfo {..}) =
                ) +++
                 ( htmlMB playCodeMB $ \playCode -> maindiv << ( 
                     p << (  "You can now play with the code. You can modify the " +++
-                            tt << "source" +++ " and calculate the view, or modify the " +++
-                            tt << "view" +++ " and calculate an updated souce." +++ br +++
+                            tt << "source" +++ " and calculate the " +++
+                            tt << "view" +++ ", or modify the " +++
+                            tt << "view" +++ " and calculate an updated "+++
+                            tt << "source" +++ "." +++ br +++
                             textarea ! [name "playCode", cols "120", rows "8" ] << playCode
                     ) +++
                     p << ( "Evaluate " +++
@@ -147,14 +159,18 @@ page (PageInfo {..}) =
                 ))
        ) +++
         maindiv << (
-               p << (
+           p << (
                "The source code of this application and the underlying library can be found " +++
                hotlink "TODO" << "here"+++
-               ".") +++
-               p << ("© 2010 Joachim Breitner <" +++
-                      hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
-                     ">")
-               )       
+               ". " +++
+                "The code for the web interface is based on " +++
+                hotlink "http://www-ps.iai.uni-bonn.de/cgi-bin/bff.cgi" << 
+                    "the demo interface from “Bidirectionalization for free!”"
+            ) +++
+           p << ("© 2010 Joachim Breitner <" +++
+                hotlink "mailto:mail@joachim-breitner.de" << "mail@joachim-breitner.de" +++
+             ">")
+           )   
        )
        
 
@@ -164,30 +180,30 @@ maindiv = thediv ! [theclass "main"]
         
 examples =
        [ ("init", unlines
-               [ "init (Nil)         = Nil"
-               , "init (Cons(a,Nil)) = Nil"
-               , "init (Cons(a,Cons(b,x))) = Cons(a,initWork(b,x))"
-               , "initWork(a,Nil)       = Nil"
-               , "initWork(a,Cons(b,x)) = Cons(a,initWork(b,x))"
+               [ "init []      = []"
+               , "init [a]     = []"
+               , "init (a:b:x) = a:initWork b x"
+               , "initWork a []    = []"
+               , "initWork a (b:x) = a:initWork b x"
                ])
        , ("initHalf", unlines
-               [ "initHalf(Nil)       = Nil"
-               , "initHalf(Cons(a,x)) = Cons(a,initHalfWork(x,x))"
+               [ "initHalf []    = []"
+               , "initHalf (a:x) = a:initHalfWork x x"
                , ""
-               , "initHalfWork(xs, Nil)         = Nil"
-               , "initHalfWork(xs, Cons(x,Nil)) = Nil"
-               , "initHalfWork(Cons(a,x), Cons(b,Cons(c,y)))"
-               , "                    = Cons(a,initHalfWork(x,y))"
+               , "initHalfWork xs  []  = []"
+               , "initHalfWork xs  [x] = []"
+               , "initHalfWork (a:x) (b:c:y)"
+               , "                    = a:initHalfWork x y"
                ])
-       , ("seive", unlines
-               [ "seive (Nil)               = Nil"
-               , "seive (Cons(a,Nil))       = Nil"
-               , "seive (Cons(a,Cons(b,x))) = Cons(b,seive(x))"
+       , ("sieve", unlines
+               [ "sieve []      = []"
+               , "sieve [a]     = []"
+               , "sieve (a:b:x) = b:sieve x"
                ])
        , ("rev", unlines
-               [ "reverse(xs) = rev(xs,Nil)"
-               , "rev(Nil,y)       = y"
-               , "rev(Cons(a,x),y) = rev(x,Cons(a,y))"
+               [ "reverse xs = rev xs []"
+               , "rev []    y = y"
+               , "rev (a:x) y = rev x (a:y)"
                ])
        ]
 
@@ -260,48 +276,38 @@ jQueryMain = do
         setHeader "Cache-control" "max-age=36000000" -- 1000 h
         outputFPS $ jQueryCode
     
-defaultPlayCode Normal get =
+defaultPlayCode (Config{..}) get =
         Just $ unlines
-            [ "get = " ++ get
-            , "put = " ++ get ++ "_B" 
+            [ "get s = Main." ++ get ++ " s"
+            , "put s v = " ++ put
             , ""
             , "source = [0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10]"
             ]
-defaultPlayCode Shapify get =
-        Just $ unlines
-            [ "get = " ++ get
-            , "put = " ++ get ++ "_B" 
-            , ""
-            , "source = [(),(),(),()]"
-            ]
-defaultPlayCode ShapifyPlus get =
-        Just $ unlines
-            [ "get = " ++ get
-            , "put = " ++ get ++ "_B" 
-            , ""
-            , "source = S (S (S (S Z)))"
-            ]
+    where put | b18nMode == SyntacticB18n =
+                    get ++ "_140_B s v"
+              | b18nMode == SemanticB18n =
+                    get ++ "_B s v"
+              | b18nMode == CombinedB18n =
+                    "fromMaybe (error \"Could not handle shape change.\") $ " ++
+                    get ++ "_Bbd rear 42 s v"
 
 formMain = do
         setHeader "Content-type" "application/xhtml+xml; charset=UTF-8"
 
         conf <- do
-            execMode'  <- maybe Normal read <$> getInput "execMode"
             b18nMode' <- maybe CombinedB18n read <$> getInput "b18nMode"
-            isShowType' <- isJust <$> getInput "showTypes"
             return $ defaultConfig
                 { isHaskellify = True
                 , b18nMode = b18nMode'
-                , execMode = execMode'
-                , isShowType = isShowType'
+                , execMode = ShapifyPlus
                 }
        
        todo <- msum <$> sequence (
             map (\what -> fmap (const what) <$> getInput (submitId what))
             [ BiDi, Get, Check, Load, EvalPut, EvalGet])
         
-       code <- fromMaybe defaultCode <$> getInput "code"
-       
+       code <- filter (/= '\r') <$> fromMaybe defaultCode <$> getInput "code"
+
         code <- case todo of
             Just Load -> do loadWhat <- getInput "loadCode"
                             return $ fromMaybe code $ loadWhat >>= flip lookup examples 
@@ -315,10 +321,8 @@ formMain = do
         let (genCodeM,getM) = case (todo,eAST) of
                 (Just Load, _) -> (Nothing, Nothing)
                 (Just _, Right ast) ->
-                    (  Just $ render $ case execMode conf of 
-                       Normal -> outputCode conf False ast (typeInference ast)
-                       Shapify -> outputCode conf False ast (shapify $ typeInference ast)
-                       ShapifyPlus -> outputCode conf True  ast (introNat $ shapify $ typeInference ast)
+                    (  Just $ render $
+                       outputCode conf True  ast (introNat $ shapify $ typeInference ast)
                     ,  firstDeclaredName ast
                     )
                 _ -> (Nothing, Nothing)
@@ -332,7 +336,7 @@ formMain = do
             -- The user successfully generated code to play with, insert default playCode.
             -- Do not use the user input, as he probably switched to a new example.
             (Just BiDi, Just get, Just _, _) ->
-                return (defaultPlayCode (execMode conf) get, Nothing)
+                return (defaultPlayCode conf get, Nothing)
             -- The user played with the code
             (Just EvalGet, Just get, Just genCode, Just pc) -> do
                 view <- liftIO $ evaluateWith genCode pc ("get source")
@@ -343,7 +347,7 @@ formMain = do
                                         $ delDefinition "result"
                                         $ pc
             (Just EvalGet, Just get, Just genCode, Nothing) -> do
-                return (defaultPlayCode (execMode conf) get, Nothing)
+                return (defaultPlayCode conf get, Nothing)
             (Just EvalPut, Just get, Just genCode, Just pc) -> do
                 view <- liftIO $ evaluateWith genCode pc ("put source view")
                 case view of 
@@ -352,7 +356,7 @@ formMain = do
                                         $ addDefiniton "result" dat 
                                         $ pc
             (Just EvalPut, Just get, Just _, Nothing) -> do
-                return (defaultPlayCode (execMode conf) get, Nothing)
+                return (defaultPlayCode conf get, Nothing)
             _ -> return (Nothing, Nothing)
 
         scrollX <- getInput "scrollx"
@@ -382,6 +386,7 @@ evaluateWith genCode playCode expr =
             ]
         imports = mods ++
             [ "Data.Maybe"
+            , "Prelude"
             ]
 
 withFullSource genCode playCode = genCode' ++ "\n" ++ playCode