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 "(Obsolete) 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 "(Obsolete) 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"(Obsolete) 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 "-no"  (Just "--no-bidrectionalization") empty
  98              (text"No Bidirectionalization (transformation stops after pre-processing)")
  99              (NullaryAction (\conf -> conf {b18nMode = NoB18n})),
 100       Option "-syn" (Just "--syntactic") empty
 101              (text"Syntatic Bidirectionalization.")
 102              (NullaryAction (\conf -> conf {b18nMode = SyntacticB18n, outputMode = OM_NotSpecified  })),
 103       Option "-sem" (Just "--semantic") empty
 104              (text"Semantic Bidirectionalization.")
 105              (NullaryAction (\conf -> conf {b18nMode = SemanticB18n, outputMode = OM_NotSpecified  })),
 106       Option "-comb" (Just "--combined") empty
 107              (text"Combined Bidirectionalization.")
 108              (NullaryAction (\conf -> conf {b18nMode = CombinedB18n, outputMode = OM_NotSpecified })),
 109       Option "-hs"   (Just "--haskell") empty
 110              (text"Output Haskell-runnable code.")
 111              (NullaryAction (\conf -> conf {isHaskellify = True}))
 112 --       Option "-d" (Just "--debug-exec") empty
 113 --              (text"Debug Execution (Do not use this option).")
 114 --              (NullaryAction $ \conf -> conf {execMode = Debug})
 115     ]
 116
 117
 118 matchOption optString options
 119     = foldr f Nothing options
 120     where f o r =
 121               if (optionString o == optString)
 122                  || (isJust (optionLongString o)
 123                      && (fromJust (optionLongString o) == optString)) then
 124                   Just o
 125               else
 126                   r
 127
 128 parseArgs :: [[Char]] -> Config -> Config
 129 parseArgs args conf =
 130     case args of
 131       ("-d":xs) ->
 132           parseArgs xs (conf { execMode = Debug })
 133       ("--debug":xs) ->
 134           parseArgs xs (conf { execMode = Debug })
 135       (x:xs) -> case matchOption x options of
 136                   Just o ->
 137                       case  interpretAction (optionAction o) xs conf of
 138                         Just (rest, c) ->
 139                             parseArgs rest c
 140                         Nothing ->
 141                             error "Error: #Argument of option mismatch."
 142                   Nothing ->
 143                       case x of
 144                         '-':_ ->
 145                             error $ "Error: Unknown option " ++ show x
 146                         _ ->
 147                             if isNothing (inputFile conf) then
 148                                 parseArgs xs (conf { inputFile = Just x })
 149                             else
 150                                 parseArgs xs conf
 151       []     -> conf
 152
 153
 154
 155 -- parseArgs :: [[Char]] -> Config -> Config
 156 -- parseArgs args conf =
 157 --     case args of
 158 --       ("-f":x:xs) ->
 159 --           parseArgs xs (conf { inputFile = Just x })
 160 --       ("-s":xs) ->
 161 --           parseArgs xs (conf { execMode = Shapify })
 162 --       ("-ss":xs) ->
 163 --           parseArgs xs (conf { execMode = ShapifyPlus })
 164 --       ("-h":xs) ->
 165 --           parseArgs xs (conf { execMode = Help })
 166 --       ("-H":xs) ->
 167 --           parseArgs xs (conf { outputMode = HaskellCode, execMode = ShapifyPlus } )
 168 --       ("-P":xs) ->
 169 --           parseArgs xs (conf { outputMode = PseudoCode } )
 170 --       ("-d":xs) ->
 171 --           parseArgs xs (conf { execMode = Debug })
 172 --       (x:xs) | isNothing (inputFile conf) ->
 173 --           parseArgs xs (conf { inputFile = Just x })
 174 --       (x:xs) ->
 175 --           parseArgs xs conf
 176 --       [] ->
 177 --           conf
 178
 179
 180 progName = unsafePerformIO getProgName
 181
 182 usage = show $
 183     text "USAGE" $$
 184     text "-----" $$
 185          nest 4 (text $ progName ++ " (-n|-s) (-T|-U) (-P|-H|-F) [-f] [FILENAME]\n") $+$
 186
 187          text ("This program is a prototype implementation of the paper:\n") $$
 188          nest 4 (sep [text "Janis Voigtlander, Zhenjiang Hu, Kazutaka Matsuda and Meng Wang:",
 189                        text "Combining Syntactic and Semantic Bidirectionalization.",
 190                        text "ICFP 2010.\n"])
 191          $$
 192          wrap 80 ( "Given a \"get\" function defined in a file specified by FILENAME,"
 193                   ++ "the program returns \"put\" function by combining "
 194                   ++ "semantic bidirectionalization (Janis Voiglander: POPL'09) "
 195                   ++ "and syntatic bidirectionalization (Kazutaka Matsuda et al.: ICFP'07). A typical usage is \""++ progName ++ " -H FILENAME\", which correspondes to the paper.\n"
 196                   ) $+$
 197     text "OPTIONS" $$
 198     text "-------" $$
 199          ppr options
 200     where
 201       pprOptions ps = vcat $ concatMap
 202                       (\(a,b) -> [nest 4 a,nest 8 b]) ps
 203       wrap n s = wrap' n s []
 204           where wrap' 0 (' ':s) buf = wrap' 0 s buf
 205                 wrap' 0 s buf  = (text (reverse buf)) $$ wrap' n s []
 206                 wrap' m [] buf = (text (reverse buf))
 207                 wrap' m (' ':s) buf
 208                     | m - lnextSpace s < 0 =
 209                         text (reverse buf) $$ wrap' n s []
 210                     | otherwise =
 211                         wrap' (m-1) s (' ':buf)
 212                 wrap' m (c:s) buf | m > 0 =
 213                     wrap' (m-1) s (c:buf)
 214                 lnextSpace [] = 0
 215                 lnextSpace (' ':_) = 0
 216                 lnextSpace (c:s)   = 1 + lnextSpace s
 217
 218 main :: IO ()
 219 main = do { args <- getArgs
 220           ; let conf = adjustConfig $ parseArgs args defaultConfig
 221           ; case execMode conf of
 222               Help -> putStrLn usage
 223               _ ->
 224                   do { csterr <- case inputFile conf of
 225                                    Nothing ->
 226                                        do cont <- getContents
 227                                           return $ parseString cont
 228                                    Just filename ->
 229                                        parseFile filename
 230                      ; case csterr of
 231                          Left err -> hPutStrLn stderr (show err)
 232                          Right cprog ->
 233                              case execMode conf of
 234                                Normal | (b18nMode conf == SyntacticB18n || b18nMode conf == NoB18n) ->
 235                                    print $
 236                                          outputCode conf False (cprog) (typeInference cprog)
 237 --                                Shapify -> print $
 238 --                                    outputCode conf False (cprog) (shapify $ typeInference cprog)
 239 --                                    -- putStrLn "Not Supported Now."
 240                                ShapifyPlus ->
 241                                    print $
 242                                          outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
 243                                Debug ->
 244                                    do { print $ ppr   $ cprog
 245                                       -- ; print $ pprAM $ constructAutomaton (typeInference cprog) initTAMap
 246                                       ; let (p1,p2,p3) = constructBwdFunction (typeInference cprog)
 247                                       ; print $ ppr p1 $$ ppr p2 $$ ppr p3
 248                                       ; print $ ppr $ constructTypeDecl p2
 249                                       ; print $ ppr $ generateCodeBwd (typeInference cprog, p1,p2,p3)
 250                                       ; putStrLn ""
 251                                       ; putStrLn $ "---- After \"Shapify\" ----"
 252                                       ; let cprog' = introNat $ shapify $ typeInference cprog
 253                                       -- ; print $ pprAM $ constructAutomaton cprog' initTAMap
 254                                       ; print $ cprog'
 255                                       ; let (p1,p2,p3) = constructBwdFunction cprog'
 256                                       ; print $ ppr p1 $$ ppr p2 $$ ppr p3
 257                                       ; putStrLn ""
 258                                       }
 259                                _ ->
 260                                    print $ outputCode conf True  (cprog) (introNat $ shapify $ typeInference cprog)
 261                      }
 262           }
 263