-- -- Copyright (C) 2005 Stefan Wehr - http://www.stefanwehr.de -- -- This program is free software; you can redistribute it and/or -- modify it under the terms of the GNU General Public License as -- published by the Free Software Foundation; either version 2 of -- the License, or (at your option) any later version. -- -- This program is distributed in the hope that it will be useful, -- but WITHOUT ANY WARRANTY; without even the implied warranty of -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -- General Public License for more details. -- -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software -- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA -- 02111-1307, USA. -- -- This module allows PHRaC to be controlled from within another program. module Phrac.Driver ( startFromSrc, -- starts compilation from source code startFromAST, -- starts compilation directly from an AST srcToAST, -- transforms a piece of source code into an AST Flag(..), Phase(..) -- configuration flags ) where import List ( find ) import Maybe ( isJust ) import Control.Exception ( catchDyn, evaluate ) import Control.Monad ( when ) import System.IO ( hFlush, stdin, stdout, stderr, hPutStrLn, hGetContents ) import System.Exit ( exitWith, ExitCode(..) ) import Phrac.Lexer import Phrac.Parser import Phrac.SyntaxTransformation import qualified Phrac.WellFormedness as WF import Phrac.Error import Phrac.Pretty import Phrac.Symtab import Phrac.KindInference import Phrac.TypeInference import Phrac.Configuration import qualified Phrac.ParseSyntax as PS import qualified Phrac.AbstractSyntax as AS import Phrac.PhracPrelude import Phrac.Overloading import Phrac.Interpreter import Phrac.Constants srcToAST :: [Flag] -- configuration flags -> String -- source code -> IO (Either String -- error message PS.Program) -- the AST startFromSrc :: [Flag] -- configuration flags -> Maybe FilePath -- source code is read from stdin if no path given -> IO (Either String -- error message AS.Program) -- the final program -- (that was passed to the interpreter) startFromAST :: [Flag] -- configuration flags -> PS.Program -- the AST -> IO (Either String -- error message AS.Program) -- the final program -- (that was passed to the interpreter) data Flag = Version | DebugLevel DebugLevel | Help | Dump Phase | ExitAfterDump | NoLocation | TerminationCondition TerminationCondition | DontRun | NoPrelude deriving Eq data Phase = Lex | Parse | RawParse | AST | RawAST | KindInfer | TypeInfer | OverReso deriving Eq -- -- the dirty source code ... -- getSrcFromStdin = do putStrLn ("reading from stdin, finish program with a line containing " ++ "only EOF") read [] where read acc = do l <- getLine if l == "EOF" then return $ unlines (reverse acc) else read (l : acc) dump' :: Pretty p => [Flag] -> p -> IO () dump' fs p = let s = showPpr p in if not (null s) then do hPutStrLn stdout (showPpr p) if ExitAfterDump `elem` fs then exitWith ExitSuccess else return () else return () myCatch :: [Flag] -> IO a -> IO (Either String a) myCatch flags io = catchDyn (io >>= \p -> return $ Right p) handler where handler dyn = do let msg = if (NoLocation `elem` flags) then showWithoutLocation (dyn :: PException) else show (dyn :: PException) return $ Left msg srcToAST flags src = do let on = \x -> elem x flags dump p = dump' flags p case debugLevel flags of Nothing -> return () Just l -> enableDebug l myCatch flags $ do -- lexer display "\n ==> LEXING <==\n" tokens <- evaluate $ scan src when (on $ Dump Lex) $ dump (text $ show tokens) -- parser display "\n ==> PARSING <==\n" parseSyntax <- evaluate (parse tokens) when (on $ Dump Parse) $ dump (ppr parseSyntax) when (on $ Dump RawParse) $ dump (text $ show parseSyntax) return parseSyntax startFromSrc flags file = do src <- case file of Nothing -> getSrcFromStdin Just f -> readFile f res <- srcToAST flags src case res of Left err -> return $ Left err Right ast -> startFromAST flags ast startFromAST flags parseSyntax = do let on = \x -> elem x flags dump p = dump' flags p case debugLevel flags of Nothing -> return () Just l -> enableDebug l myCatch flags $ do parseSyntax' <- addBuiltins (if on NoPrelude then NoImplicitPrelude else ImplicitPrelude) parseSyntax -- syntax transformation display "\n ==> SYNTAX TRANSFORMATION <==\n" wholeProg <- transform parseSyntax' let (_, ast) = AS.splitProgram wholeProg when (on $ Dump AST) $ dump (ppr ast) when (on $ Dump RawAST) $ dump (text $ show ast) symtab <- buildSymtab wholeProg runST symtab $ do case terminationCondition flags of Nothing -> return () Just t -> modifyConfiguration (\c -> c { typeSynonymTermination = t }) let (bast, ast) = AS.splitProgram wholeProg display "\n ==> WELL-FORMEDNESS 1 <==\n" WF.check wholeProg display "\n ==> KIND INFERENCE <==\n" kindInference wholeProg when (on $ Dump KindInfer) $ do kiDump <- dumpKindInference ast liftIO $ dump $ (ppr ast) $$ kiDump display "\n ==> WELL-FORMEDNESS 2 <==\n" WF.checkAfterKindInference wholeProg display "\n ==> TYPE INFERENCE <==\n" (as, bast') <- tiMain emptyAssumps bast -- start numbering type variables and type constructors from -- scratch after typing the builtins. This prevents tests from -- breaking when something is added to the prelude. setFreshVarsPrefix "v" "C" "d" (as', ast') <- tiMain as ast let wholeProg' = AS.mergeProgram bast' ast' when (on $ Dump TypeInfer) $ do liftIO $ dump (dumpTypeInference as' ast) installInstanceDictionaries (AS.prog_instances bast' ++ AS.prog_instances ast') when (on $ Dump OverReso) $ do let isBuiltin ((cid, ts), _) = isJust (find (\ci -> AS.inst_class ci == cid && AS.inst_types ci == ts) (AS.prog_instances bast')) dictExprs <- getDictionaryExpressions liftIO $ dump (dumpDictExprs (filter (not . isBuiltin) dictExprs) $$ (vcat $ map ppr (AS.prog_bindings ast'))) when (not $ on DontRun) $ do val <- evalProgram wholeProg' liftIO $ putStrLn (showPpr val) return wholeProg' debugLevel :: [Flag] -> Maybe DebugLevel debugLevel [] = Nothing debugLevel (DebugLevel l:_) = Just l debugLevel (_:rest) = debugLevel rest terminationCondition :: [Flag] -> Maybe TerminationCondition terminationCondition [] = Nothing terminationCondition (TerminationCondition t:_) = Just t terminationCondition (_:rest) = terminationCondition rest