Support new "userlevel" options.
authorKazutaka Matsuda <kztk@kb.ecei.tohoku.ac.jp>
Fri, 10 Sep 2010 09:16:13 +0000 (09:16 +0000)
committerKazutaka Matsuda <kztk@kb.ecei.tohoku.ac.jp>
Fri, 10 Sep 2010 09:16:13 +0000 (09:16 +0000)
CodeGen.hs
Main.hs
Makefile
SemSyn.hs

index 88089c9..4a549bf 100644 (file)
@@ -11,6 +11,10 @@ import Data.List (groupBy)
 import AST
 import Util
 
+generateCodeDet :: AST -> [ TH.Dec ] 
+generateCodeDet = convCmpl
+
+
 generateCodeBwd :: (AST, AST, AST, TAST) -> [ TH.Dec ]
 generateCodeBwd (orig, bwd, cmpl, tinv) = 
     convCmpl orig ++ convBWD bwd ++ convCmpl cmpl ++ convNDet tinv 
diff --git a/Main.hs b/Main.hs
index b0717f6..3ece191 100644 (file)
--- a/Main.hs
+++ b/Main.hs
@@ -68,9 +68,9 @@ options =
              (text "Specify program's input file")
              (UnaryAction (\x conf -> 
                                conf { inputFile = Just x })),
-      Option "-s" (Just "--shapify") (empty)
-             (text "Convert terms with type \"T a\" to \"T Unit\".")
-             (NullaryAction (\conf -> conf {execMode = Shapify})),
+--       Option "-s" (Just "--shapify") (empty)
+--              (text "Convert terms with type \"T a\" to \"T Unit\".")
+--              (NullaryAction (\conf -> conf {execMode = Shapify})),
       Option "-n" (Just "--natify") empty
              (text "Convert terms with \"List a\" to \"Nat\".")
              (NullaryAction (\conf -> conf {execMode = ShapifyPlus})),
@@ -78,22 +78,37 @@ options =
              (text "Show this help message.")
              (NullaryAction (\conf -> conf {execMode = Help})),
       Option "-H"  (Just "--haskell-code") empty
