-- $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