diff --git a/src/Comments.hs b/src/Comments.hs new file mode 100644 --- /dev/null +++ b/src/Comments.hs @@ -0,0 +1,23 @@ +module Comments where + +type Comment = (Int,String) + +mixComments :: [Comment] -> [(Int,String)] -> [String] +mixComments c [] = map (showComment.lines) (map snd c) +mixComments [] i = map snd i +mixComments c@((cl,cc):cs) i@((il,ic):is) + | cl <= il = showComment (lines cc):mixComments cs i + | otherwise = ic:mixComments c is + +showComment :: [String] -> String +showComment [x] = '-':'-':' ':x +showComment c = "{- " ++ unlines c ++ " -}" + +-- FIXME! +parseComments :: String -> [Comment] +parseComments input = parseComments' (lines input) 1 + +parseComments' :: [String] -> Int -> [Comment] +parseComments' [] _ = [] +parseComments' (('-':'-':c):xs) l = (l,c):parseComments' xs (l+1) +parseComments' (_:xs) l = parseComments' xs (l+1) diff --git a/src/Setup.hs b/src/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Setup.hs @@ -0,0 +1,114 @@ +module Setup where + +import System.Console.GetOpt ( ArgDescr (..), OptDescr (..), usageInfo, getOpt', ArgOrder (..) ) +import System.Environment ( getProgName ) +import System.Exit ( exitWith, ExitCode (..) ) +import System.Directory ( findExecutable ) +import Data.Maybe ( fromMaybe ) + +data ConfigFlags + = ConfigFlags + { configGHCPath :: FilePath + , configInputFile :: FilePath + , configOutputFile :: FilePath + , configCpphsPath :: FilePath + , configGHCArgs :: [String] + , configCpphsArgs :: [String] + } deriving Show + +getExecutable :: String -> Maybe FilePath -> IO FilePath +getExecutable _ (Just path) = return path +getExecutable name Nothing = fmap (fromMaybe (error errMsg)) (findExecutable name) + where errMsg = "Couldn't find: "++name + + + +mkConfigFlags :: TempFlags -> IO ConfigFlags +mkConfigFlags tmpFlags + = do ghcPath <- getExecutable "ghc" (tempGHCPath tmpFlags) + cpphsPath <- getExecutable "cpphs" (tempCpphsPath tmpFlags) + return (ConfigFlags + { configGHCPath = ghcPath + , configCpphsPath = cpphsPath + , configInputFile = tempInputFile tmpFlags + , configOutputFile = tempOutputFile tmpFlags + , configGHCArgs = tempGHCArgs tmpFlags + , configCpphsArgs = tempCpphsArgs tmpFlags}) + +data TempFlags + = TempFlags + { tempGHCPath :: Maybe FilePath + , tempInputFile :: FilePath + , tempOutputFile :: FilePath + , tempCpphsPath :: Maybe FilePath + , tempGHCArgs :: [String] + , tempCpphsArgs :: [String] + } deriving Show + +data Flag + = WithGHC FilePath + | InputFile FilePath + | OutputFile FilePath + | WithCpphs FilePath + | GHCArgs String + | CpphsArgs String + | HelpFlag + +-- We don't want to use elem, because that imposes Eq a +hasHelpFlag :: [Flag] -> Bool +hasHelpFlag flags = not . null $ [ () | HelpFlag <- flags ] + + +emptyTempFlags :: TempFlags +emptyTempFlags = + TempFlags + { tempGHCPath = Nothing + , tempInputFile = "-" + , tempOutputFile = "-" + , tempCpphsPath = Nothing + , tempGHCArgs = [] + , tempCpphsArgs = [] + } + + +globalOptions :: [OptDescr Flag] +globalOptions = + [ Option "h?" ["help"] (NoArg HelpFlag) "Show this help text" + , Option "w" ["ghc"] (ReqArg WithGHC "PATH") "Use this GHC" + , Option "" ["cpphs"] (ReqArg WithCpphs "PATH") "Use this cpphs" + , Option "i" ["input"] (ReqArg InputFile "PATH") "Input file" + , Option "o" ["output"] (ReqArg OutputFile "PATH") "Output file" + , Option "" ["ghc-args"] (ReqArg GHCArgs "Arguments") "Arguments to GHC" + , Option "" ["cpphs-args"] (ReqArg CpphsArgs "Arguments") "Arguments to cpphs" + ] + +printHelp :: IO () +printHelp = + do pname <- getProgName + let syntax_line = concat [ "Usage: ", pname + , " [FLAGS]\n"] + putStrLn (usageInfo syntax_line globalOptions) + +parseArgs :: [String] -> IO TempFlags +parseArgs args = + case getOpt' RequireOrder globalOptions args of + (flags, _, _, []) | hasHelpFlag flags -> do + printHelp + exitWith ExitSuccess + (flags, [], _, []) -> return (mkTempFlags flags emptyTempFlags) + (_, _, _, errs) -> do putStrLn "Errors:" + mapM_ putStrLn errs + exitWith (ExitFailure 1) + +mkTempFlags :: [Flag] -> TempFlags -> TempFlags +mkTempFlags = updateCfg + where updateCfg [] t = t + updateCfg (fl:flags) t = updateCfg flags $ + case fl of + WithGHC path -> t { tempGHCPath = Just path } + InputFile path -> t { tempInputFile = path } + OutputFile path -> t { tempOutputFile = path } + WithCpphs path -> t { tempCpphsPath = Just path } + GHCArgs args -> t { tempGHCArgs = tempGHCArgs t ++ words args } + CpphsArgs args -> t { tempCpphsArgs = tempCpphsArgs t ++ words args } + _ -> error $ "Unexpected flag!" diff --git a/src/Zeroth.hs b/src/Zeroth.hs new file mode 100644 --- /dev/null +++ b/src/Zeroth.hs @@ -0,0 +1,113 @@ +module Zeroth + ( zeroth + ) where + +import Language.Haskell.Exts hiding ( comments ) +import System.Process ( runInteractiveProcess, waitForProcess ) +import System.IO ( hPutStr, hClose, hGetContents, openTempFile ) +import System.Directory ( removeFile, getTemporaryDirectory ) +import System.Exit ( ExitCode (..) ) +import Data.Maybe ( mapMaybe ) + +import Comments ( parseComments, mixComments ) + +zeroth :: FilePath -- ^ Path to GHC + -> FilePath -- ^ Path to cpphs + -> [String] -- ^ GHC options + -> [String] -- ^ cpphs options + -> String -- ^ Input data + -> IO String +zeroth ghcPath cpphsPath ghcOpts cpphsOpts input + = do thInput <- preprocessCpphs cpphsPath (["--noline","-DHASTH"]++cpphsOpts) input + zerothInput <- preprocessCpphs cpphsPath (["--noline"]++cpphsOpts) input + thData <- case parseModule thInput of + ParseOk m@(HsModule _ _ _ _ decls) -> runTH ghcPath m ghcOpts (mapMaybe getTH decls) + e -> error (show e) + zerothData <- case parseModule zerothInput of + ParseOk (HsModule loc m exports im decls) -> return (HsModule loc m exports im (filter delTH decls)) + e -> error (show e) + return (prettyPrint zerothData ++ "\n" ++ unlines (mixComments comments thData)) + where getTH (HsSpliceDecl l s) = Just (l,s) + getTH _ = Nothing + delTH (HsSpliceDecl _ _) = False + delTH _ = True + comments = parseComments input + +preprocessCpphs :: FilePath -- ^ Path to cpphs + -> [String] + -> String + -> IO String +preprocessCpphs cpphs args input + = do tmpDir <- getTemporaryDirectory + (tmpPath,tmpHandle) <- openTempFile tmpDir "TH.cpphs.zeroth" + hPutStr tmpHandle input + hClose tmpHandle + (inH,outH,_,pid) <- runInteractiveProcess cpphs (tmpPath:args) Nothing Nothing + hClose inH + output <- hGetContents outH + length output `seq` hClose outH + eCode <- waitForProcess pid + removeFile tmpPath + case eCode of + ExitFailure err -> error $ "Failed to run cpphs: " ++ show err + ExitSuccess -> return output + +runTH :: FilePath -- ^ Path to GHC + -> HsModule + -> [String] + -> [(SrcLoc,HsSplice)] + -> IO [(Int,String)] +runTH ghcPath (HsModule _ _ _ imports _) ghcOpts th + = do tmpDir <- getTemporaryDirectory + (tmpInPath,tmpInHandle) <- openTempFile tmpDir "TH.source.zeroth.hs" + hPutStr tmpInHandle realM + hClose tmpInHandle + let args = [tmpInPath,"-e","main","-fth","-fglasgow-exts"]++ghcOpts + --putStrLn $ "Module:\n" ++ realM + --putStrLn $ "Running: " ++ unwords (ghcPath:args) + (inH,outH,errH,pid) <- runInteractiveProcess ghcPath args Nothing Nothing + hClose inH + output <- hGetContents outH + --putStrLn $ "TH Data:\n" ++ output + length output `seq` hClose outH + errMsg <- hGetContents errH + length errMsg `seq` hClose errH + eCode <- waitForProcess pid + -- removeFile tmpInPath + case eCode of + ExitFailure err -> error (unwords (ghcPath:args) ++ ": failure: " ++ show err) + ExitSuccess | not (null errMsg) -> error (unwords (ghcPath:args) ++ ": failure:\n" ++ errMsg) + | otherwise -> case reads output of + [(ret,_)] -> return ret + _ -> error $ "Failed to parse result:\n"++output + where thImport = HsImportDecl emptySrcLoc (Module "Language.Haskell.TH") False Nothing Nothing + emptySrcLoc = SrcLoc "" 0 0 + pp :: (Pretty a) => a -> String + pp = prettyPrintWithMode (defaultMode{layout = PPInLine}) + realM = unlines $ ["module Main ( main ) where"] + ++ map pp (thImport:imports) + ++ ["main = do decls <- sequence $ " ++ pp (HsList splices)] + ++ [" print $ map (\\(l,d) -> (l,pprint d)) (zip "++ pp (HsList lineNums) ++" decls)"] + splices = flip map th $ \(_src,splice) -> HsApp (HsVar (UnQual (HsIdent "runQ"))) (HsParen (spliceToExp splice)) + lineNums = flip map th $ \(loc,_splice) -> HsLit (HsInt (fromIntegral (srcLine loc))) + spliceToExp (HsParenSplice e) = e + spliceToExp _ = error "TH: FIXME!" + +{- + +module Test where +$(test) -- line 2 +$(jalla) -- line 3 +svend = svend + + +------------------------------- + +module Main where +import Language.Haskell.TH +main = do decs <- sequence [runQ test + ,runQ jalla] + mapM_ (putStrLn.pprint) (zip decs [2,3]) + + +-} diff --git a/zeroth.cabal b/zeroth.cabal --- a/zeroth.cabal +++ b/zeroth.cabal @@ -1,5 +1,5 @@ Name: zeroth -Version: 2008.10.27 +Version: 2008.10.28 License: BSD3 License-file: LICENSE Maintainer: Lemmih @@ -17,5 +17,6 @@ Executable: zeroth Main-is: Main.hs +Other-modules: Comments, Setup, Zeroth GHC-Options: -Wall Hs-Source-Dirs: src