content: -- $Id: Main.hs,v 1.45 2001/07/30 05:07:23 hallgren Exp $
  
  -- Currently a test harness for the lexer/parser/pretty printer.
  
  --ToDo: Are initial values for SrcLoc/current column correct?
  
  module Main (testLexer, main) where
  
  import IO
  import Monad
  import Lexer
  import ParseMonad
  import HsParser
  import ParseUtil
  import Syntax
  import PrettyPrint
  import System
  import GetOpt
  import IOExts
  import List
  import Rewrite(rewriteModule)
  import HsAssoc(initEnv)
  import TypeCheckTest 
  import InferenceMonad
  import Components
  import Scope as SS
  import qualified Scope2 as S2
  import SCC
  import ExampleScope(testD)
  
  
  data Flag = LexOnlyLength          -- print number of tokens only
            | LexOnlyRev             -- print tokens in reverse order
            | LexOnly                -- print tokens
            | ParseLength            -- print number of declarations only
            | ParseInternal          -- print abstract syntax in internal format
            | ParsePretty PPLayout   -- pretty print in this style
            | TestStatic             -- test static checker
            | TestTypeCheck
            | ShowNames
            | Help                   -- give short usage info
            | BindingGroupTest
  
  
  usage = "usage: hsparser [option] [filename]"
  
  options =
     [ Option ['n']  ["numtokens"] (NoArg LexOnlyLength)
           "print number of tokens only",
       Option ['r']  ["revtokens"] (NoArg LexOnlyRev)
           "print tokens in reverse order",
       Option ['t']  ["tokens"]    (NoArg LexOnly)
           "print tokens",
       Option ['d']  ["numdecls"]  (NoArg ParseLength)
           "print number of declarations only",
       Option ['a']  ["abstract"]  (NoArg ParseInternal)
           "print abstract syntax in internal format",
       Option ['p']  ["pretty"]    (OptArg style "STYLE")
           "pretty print in STYLE[(o)ffside|(s)emicolon|(u)trecht|(i)nline|\
            \(n)one] (default = offside)",
       Option ['h','?'] ["help"]   (NoArg Help)
           "display this help and exit",
       Option ['s'] ["static"]     (NoArg TestStatic) 
           "run static checker",
       Option ['c'] ["typecheck"]  (NoArg TestTypeCheck)
           "run typechecker",
       Option ['m'] ["names"]      (NoArg ShowNames)
           "show all defined names",
       Option ['b'] ["groups"]     (NoArg BindingGroupTest)
           "show binding groups"
     ]
  
  style :: Maybe String -> Flag
  style Nothing  = ParsePretty PPOffsideRule
  style (Just s) = ParsePretty $
           case s of
           "o"         -> PPOffsideRule
           "offside"   -> PPOffsideRule
           "s"         -> PPSemiColon
           "semicolon" -> PPSemiColon
           "u"         -> PPUtrecht
           "utrecht"   -> PPUtrecht
           "i"         -> PPInLine
           "inline"    -> PPInLine
           "n"         -> PPNoLayout
           "none"      -> PPNoLayout
           _           -> PPOffsideRule
  
  main :: IO ()
  main = do cmdline <- getArgs
            mainHugs cmdline
  
  mainHugs :: [String] -> IO ()
  mainHugs cmdline =
     case getOpt Permute options cmdline of
        (flags, args, [])    ->
         do (file, inp) <- case args of
               []  -> do inp <- getContents
                         return ("stdio", inp)
               [f] -> do inp <- readFile f
                         return (f, inp)
               _   -> error usage
            putStrLn (handleFlag (getFlag flags) file inp)
        (    _,   _, errors) ->
          error (concat errors ++ usageInfo usage options)
  
  getFlag :: [Flag] -> Flag
  getFlag []  = ParsePretty PPOffsideRule
  getFlag [f] = f
  getFlag _   = error usage
  
  handleFlag :: Flag -> FilePath -> String -> String
  handleFlag LexOnlyLength    f = show . numToks . testLexerRev f
  handleFlag LexOnlyRev       f = show . testLexerRev f
  handleFlag LexOnly          f = show . testLexer f
  handleFlag ShowNames        f = show . getAllNames . testParser f
  handleFlag ParseLength      f = show . allLengths . testParser f
     where allLengths (HsModule _ _ imp d) =
              length imp + length d
  handleFlag ParseInternal    f = show . testParser f
  handleFlag TestStatic       f = \s -> 
      unsafePerformIO $ 
      do { r <- testStatic $ testParser f s ;
           return "Done static checking." }
  handleFlag TestTypeCheck    f = \s -> 
      unsafePerformIO $ 
      do  { let { m = testParser f s } ;
            r <- testStatic m ;
            print $ (typeCheckDecls . (\ (HsModule _ _ _ ds) -> ds)) m;
            return "Done static checking." }
  handleFlag (ParsePretty lo) f
      = renderWithMode mode . ppi . testParser f
        where mode = defaultMode { layoutType = lo }
  
  handleFlag BindingGroupTest f = \s -> 
            unsafePerformIO (return groups >>= \s ->  return " Done b.g. ")
  
  
  handleFlag Help   f
      = const $
        usageInfo
            ("A simple test program for *The Haskell Parser*" ++ usage)       options
  
  
  numToks :: ParseResult () [Token] -> Int
  numToks (Ok _ toks)  = length toks
  numToks (Failed err) = error ("Huh? " ++ err)
  
  testLexerRev :: FilePath -> String -> ParseResult () [Token]
  testLexerRev f s =
      (unPM $ loop []) s (SrcLoc f 1 0) 1 (error "Initial environment", []) 
      where loop toks =
             lexer (\t -> case t of 
                             EOF -> returnPM toks
                             _   -> loop (t:toks))
  
  testLexer :: FilePath -> String -> ParseResult () [Token]
  testLexer f s = (unPM $ loop []) s  (SrcLoc f 1 0) 1 ((), [])
    where loop toks =
           lexer (\t -> case t of 
                EOF -> returnPM (reverse toks) -- space leak?
                _   -> loop (t:toks))
  
  testParser :: FilePath -> String -> HsModuleR
  testParser f s =
      case (unPM parse) s  (SrcLoc f 1 1) 0 ((), []) of
        Ok state mod -> rewriteModule initEnv mod
        Failed err -> error err
  
  testStatic :: HsModuleR -> IO ()
  testStatic (HsModule _ _ imp ds) = SS.test ds
  
  
  start s = liftM (testParser s) (readFile s)
  {-
  start s = do contents <- readFile s
               return $ testParser s contents
  -}
  
  look s = unsafePerformIO $ start s
  
  myTestTypeCheck f s =
      do { let { m = testParser f s } ;
       r <- testStatic m ;
           return $ (typeCheckDs . (\ (HsModule _ _ _ ds) -> ds)) m
         } 
  
  
  
  t22 x =
      unsafePerformIO $
      do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \
            \on a single line\n" ;
       ls <- getLines [] ;
       myTestTypeCheck "Stdio" ls
         }
  
  t34 x = 
      unsafePerformIO $ 
      do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \
            \on a single line\n"
         ; text <- getLines []
         ; z @ (v, text, _) <- myTestTypeCheck "Stdio" text
         ; putStrLn "\n\n OUTPUT: \n"
         ; putStrLn text
         ; return v
         }
  
  testFreeV = 
      unsafePerformIO $
      do { putStrLn "\nEnter Haskell declarations.  Terminate with :q \
            \on a single line\n"
         ; text <- getLines []
         ; let HsModule _ _ _ ds = testParser "Stdio" text
         ; let (a, b, c) = tfv (SS.freeD ds, map (\x -> SS.freeD [x]) ds)
         ; print ( (map zap  a), map zap b)
         }
  
  tfv ((f1, f2), ds) = (f1 [], f2 [], map (\ (f1, f2) -> (f1 [], f2 [])) ds)
  
  zap (UnQual x) = x
  
  {-
  go () = 
       let (a,b,c) = tfv(testFreeV ())
           h (x,y) = (map zap x, map zap y)
       in (map zap a, map zap b, map h c)
  -}
  
  getLines c = 
      do { l <- getLine
         ; if l == ":q" 
             then return c
             else getLines (c ++ "\n" ++ l)
         }
  
  z = testGeneral "test2.hs" SCC.tim
  
  testGeneral fname f  = 
      do { text <- readFile fname
         ; let HsModule _ _ _ ds = testParser fname text
         ; return $ f ds 
         }
            
  w = do { testGeneral "test3.hs" SS.test
         ; testGeneral "test3.hs" performTC
         } >>= id
  
  dfree = (testGeneral "test3.hs" (\ ds -> SS.makeSCC ds [])) >>= print
  
  d2 = (testGeneral "test3.hs" (map (\ d -> ff [] d []))) >>= print
  
  {- testD doesn't appear in Scope2 (imported qualified as S2) ...
  d3 =  (testGeneral "test3.hs" (map (\ d -> S2.testD [d]))) >>= print
  
  d4 =  (testGeneral "test3.hs" S2.testD) >>= print
  -}
  
  
  HsModule _ _ _ ds = unsafePerformIO (start "test3.hs")
  
  
  Dec(HsDataDecl _ cs1 tp1 t1 _) = ds !! 0
  Dec(HsDataDecl _ cs2 tp2 t2 _) = ds !! 1
  Dec(HsTypeDecl _ tp3 t3) = ds !! 2
  
  
  fr xs y = let (bound,freef1) = SS.scopPatList [] (map SS.freeTP xs)
         in (bound ,SS.freeT y bound)
  
  
  groups fname = 
      do { (bg,cyclic) <- testGeneral fname SCC.bindingGroups
         ; mapM_ (\ x -> do { putStrLn (pp x)
                ; putStrLn "-----------------"
                })
             bg
         }
  
  -----------------------------------------------------------------
  -- testing the free variable analysis
  
  HsModule _ _ _ freeds = unsafePerformIO (start "tests/freeVartests.hs")
  
  test1 d = testD [d]
  freetest _ = map test1 freeds
  
  d5 = freeds !! 4
  