Handle typeCheck error in Main.hs

[darcs-mirror-sem_syn.git] / Main.hs

diff --git a/Main.hs b/Main.hs
index b90e858..d1156c1 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -182,17 +182,17 @@ progName = unsafePerformIO getProgName
 usage = show $ 
     text "USAGE" $$
     text "-----" $$
-         nest 4 (text $ progName ++ " (-n|-s) (-T|-U) (-P|-H|-F) [-f] [FILENAME]\n") $+$ 
+         nest 4 (text $ progName ++ " (-n|-s) (-T|-U) (-no|-sem|-syn|-comb) [-hs] [-f] [FILENAME]\n") $+$ 
                   
          text ("This program is a prototype implementation of the paper:\n") $$
          nest 4 (sep [text "Janis Voigtlander, Zhenjiang Hu, Kazutaka Matsuda and Meng Wang:",
                        text "Combining Syntactic and Semantic Bidirectionalization.",
                        text "ICFP 2010.\n"])
          $$
-         wrap 80 ( "Given a \"get\" function defined in a file specified by FILENAME,"
+         wrap 80 ( "Given a \"get\" function defined in a file specified by FILENAME, "
                   ++ "the program returns \"put\" function by combining "
                   ++ "semantic bidirectionalization (Janis Voiglander: POPL'09) "
-                  ++ "and syntatic bidirectionalization (Kazutaka Matsuda et al.: ICFP'07). A typical usage is \""++ progName ++ " -H FILENAME\", which correspondes to the paper.\n"
+                  ++ "and syntatic bidirectionalization (Kazutaka Matsuda et al.: ICFP'07). A typical usage is \""++ progName ++ " FILENAME\", which correspondes to the paper.\n"
                   ) $+$
     text "OPTIONS" $$
     text "-------" $$
@@ -215,21 +215,6 @@ usage = show $
                 lnextSpace (' ':_) = 0
                 lnextSpace (c:s)   = 1 + lnextSpace s 
 
-isNormalMode conf =
-    ( b18nMode conf == SemanticB18n ) 
-    || ( (b18nMode conf == SyntacticB18n || b18nMode conf == NoB18n)
-         && (execMode conf == Normal) )
-    
-
-isShapifyMode conf = 
-    (b18nMode conf == SyntacticB18n || b18nMode conf == NoB18n)
-    && (execMode conf == Shapify)
-
-isShapifyPlusMode conf =
-    (b18nMode conf == CombinedB18n) 
-    || ( (b18nMode conf == SyntacticB18n || b18nMode conf == NoB18n)
-         && (execMode conf == ShapifyPlus) )
-
 main :: IO ()
 main = do { args <- getArgs 
           ; let conf = adjustConfig $ parseArgs args defaultConfig
@@ -244,7 +229,9 @@ main = do { args <- getArgs
                                        parseFile filename
                      ; case csterr of
                          Left err -> hPutStrLn stderr (show err)
-                         Right cprog -> 
+                         Right cprog ->  case typeInference cprog of
+                            Left err -> hPutStrLn stderr err
+                            Right typeChecked -> 
                              case execMode conf of 
 --                                Normal | (b18nMode conf == SyntacticB18n || b18nMode conf == NoB18n) -> 
 --                                    print $
@@ -256,29 +243,38 @@ main = do { args <- getArgs
 --                                    print $
 --                                          outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
                                Debug ->
-                                   do { print $ ppr   $ cprog
-                                      -- ; print $ pprAM $ constructAutomaton (typeInference cprog) initTAMap
-                                      ; let (p1,p2,p3) = constructBwdFunction (typeInference cprog)
-                                      ; print $ ppr p1 $$ ppr p2 $$ ppr p3
-                                      ; print $ ppr $ constructTypeDecl p2 
-                                      ; print $ ppr $ generateCodeBwd (typeInference cprog, p1,p2,p3)
-                                      ; putStrLn ""
-                                      ; putStrLn $ "---- After \"Shapify\" ----" 
-                                      ; let cprog' = introNat $ shapify $ typeInference cprog 
-                                      -- ; print $ pprAM $ constructAutomaton cprog' initTAMap
-                                      ; print $ cprog'                                       
-                                      ; let (p1,p2,p3) = constructBwdFunction cprog' 
-                                      ; print $ ppr p1 $$ ppr p2 $$ ppr p3
-                                      ; putStrLn ""
-                                      }
+                                       putStrLn "Debug mode does nothing."
+--                                    do { print $ ppr   $ cprog
+--                                       -- ; print $ pprAM $ constructAutomaton (typeInference cprog) initTAMap
+--                                       ; let (p1,p2,p3) = constructBwdFunction (typeInference cprog)
+--                                       ; print $ ppr p1 $$ ppr p2 $$ ppr p3
+--                                       ; print $ ppr $ constructTypeDecl p2 
+--                                       ; print $ ppr $ generateCodeBwd (typeInference cprog, p1,p2,p3)
+--                                       ; putStrLn ""
+--                                       ; putStrLn $ "---- After \"Shapify\" ----" 
+--                                       ; let cprog' = introNat $ shapify $ typeInference cprog 
+--                                       -- ; print $ pprAM $ constructAutomaton cprog' initTAMap
+--                                       ; print $ cprog'                                       
+--                                       ; let (p1,p2,p3) = constructBwdFunction cprog' 
+--                                       ; print $ ppr p1 $$ ppr p2 $$ ppr p3
+--                                       ; putStrLn ""
+--                                       }
                                _ | isNormalMode conf ->
-                                     print $ outputCode conf False (cprog) (typeInference cprog)
+                                     let transformed = typeChecked
+                                     in checkAndDoBidirectionalize conf False cprog transformed
                                _ | isShapifyMode conf -> 
-                                     print $ outputCode conf False (cprog) (shapify $ typeInference cprog)
-                               _ | isShapifyPlusMode conf -> 
-                                     print $ outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
-                               _ ->
-                                   print $ outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
+                                     let transformed = shapify $ typeChecked
+                                     in checkAndDoBidirectionalize conf False cprog transformed
+                               _ | isShapifyPlusMode conf || True -> 
+                                     let transformed = introNat $ shapify $ typeChecked
+                                     in checkAndDoBidirectionalize conf True cprog transformed 
                      }
           }
+              where checkAndDoBidirectionalize conf isShapify orig ast =
+                        if b18nMode conf == NoB18n || b18nMode conf == SemanticB18n then 
+                            (print $ outputCode conf isShapify orig ast)
+                        else
+                            maybe (print $ outputCode conf isShapify orig ast)
+                                  putStrLn 
+                                  (checkBidirectionalizability ast)