-- $Id: ParseOld.hs,v 1.4 2001/11/09 00:47:50 hallgren Exp $ -- Currently a test harness for the lexer/parser/pretty printer. --ToDo: Are initial values for SrcLoc/current column correct? 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, OperatorEnv) import HsAssocInitEnv 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 stattic 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 ds) = length imp + length ds 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 [] 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 parseFile parse f s of Right mod -> {-rewriteModule initEnv-} mod Left err -> error err 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" 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 -}