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