Refactor code
[darcs-mirror-sem_syn.git] / Main.hs
1 {-# OPTIONS -XFlexibleInstances #-}
2
3 module Main where
4
5 import Text.PrettyPrint
6 import Control.Monad.State
7 import Control.Monad.Error
8 import Data.List
9 import Data.Maybe (fromJust, isNothing, isJust)
10 import Debug.Trace 
11
12 import Data.Function (on)
13
14 import Data.Map (Map)
15 import qualified Data.Map as Map
16
17 import Data.Set (Set)
18 import qualified Data.Set as Set
19
20 import Data.Graph 
21
22 import Util 
23 import AST
24
25 import Parser
26 import Type
27 import Shapify
28 import CodeGen 
29
30 import SemSyn
31
32 import System.IO
33 import System.Environment
34 import System.IO.Unsafe
35
36 data OptionAction 
37     = NullaryAction (Config -> Config)
38     | UnaryAction   (String -> Config -> Config)
39
40 interpretAction (NullaryAction f) xs c 
41     = Just (xs, f c)
42 interpretAction (UnaryAction f) [] c 
43     = Nothing
44 interpretAction (UnaryAction f) (x:xs) c 
45     = Just (xs, f x c) 
46
47       
48 data Option 
49     = Option { optionString :: String, 
50                optionLongString :: Maybe String,
51                optionArgDescription :: Doc, 
52                optionDescription :: Doc, 
53                optionAction :: OptionAction }
54
55 instance Ppr Option where
56     ppr (Option s ls argdesc desc _) =
57         ppr s <> (case ls of 
58                     Just ls -> comma <+> ppr ls
59                     Nothing -> empty)
60               <+> argdesc  $$
61               nest 4 desc
62     pprList opts =
63         vcat $ (punctuate (text "\n") $ map ppr opts)
64         
65
66 options = 
67     [ Option "-f" (Just "--file") (text "FILENAME")
68              (text "Specify program's input file")
69              (UnaryAction (\x conf -> 
70                                conf { inputFile = Just x })),
71       Option "-s" (Just "--shapify") (empty)
72              (text "Convert terms with type \"T a\" to \"T Unit\".")
73              (NullaryAction (\conf -> conf {execMode = Shapify})),
74       Option "-n" (Just "--natify") empty
75              (text "Convert terms with \"List a\" to \"Nat\".")
76              (NullaryAction (\conf -> conf {execMode = ShapifyPlus})),
77       Option "-h"  (Just "--help") empty
78              (text "Show this help message.")
79              (NullaryAction (\conf -> conf {execMode = Help})),
80       Option "-H"  (Just "--haskell-code") empty
81              (text "Return a Haskell source code of \"put\" function."
82               $$ text "This options implies \"-n\".")
83              (NullaryAction (\conf -> conf {outputMode = HaskellCode, execMode = ShapifyPlus})),
84       Option "-P"  (Just "--pseudo-code") empty
85              (text "Return a pseudo code only after syntatic bidirectionalizatoin."
86               $$ text "Note that \"wrapping\" code for semantic bidirectionalization is not produced.")
87              (NullaryAction (\conf -> conf {outputMode = PseudoCode })),
88       Option "-F"  (Just "--forward-only") empty
89              (text"Return a pseudo code without bidirecionalization.")
90              (NullaryAction (\conf -> conf {outputMode = ForwardCode })), 
91       Option "-U"  (Just "--without-type") empty 
92              (text"Pseudo code without type. This option affects the output of \"-P\" and \"-F\".")
93              (NullaryAction (\conf -> conf {isShowType = False})),
94       Option "-T"  (Just "--with-type") empty 
95              (text"Pseudo code with type. This option affects the output of \"-P\" and \"-F\".")
96              (NullaryAction (\conf -> conf {isShowType = True}))
97 --       Option "-d" (Just "--debug-exec") empty
98 --              (text"Debug Execution (Do not use this option).")
99 --              (NullaryAction $ \conf -> conf {execMode = Debug})
100     ]
101
102       
103 matchOption optString options 
104     = foldr f Nothing options 
105     where f o r = 
106               if (optionString o == optString) 
107                  || (isJust (optionLongString o) 
108                      && (fromJust (optionLongString o) == optString)) then 
109                   Just o 
110               else
111                   r
112            
113 parseArgs :: [[Char]] -> Config -> Config 
114 parseArgs args conf =
115     case args of 
116       ("-d":xs) -> 
117           parseArgs xs (conf { execMode = Debug })
118       ("--debug":xs) -> 
119           parseArgs xs (conf { execMode = Debug })
120       (x:xs) -> case matchOption x options of 
121                   Just o -> 
122                       case  interpretAction (optionAction o) xs conf of 
123                         Just (rest, c) -> 
124                             parseArgs rest c 
125                         Nothing ->
126                             error "Error: #Argument of option mismatch." 
127                   Nothing -> 
128                       case x of 
129                         '-':_ -> 
130                             error $ "Error: Unknown option " ++ show x 
131                         _ -> 
132                             if isNothing (inputFile conf) then 
133                                 parseArgs xs (conf { inputFile = Just x })
134                             else 
135                                 parseArgs xs conf
136       []     -> conf
137
138
139
140 -- parseArgs :: [[Char]] -> Config -> Config 
141 -- parseArgs args conf =
142 --     case args of 
143 --       ("-f":x:xs) ->
144 --           parseArgs xs (conf { inputFile = Just x })
145 --       ("-s":xs) ->
146 --           parseArgs xs (conf { execMode = Shapify })
147 --       ("-ss":xs) ->
148 --           parseArgs xs (conf { execMode = ShapifyPlus })
149 --       ("-h":xs) ->
150 --           parseArgs xs (conf { execMode = Help })
151 --       ("-H":xs) ->
152 --           parseArgs xs (conf { outputMode = HaskellCode, execMode = ShapifyPlus } )
153 --       ("-P":xs) ->
154 --           parseArgs xs (conf { outputMode = PseudoCode } )
155 --       ("-d":xs) ->
156 --           parseArgs xs (conf { execMode = Debug })
157 --       (x:xs) | isNothing (inputFile conf) ->
158 --           parseArgs xs (conf { inputFile = Just x })
159 --       (x:xs) ->
160 --           parseArgs xs conf
161 --       [] ->
162 --           conf
163
164
165 progName = unsafePerformIO getProgName
166
167 usage = show $ 
168     text "USAGE" $$
169     text "-----" $$
170          nest 4 (text $ progName ++ " (-n|-s) (-T|-U) (-P|-H|-F) [-f] [FILENAME]\n") $+$ 
171                   
172          text ("This program is a prototype implementation of the paper:\n") $$
173          nest 4 (sep [text "Janis Voigtlander, Zhenjiang Hu, Kazutaka Matsuda and Meng Wang:",
174                        text "Combining Syntactic and Semantic Bidirectionalization.",
175                        text "ICFP 2010.\n"])
176          $$
177          wrap 80 ( "Given a \"get\" function defined in a file specified by FILENAME,"
178                   ++ "the program returns \"put\" function by combining "
179                   ++ "semantic bidirectionalization (Janis Voiglander: POPL'09) "
180                   ++ "and syntatic bidirectionalization (Kazutaka Matsuda et al.: ICFP'07). A typical usage is \""++ progName ++ " -H FILENAME\", which correspondes to the paper.\n"
181                   ) $+$
182     text "OPTIONS" $$
183     text "-------" $$
184          ppr options
185     where
186       pprOptions ps = vcat $ concatMap 
187                       (\(a,b) -> [nest 4 a,nest 8 b]) ps 
188       wrap n s = wrap' n s [] 
189           where wrap' 0 (' ':s) buf = wrap' 0 s buf 
190                 wrap' 0 s buf  = (text (reverse buf)) $$ wrap' n s []
191                 wrap' m [] buf = (text (reverse buf))
192                 wrap' m (' ':s) buf  
193                     | m - lnextSpace s < 0 =
194                         text (reverse buf) $$ wrap' n s []
195                     | otherwise = 
196                         wrap' (m-1) s (' ':buf)
197                 wrap' m (c:s) buf | m > 0 =
198                     wrap' (m-1) s (c:buf)
199                 lnextSpace [] = 0
200                 lnextSpace (' ':_) = 0
201                 lnextSpace (c:s)   = 1 + lnextSpace s 
202
203 main :: IO ()
204 main = do { args <- getArgs 
205           ; let conf = parseArgs args defaultConfig
206           ; case execMode conf of 
207               Help -> putStrLn usage 
208               _ -> 
209                   do { csterr <- case inputFile conf of
210                                    Nothing -> 
211                                        do cont <- getContents
212                                           return $ parseString cont
213                                    Just filename ->
214                                        parseFile filename
215                      ; case csterr of
216                          Left err -> hPutStrLn stderr (show err)
217                          Right cprog -> 
218                              case execMode conf of 
219                                Normal -> print $
220                                    outputCode conf False (cprog) (typeInference cprog)
221                                Shapify -> print $
222                                    outputCode conf False (cprog) (shapify $ typeInference cprog)
223                                    -- putStrLn "Not Supported Now."
224                                ShapifyPlus -> print $
225                                    outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
226                                Debug ->
227                                    do { print $ ppr   $ cprog
228                                       -- ; print $ pprAM $ constructAutomaton (typeInference cprog) initTAMap
229                                       ; let (p1,p2,p3) = constructBwdFunction (typeInference cprog)
230                                       ; print $ ppr p1 $$ ppr p2 $$ ppr p3
231                                       ; print $ ppr $ constructTypeDecl p2 
232                                       ; print $ ppr $ generateCodeBwd (typeInference cprog, p1,p2,p3)
233                                       ; putStrLn ""
234                                       ; putStrLn $ "---- After \"Shapify\" ----" 
235                                       ; let cprog' = introNat $ shapify $ typeInference cprog 
236                                       -- ; print $ pprAM $ constructAutomaton cprog' initTAMap
237                                       ; print $ cprog'                                       
238                                       ; let (p1,p2,p3) = constructBwdFunction cprog' 
239                                       ; print $ ppr p1 $$ ppr p2 $$ ppr p3
240                                       ; putStrLn ""
241                                       }
242                      }
243           }
244