-             (text "Return a Haskell source code of \"put\" function."
+             (text "(Obsolete) Return a Haskell source code of \"put\" function."
               $$ text "This options implies \"-n\".")
              (NullaryAction (\conf -> conf {outputMode = HaskellCode, execMode = ShapifyPlus})),
       Option "-P"  (Just "--pseudo-code") empty
-             (text "Return a pseudo code only after syntatic bidirectionalizatoin."
+             (text "(Obsolete) Return a pseudo code only after syntatic bidirectionalizatoin."
               $$ text "Note that \"wrapping\" code for semantic bidirectionalization is not produced.")
              (NullaryAction (\conf -> conf {outputMode = PseudoCode })),
       Option "-F"  (Just "--forward-only") empty
-             (text"Return a pseudo code without bidirecionalization.")
+             (text"(Obsolete) Return a pseudo code without bidirecionalization.")
              (NullaryAction (\conf -> conf {outputMode = ForwardCode })), 
       Option "-U"  (Just "--without-type") empty 
              (text"Pseudo code without type. This option affects the output of \"-P\" and \"-F\".")
              (NullaryAction (\conf -> conf {isShowType = False})),
       Option "-T"  (Just "--with-type") empty 
              (text"Pseudo code with type. This option affects the output of \"-P\" and \"-F\".")
-             (NullaryAction (\conf -> conf {isShowType = True}))
+             (NullaryAction (\conf -> conf {isShowType = True})),
+      Option "-no"  (Just "--no-bidrectionalization") empty
+             (text"No Bidirectionalization (transformation stops after pre-processing)")
+             (NullaryAction (\conf -> conf {b18nMode = NoB18n})),
+      Option "-syn" (Just "--syntactic") empty 
+             (text"Syntatic Bidirectionalization.")
+             (NullaryAction (\conf -> conf {b18nMode = SyntacticB18n, outputMode = OM_NotSpecified  })),
+      Option "-sem" (Just "--semantic") empty 
+             (text"Semantic Bidirectionalization.")
+             (NullaryAction (\conf -> conf {b18nMode = SemanticB18n, outputMode = OM_NotSpecified  })),
+      Option "-comb" (Just "--combined") empty
+             (text"Combined Bidirectionalization.")
+             (NullaryAction (\conf -> conf {b18nMode = CombinedB18n, outputMode = OM_NotSpecified })),
+      Option "-hs"   (Just "--haskell") empty
+             (text"Output Haskell-runnable code.")
+             (NullaryAction (\conf -> conf {isHaskellify = True}))
 --       Option "-d" (Just "--debug-exec") empty
 --              (text"Debug Execution (Do not use this option).")
 --              (NullaryAction $ \conf -> conf {execMode = Debug})
@@ -111,7 +126,7 @@ matchOption optString options
                   r
            
 parseArgs :: [[Char]] -> Config -> Config 
-parseArgs args conf =
+parseArgs args conf = 
     case args of 
       ("-d":xs) -> 
           parseArgs xs (conf { execMode = Debug })
@@ -202,7 +217,7 @@ usage = show $
 
 main :: IO ()
 main = do { args <- getArgs 
-          ; let conf = parseArgs args defaultConfig
+          ; let conf = adjustConfig $ parseArgs args defaultConfig
           ; case execMode conf of 
               Help -> putStrLn usage 
               _ -> 
@@ -216,13 +231,15 @@ main = do { args <- getArgs
                          Left err -> hPutStrLn stderr (show err)
                          Right cprog -> 
                              case execMode conf of 
-                               Normal -> print $
-                                   outputCode conf False (cprog) (typeInference cprog)
-                               Shapify -> print $
-                                   outputCode conf False (cprog) (shapify $ typeInference cprog)
-                                   -- putStrLn "Not Supported Now."
-                               ShapifyPlus -> print $
-                                   outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
+                               Normal | (b18nMode conf == SyntacticB18n || b18nMode conf == NoB18n) -> 
+                                   print $
+                                         outputCode conf False (cprog) (typeInference cprog)
+--                                Shapify -> print $
+--                                    outputCode conf False (cprog) (shapify $ typeInference cprog)
+--                                    -- putStrLn "Not Supported Now."
+                               ShapifyPlus -> 
+                                   print $
+                                         outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
                                Debug ->
                                    do { print $ ppr   $ cprog
                                       -- ; print $ pprAM $ constructAutomaton (typeInference cprog) initTAMap
@@ -239,6 +256,8 @@ main = do { args <- getArgs
                                       ; print $ ppr p1 $$ ppr p2 $$ ppr p3
                                       ; putStrLn ""
                                       }
+                               _ ->
+                                   print $ outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
                      }
           }
 
index 39626cb..e905ebe 100644 (file)
--- a/Makefile
+++ b/Makefile
@@ -6,6 +6,6 @@ $(TARGET): Main.hs AST.hs Parser.hs Util.hs Type.hs Shapify.hs CodeGen.hs
        ghc --make -o $(TARGET) Main.hs
 
 clean:
-       rm $(TARGET)
+       rm -rf $(TARGET)
        rm -rf *.o *.hi
-       rm *~
\ No newline at end of file
+       rm -rf *~
index 1810dc1..e1d05b5 100644 (file)
--- a/SemSyn.hs
+++ b/SemSyn.hs
@@ -32,50 +32,120 @@ data Config
     = Config 
       { 
         inputFile   :: Maybe String, -- ^ Path to input file
-        execMode    :: ExecMode,
-        outputMode  :: OutputMode, 
+        execMode    :: ExecMode,  
+        b18nMode    :: B18nMode, 
+        outputMode  :: OutputMode,   -- ^ Obsolete   
+        isHaskellify :: Bool, 
         isShowType  :: Bool
       }
+    deriving Show 
 
 data ExecMode 
     = Normal | Shapify | ShapifyPlus | Help | Debug 
     deriving (Eq, Read, Show)
 
-data OutputMode = PseudoCode | HaskellCode | ForwardCode
+data OutputMode = PseudoCode | HaskellCode | ForwardCode | OM_NotSpecified 
+    deriving (Eq, Read, Show)
+
+data B18nMode = SyntacticB18n | SemanticB18n | CombinedB18n | NoB18n 
     deriving (Eq, Read, Show)
 
 defaultConfig = Config { 
-                  inputFile   = Nothing, 
-                  execMode    = Normal, 
-                  outputMode  = HaskellCode,
-                  isShowType  = True  }
+                  inputFile    = Nothing, 
+                  execMode     = Normal, 
+                  b18nMode     = CombinedB18n, 
+                  outputMode   = OM_NotSpecified, 
+                  isHaskellify = False, 
+                  isShowType   = True  }
+
+-- | Since some combination of the config options is useless, 
+--   this function adjust some configuration to valid one.
+adjustConfig :: Config -> Config 
+-- adjustConfig (conf@(Config {b18nMode = CombinedB18n})) =
+--     conf { isHaskellify = True, execMode = ShapifyPlus }
+-- adjustConfig (conf@(Config {b18nMode = SemanticB18n})) =
+--     conf { isHaskellify = True, execMode = Normal, outputMode = ForwardCode }
+-- adjustConfig (conf@(Config {b18nMode = SyntacticB18n})) =
+--     conf { execMode = Normal, outputMode = PseudoCode }
+adjustConfig (conf@(Config {outputMode = ForwardCode})) = 
+    conf { b18nMode = NoB18n }
+adjustConfig (conf@(Config {outputMode = HaskellCode})) | execMode conf /= Help = 
+    conf { execMode = ShapifyPlus, isHaskellify = True, b18nMode = CombinedB18n  }
+adjustConfig (conf@(Config {outputMode = PseudoCode})) =
+    conf { isHaskellify = False, b18nMode = SyntacticB18n }
+adjustConfig conf = conf 
+
+
 
 outputCode :: Config -> Bool -> AST -> AST -> Doc
-outputCode conf isShapify orig ast =
+outputCode conf_ isShapify orig ast = 
     let (p1,p2,p3) = constructBwdFunction ast
-    in case outputMode conf of 
-         ForwardCode ->
-                  ppr (typeFilter ast)
-         PseudoCode  -> vcat
-                [ ppr (constructTypeDecl p2)
-                , ppr orig $$ ppr (typeFilter p1) $$ ppr (typeFilter p2) $$ ppr (typeFilterT p3)
-                ]
-         HaskellCode -> vcat $
-                [ text "import Control.Monad"
-                , text "import BUtil"
-                ] ++ (
-                if isShapify
-                then map genBwdDef $
-                        let AST decls = typeInference orig
-                        in map (\(Decl f t _ _:_) -> (f,t)) $ groupBy isSameFunc decls
-                else []                                     
-                ) ++
-                [ ppr (constructTypeDecl p2)
-                , ppr $ generateCodeBwd (orig,p1,p2,p3)
-                ]
+    in case b18nMode conf of 
+         NoB18n -> 
+             if isHaskellify conf then 
+                 ppr (generateCodeDet ast) 
+             else
+                 ppr (typeFilter ast)
+         SyntacticB18n ->
+             if isHaskellify conf then 
+                 vcat [ text "import Control.Monad" 
+                      , ppr (constructTypeDecl p2)
+                      , ppr $ generateCodeBwd (orig, p1, p2, p3) ]
+             else 
+                 vcat [ ppr (constructTypeDecl p2)
+                      , ppr orig $$ ppr (typeFilter p1) $$ ppr (typeFilter p2) $$ ppr (typeFilterT p3) ]
+         SemanticB18n -> vcat $ 
+             [ text "import Data.Bff" ] ++
+             [ text "import BUtil" ] ++ 
+             (map genBwdDefBff $ 
+                   let AST decls = typeInference orig 
+                   in map (\(Decl f t _ _:_) -> f) $ groupBy isSameFunc decls) ++
+             [ ppr $ generateCodeDet p1 ]             
+         CombinedB18n -> vcat $ 
+             [ text "import Control.Monad"
+             , text "import BUtil"
+             ] ++ (
+             if isShapify
+             then map genBwdDef $
+                     let AST decls = typeInference orig
+                     in map (\(Decl f t _ _:_) -> (f,t)) $ groupBy isSameFunc decls
+             else []                                     
+             ) ++
+             [ ppr (constructTypeDecl p2)
+             , ppr $ generateCodeBwd (orig,p1,p2,p3)
+             ]
+                             
+-- case outputMode conf of 
+--          ForwardCode ->
+--                   ppr (typeFilter ast)
+--          PseudoCode  -> vcat
+--                 [ ppr (constructTypeDecl p2)
+--                 , ppr orig $$ ppr (typeFilter p1) $$ ppr (typeFilter p2) $$ ppr (typeFilterT p3)
+--                 ]
+--          HaskellCode -> vcat $
+--                 [ text "import Control.Monad"
+--                 , text "import BUtil"
+--                 ] ++ (
+--                 if isShapify
+--                 then map genBwdDef $
+--                         let AST decls = typeInference orig
+--                         in map (\(Decl f t _ _:_) -> (f,t)) $ groupBy isSameFunc decls
+--                 else []                                     
+--                 ) ++
+--                 [ ppr (constructTypeDecl p2)
+--                 , ppr $ generateCodeBwd (orig,p1,p2,p3)
+--                 ]
     where
+      conf       = adjustConfig conf_
       typeFilter  = if isShowType conf then id else eraseType
       typeFilterT = if isShowType conf then id else eraseTypeT
+      genBwdDefBff (Name fName) =
+          ppr (Name fName) <> text "_B" $$
+              nest 4 (text "= bff " <> ppr (Name fName)) $$
+          ppr (Name fName) <> text "_B_Eq" $$
+              nest 4 (text "= bff_Eq " <> ppr (Name fName)) $$
+          ppr (Name fName) <> text "_B_Ord" $$
+              nest 4 (text "= bff_Ord " <> ppr (Name fName))  
       genBwdDef (Name fName,(TFun is ts t)) =
           case (ts,t) of 
             ([TCon (Name "List") [TVar i]],TCon (Name "List") [TVar j]) | i == j  ->