diff --git a/src/Transfer/CompilerAPI.hs b/src/Transfer/CompilerAPI.hs new file mode 100644 index 000000000..e1ef32f62 --- /dev/null +++ b/src/Transfer/CompilerAPI.hs @@ -0,0 +1,72 @@ +module Transfer.CompilerAPI where + +import Transfer.Syntax.Lex +import Transfer.Syntax.Par +import Transfer.Syntax.Print +import Transfer.Syntax.Abs +import Transfer.Syntax.Layout + +import Transfer.ErrM +import Transfer.SyntaxToCore + +import Transfer.PathUtil + +import System.Directory + + +-- | Compile a source module file to a a code file. +compileFile :: [FilePath] -- ^ directories to look for imported modules in + -> FilePath -- ^ source module file + -> IO FilePath -- ^ path to the core file that was written +compileFile path f = do + ds <- loadModule path f + s <- compile ds + writeFile coreFile s + return coreFile + where coreFile = replaceFilenameSuffix f "trc" + +-- | Compile a self-contained list of declarations to a core program. +compile :: Monad m => [Decl] -> m String +compile m = return (printTree $ declsToCore m) + +-- | Load a source module file and all its dependencies. +loadModule :: [FilePath] -- ^ directories to look for imported modules in + -> FilePath -- ^ source module file + -> IO [Decl] +loadModule path f = + do + s <- readFile f + Module is ds <- case pModule (myLLexer s) of + Bad e -> fail $ "Parse error in " ++ f ++ ": " ++ e + Ok m -> return m + let deps = [ i | Import (Ident i) <- is ] + let path' = directoryOf f : path + files <- mapM (findFile path' . (++".tr")) deps + dss <- mapM (loadModule path) files + return $ concat (dss++[ds]) + +myLLexer :: String -> [Token] +myLLexer = resolveLayout True . myLexer + +-- | Find a file in one of the given directories. +-- Fails if the file was not found. +findFile :: [FilePath] -- ^ directories to look in + -> FilePath -- ^ file name to find + -> IO FilePath +findFile path f = + do + mf <- findFileM path f + case mf of + Nothing -> fail $ f ++ " not found in path: " ++ show path + Just f' -> return f' + +-- | Find a file in one of the given directories. +findFileM :: [FilePath] -- ^ directories to look in + -> FilePath -- ^ file name to find + -> IO (Maybe FilePath) +findFileM [] _ = return Nothing +findFileM (p:ps) f = + do + let f' = p ++ "/" ++ f + e <- doesFileExist f' + if e then return (Just f') else findFileM ps f diff --git a/transfer/compile_to_core.hs b/transfer/compile_to_core.hs index 1f9ea746b..b35d906d0 100644 --- a/transfer/compile_to_core.hs +++ b/transfer/compile_to_core.hs @@ -1,52 +1,25 @@ module Main where -import Transfer.Syntax.Lex -import Transfer.Syntax.Par -import Transfer.Syntax.Print -import Transfer.Syntax.Abs -import Transfer.Syntax.Layout - -import Transfer.ErrM -import Transfer.SyntaxToCore - -import Transfer.PathUtil +import Transfer.CompilerAPI +import Data.List (partition, isPrefixOf) import System.Environment import System.Exit import System.IO -import Debug.Trace - -myLLexer = resolveLayout True . myLexer - -compile :: Monad m => [Decl] -> m String -compile m = return (printTree $ declsToCore m) - -loadModule :: FilePath -> IO [Decl] -loadModule f = - do - s <- readFile f - Module is ds <- case pModule (myLLexer s) of - Bad e -> die $ "Parse error in " ++ f ++ ": " ++ e - Ok m -> return m - let dir = directoryOf f - deps = [ replaceFilename f i ++ ".tr" | Import (Ident i) <- is ] - dss <- mapM loadModule deps - return $ concat (ds:dss) - die :: String -> IO a die s = do hPutStrLn stderr s exitFailure -coreFile :: FilePath -> FilePath -coreFile f = replaceFilenameSuffix f "trc" - -compileFile :: FilePath -> IO String -compileFile f = loadModule f >>= compile - main :: IO () -main = do args <- getArgs - case args of - [f] -> compileFile f >>= writeFile (coreFile f) - _ -> die "Usage: compile_to_core " +main = do + args <- getArgs + let (flags,files) = partition ("-" `isPrefixOf`) args + path = [ p | ('-':'i':p) <- flags ] + case files of + [f] -> do + cf <- compileFile path f + putStrLn $ "Wrote " ++ cf + return () + _ -> die "Usage: compile_to_core [-i [-i ... ]] "