zeroth 2008.10.27 → 2008.10.28
raw patch · 4 files changed
+252/−1 lines, 4 files
Files
- src/Comments.hs +23/−0
- src/Setup.hs +114/−0
- src/Zeroth.hs +113/−0
- zeroth.cabal +2/−1
+ src/Comments.hs view
@@ -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)
+ src/Setup.hs view
@@ -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!"
+ src/Zeroth.hs view
@@ -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])+++-}
zeroth.cabal view
@@ -1,5 +1,5 @@ Name: zeroth-Version: 2008.10.27+Version: 2008.10.28 License: BSD3 License-file: LICENSE Maintainer: Lemmih <lemmih@gmail.com>@@ -17,5 +17,6 @@ Executable: zeroth Main-is: Main.hs+Other-modules: Comments, Setup, Zeroth GHC-Options: -Wall Hs-Source-Dirs: src