diff --git a/Distribution/ZeroTH.hs b/Distribution/ZeroTH.hs new file mode 100644 --- /dev/null +++ b/Distribution/ZeroTH.hs @@ -0,0 +1,40 @@ +module Distribution.ZeroTH where + +import Data.Foldable ( fold ) +import Data.Monoid ( mempty ) +import Distribution.Package ( PackageIdentifier(..) ) +import Distribution.PackageDescription ( PackageDescription(..) ) +import Distribution.Simple ( Args, defaultMainWithHooks, simpleUserHooks, postConf ) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo ) +import Distribution.Simple.Setup ( ConfigFlags(..) ) +import System.Directory ( createDirectoryIfMissing ) +import System.FilePath ( (), takeDirectory ) + +import Language.Haskell.TH.ZeroTH ( zeroTH ) +import Language.Haskell.TH.ZeroTH.GetOpt ( mkConfig, tempCpphsArgs', tempCpphsPath', tempDropImport', TempFlags, tempGHCArgs', tempGHCPath', tempInputFile', tempOutputFile' ) + +zeroTHCabalMain :: Maybe [String] -> [String] -> [FilePath] -> IO () +zeroTHCabalMain dropIm extraCpphsArgs relevantFiles + = defaultMainWithHooks $ simpleUserHooks { postConf = zeroTHPostConf dropIm extraCpphsArgs relevantFiles } + +zeroTHPostConf :: Maybe [String] -> [String] -> [FilePath] -> Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () +zeroTHPostConf dropIm extraCpphsArgs relevantFiles _ + (ConfigFlags { configProgramPaths = paths, configProgramArgs = args }) + (PackageDescription { package = PackageIdentifier { pkgVersion = version } }) + _ = let ppFlags = tempCpphsArgs' (("-Dversion=" ++ show version) : extraCpphsArgs ++ fold (lookup "cpphs" args)) + . maybe id tempCpphsPath' (lookup "cpphs" paths) + . maybe id tempDropImport' dropIm + . tempGHCArgs' ("--make" : fold (lookup "ghc" args)) + $ maybe id tempGHCPath' (lookup "ghc" paths) mempty + in mapM_ (ppZeroTH ppFlags) relevantFiles + +-- | Run zeroTH as a preprocessor on the given file +ppZeroTH :: TempFlags -> FilePath -> IO () +ppZeroTH flags inputFile = do + let outputFile = ppOutputDir inputFile + createDirectoryIfMissing True $ takeDirectory outputFile + zeroTH =<< mkConfig (tempInputFile' inputFile $ tempOutputFile' outputFile flags) + +-- | The directory in which generated files are written +ppOutputDir :: FilePath +ppOutputDir = "ppsrc" diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ -Copyright (c) 2004-2005, David Himmelstrup +Copyright (c) 2004-2008, David Himmelstrup +Copyright (c) 2009, Robin Green All rights reserved. Redistribution and use in source and binary forms, diff --git a/Language/Haskell/TH/ZeroTH.hs b/Language/Haskell/TH/ZeroTH.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/ZeroTH.hs @@ -0,0 +1,241 @@ +module Language.Haskell.TH.ZeroTH + ( prettyPrintAll, zeroTH, zeroTHInternal + ) where + +import Language.Haskell.Exts +import System.Process ( runInteractiveProcess, waitForProcess ) +import System.IO ( hClose, hGetContents, hPutStr, hPutStrLn, openTempFile, stderr ) +import System.Directory ( removeFile, getTemporaryDirectory ) +import System.Exit ( ExitCode (..) ) +import Control.Applicative ( (<$>), (<*>) ) +import Control.Monad ( guard, when ) +import Data.Foldable ( fold ) +import Data.Generics.Aliases ( mkT ) +import Data.Generics.Schemes ( everywhere, listify ) +import Data.List ( (\\), delete, intersperse, isInfixOf, isPrefixOf, nub, stripPrefix ) +import Data.Maybe ( catMaybes, fromMaybe, mapMaybe ) + +import Language.Haskell.TH.ZeroTH.Config ( Config(..) ) +import Language.Haskell.TH.ZeroTH.Comments ( Location, parseComments, mixComments ) +import Language.Haskell.TH.ZeroTH.Helper ( idPrefix ) +import ListUtils ( replaceAll ) + +readFromFile :: FilePath -> IO String +readFromFile "-" = getContents +readFromFile path = readFile path + +writeToFile :: FilePath -> String -> IO () +writeToFile "-" d = putStr d +writeToFile path d = writeFile path d + +zeroTH :: Config -> IO () +zeroTH = (=<<) . writeToFile . outputFile <*> (prettyPrintAll <$>) . zeroTHInternal + +data ZeroTHOutput + = ZeroTHOutput { originalSource :: String + , combinedOutput :: Module + , thOutput :: [(Location, String)] + } + +zeroTHInternal :: Config -> IO ZeroTHOutput +zeroTHInternal c + = do input <- readFromFile $ inputFile c + tmpDir <- getTemporaryDirectory + (inputFile2, tmpHandle) <- case inputFile c of + "-" -> openTempFile tmpDir "TH.cpphs.zeroth" + _ -> return (inputFile c, undefined) + when (inputFile c == "-") $ hPutStr tmpHandle input >> hClose tmpHandle + let exts = readExtensions input + hPutStrLn stderr $ "extensions: " ++ show exts + let firstLine = head $ lines input + shouldRunCpphs = "-cpp" `elem` ghcArgs c || " -cpp " `isInfixOf` firstLine || CPP `elem` (fold exts) + thInput <- if shouldRunCpphs then preprocessCpphs (cpphsPath c) (["--noline","-DHASTH"]++cpphsArgs c) inputFile2 + else return input + zerothInput <- if shouldRunCpphs then preprocessCpphs (cpphsPath c) ("--noline" : cpphsArgs c) inputFile2 + else return input + (thData, qualImports) <- case parseFileContents thInput of + ParseOk m -> unzip <$> runTH (ghcPath c) ((if wholeFile c then id else onlySplices) m) (ghcArgs c) + e -> error $ show e ++ '\n' : thInput + let reattach :: [Decl] -> [Decl] + reattach (SpliceDecl sLoc _ : t) = (parseDecls . fromMaybe err $ lookup (location sLoc) thData) ++ t + where + err = error $ "Could not find splice at " ++ show (location sLoc) ++ " in " ++ show thData + reattach x = x + combinedData <- case parseFileContents zerothInput of + ParseOk (Module loc m pragmas mWarn exports im decls) + -> return (Module loc m pragmas mWarn exports (postProcessImports (dropImport c) im $ concat qualImports) + (everywhere (mkT reattach) decls)) + e -> error $ show e ++ '\n' : zerothInput + when (inputFile c == "-") $ removeFile inputFile2 + return ZeroTHOutput { originalSource = input + , combinedOutput = combinedData + , thOutput = thData + } + where parseDecls s = case parseFileContents s of + ParseOk (Module _ _ _ _ _ _ decls) -> decls + e -> error $ show e ++ '\n' : s + onlySplices (Module loc m pragmas mWarn exports im decls) = Module loc m pragmas mWarn exports im $ listify isSplice decls + isSplice (SpliceDecl _ _) = True + isSplice _ = False + +prettyPrintAll :: ZeroTHOutput -> String +prettyPrintAll out = unlines . mixComments (parseComments $ originalSource out) . numberAndPrettyPrint $ combinedOutput out + +location :: SrcLoc -> Location +location sLoc = (srcLine sLoc, srcColumn sLoc) + +numberAndPrettyPrint :: Module -> [(Location, String)] +numberAndPrettyPrint (Module mLoc m prags mbWarn exports imp decls) + = (nAndPPrag =<< prags) + ++ (location mLoc, concat $ "module " + : prettyPrint m + : catMaybes [ ppWarnText <$> mbWarn + , (\es -> " (" ++ concat (intersperse ", " $ prettyPrint <$> es) ++ ")") <$> exports + ] + ++ [" where"]) + : (((\i -> (location (importLoc i), prettyPrint i)) <$> imp) ++ (nAndPDec =<< decls)) + where nAndPDec d@(TypeDecl loc _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(DataDecl loc _ _ _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(GDataDecl loc _ _ _ _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(InfixDecl loc _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(ClassDecl loc _ _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(InstDecl loc _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(DefaultDecl loc _) = [(location loc, prettyPrint d)] + nAndPDec d@(SpliceDecl loc _) = [(location loc, prettyPrint d)] + nAndPDec d@(TypeSig loc _ _) = [(location loc, prettyPrint d)] + nAndPDec (FunBind matches) = (\match@(Match loc _ _ _ _ _) -> (location loc, prettyPrint match)) <$> matches + nAndPDec d@(PatBind loc _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(ForImp loc _ _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(ForExp loc _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(DataFamDecl loc _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(DataInsDecl loc _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(DeprPragmaDecl loc _) = [(location loc, prettyPrint d)] + nAndPDec d@(DerivDecl loc _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(GDataInsDecl loc _ _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(InlineSig loc _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(InstSig loc _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(RulePragmaDecl loc _) = [(location loc, prettyPrint d)] + nAndPDec d@(SpecInlineSig loc _ _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(SpecSig loc _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(TypeFamDecl loc _ _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(TypeInsDecl loc _ _) = [(location loc, prettyPrint d)] + nAndPDec d@(WarnPragmaDecl loc _) = [(location loc, prettyPrint d)] + nAndPPrag (LanguagePragma loc names) + | null filteredNames = [] + | otherwise = [(location loc, prettyPrint $ LanguagePragma loc filteredNames)] + where + filteredNames = names \\ (Ident <$> unwantedLanguageOptions) + nAndPPrag p@(IncludePragma loc _) = [(location loc, prettyPrint p)] + nAndPPrag p@(CFilesPragma loc _) = [(location loc, prettyPrint p)] + nAndPPrag (OptionsPragma loc mt s) = [(location loc, prettyPrint . OptionsPragma loc mt $ filterOptions s)] + filterOptions optStr = foldr (\opt -> replaceAll (" -" ++ opt ++ " ") " ") optStr $ "cpp" : "fth" : (('X' :) <$> unwantedLanguageOptions) + unwantedLanguageOptions = ["CPP", "TemplateHaskell"] + +ppWarnText :: WarningText -> String +ppWarnText (DeprText s) = "{-# DEPRECATED" ++ s ++ "#-}" +ppWarnText (WarnText s) = "{-# WARNING" ++ s ++ "#-}" + +-- Removes TH imports, and adds any qualified imports needed by generated TH code +postProcessImports :: [String] -> [ImportDecl] -> [String] -> [ImportDecl] +postProcessImports dropPrefixes oldImports qNames + = nub $ removeTH + ++ mapMaybe (\q -> do guard . not $ any (maybe False (\(ModuleName m) -> m == q) . importAs) removeTH + return ImportDecl { importLoc = emptySrcLoc + , importModule = ModuleName q + , importQualified = True + , importSrc = False + , importAs = Nothing + , importPkg = Nothing + , importSpecs = Nothing }) + qNames + where + removeTH = filter (not . (\(ModuleName m) -> any (`isPrefixOf` m) dropPrefixes) . importModule) oldImports + +preprocessCpphs :: FilePath -- ^ Path to cpphs + -> [String] + -> String + -> IO String +preprocessCpphs cpphs args inputFilename + = do (inH,outH,_,pid) <- runInteractiveProcess cpphs (inputFilename:args) Nothing Nothing + hClose inH + output <- hGetContents outH + length output `seq` hClose outH + eCode <- waitForProcess pid + case eCode of + ExitFailure err -> error $ "Failed to run cpphs: " ++ show err + ExitSuccess -> return output + +runTH :: FilePath -- ^ Path to GHC + -> Module + -> [String] + -> IO ([((Location,String),[String])]) +runTH ghc (Module _ _ pragmas _ _ imports decls) ghcOpts + = do tmpDir <- getTemporaryDirectory + (tmpInPath,tmpInHandle) <- openTempFile tmpDir "TH.source.zeroth.hs" + hPutStr tmpInHandle realM + hClose tmpInHandle + let args = [tmpInPath]++ghcOpts++extraOpts + --putStrLn $ "Module:\n" ++ realM + --putStrLn $ "Running: " ++ unwords (ghc:args) + (inH,outH,errH,pid) <- runInteractiveProcess ghc 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 + let check :: [(((Location,String),[String]), String)] -> ((Location,String),[String]) + check [(ret,_)] = ret + check _ = error $ "Failed to parse result:\n" ++ output + case eCode of + ExitFailure err -> error (unwords (ghc:args) ++ ": failure: " ++ show err ++ ":\n" ++ errMsg) + ExitSuccess -> return . mapMaybe (fmap (check . reads) . stripPrefix idPrefix) $ lines output + where pp :: (Pretty a) => a -> String + pp = prettyPrintWithMode (defaultMode{layout = PPInLine}) + realM = unlines $ (pp . disableWarnings <$> pragmas) + ++ ["module ZerothTemp where"] + ++ (pp <$> imports) + ++ ["import qualified " ++ helperModule] + ++ (prettyPrint <$> everywhere (mkT editSplice) decls) + helperModule = "Language.Haskell.TH.ZeroTH.Helper" + editSplice :: Decl -> Decl + editSplice (SpliceDecl loc splice) + = SpliceDecl loc + . ParenSplice + . App (App (Var . Qual (ModuleName helperModule) $ Ident "helper") + (Paren $ spliceToExp splice)) + . Tuple + $ Lit . Int . fromIntegral <$> [ srcLine loc, srcColumn loc ] + editSplice x = x + spliceToExp (ParenSplice e) = e + spliceToExp _ = error "TH: FIXME!" + extraOpts = ["-w"] + extraOpts' = (' ' :) =<< extraOpts + disableWarnings (OptionsPragma loc Nothing s) = OptionsPragma loc Nothing $ s ++ extraOpts' -- Turn off all warnings (works for GHC) + disableWarnings (OptionsPragma loc (Just GHC) s) = OptionsPragma loc (Just GHC) $ s ++ extraOpts' + disableWarnings (LanguagePragma loc xs) = LanguagePragma loc $ delete (Ident "CPP") xs + disableWarnings x = x + +emptySrcLoc :: SrcLoc +emptySrcLoc = SrcLoc "" 0 0 + +{- + +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/Language/Haskell/TH/ZeroTH/Comments.hs b/Language/Haskell/TH/ZeroTH/Comments.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/ZeroTH/Comments.hs @@ -0,0 +1,25 @@ +module Language.Haskell.TH.ZeroTH.Comments where + +type Location = (Int, Int) + +type Comment = (Location,String) + +mixComments :: [Comment] -> [(Location,String)] -> [String] +mixComments c [] = map (showComment.lines.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, 1), c):parseComments' xs (l+1) +parseComments' (_:xs) l = parseComments' xs (l+1) diff --git a/Language/Haskell/TH/ZeroTH/Config.hs b/Language/Haskell/TH/ZeroTH/Config.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/ZeroTH/Config.hs @@ -0,0 +1,13 @@ +module Language.Haskell.TH.ZeroTH.Config where + +data Config + = Config + { ghcPath :: FilePath + , cpphsPath :: FilePath + , inputFile :: FilePath + , outputFile :: FilePath + , ghcArgs :: [String] + , cpphsArgs :: [String] + , dropImport :: [String] + , wholeFile :: Bool + } deriving Show diff --git a/Language/Haskell/TH/ZeroTH/Helper.hs b/Language/Haskell/TH/ZeroTH/Helper.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/ZeroTH/Helper.hs @@ -0,0 +1,20 @@ +module Language.Haskell.TH.ZeroTH.Helper ( helper, idPrefix ) where + +import Control.Applicative ( (<$>) ) +import Data.Generics.Schemes ( listify ) +import Data.Maybe ( fromJust, isJust ) +import Language.Haskell.TH.Ppr ( pprint ) +import Language.Haskell.TH.Syntax ( Dec, nameModule, Q, runIO ) +import System.IO ( hFlush, stdout ) + +import Language.Haskell.TH.ZeroTH.Comments ( Location ) + +idPrefix :: String +idPrefix = "ZEROTH OUTPUT: " + +helper :: Q [Dec] -> Location -> Q [Dec] +helper splice loc = do + decls <- splice + runIO $ do putStrLn $ idPrefix ++ show ((loc, unlines $ pprint <$> decls), map (fromJust . nameModule) $ listify (isJust . nameModule) decls) + hFlush stdout + return decls diff --git a/ListUtils.hs b/ListUtils.hs new file mode 100644 --- /dev/null +++ b/ListUtils.hs @@ -0,0 +1,13 @@ +module ListUtils where + +import Data.List ( intercalate, isPrefixOf, unfoldr ) + +-- | Replace a substring with a replacement string throughout a list +replaceAll :: Eq a => [a] -> [a] -> [a] -> [a] +replaceAll [] newSub = intercalate newSub . map return +replaceAll oldSub newSub = concat . unfoldr replace + where + replace list = do + (h:t) <- return list + return $ if oldSub `isPrefixOf` list then (newSub, drop len list) else ([h], t) + len = length oldSub diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,9 @@ +module Main ( main ) where + +import Language.Haskell.TH.ZeroTH.GetOpt ( myParseArgs, mkConfig ) +import Language.Haskell.TH.ZeroTH ( zeroTH ) + +import System.Environment ( getArgs ) + +main :: IO () +main = zeroTH =<< mkConfig =<< myParseArgs =<< getArgs diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,4 @@ +#!/usr/bin/env runhaskell +> import Distribution.ZeroTH +> main = zeroTHCabalMain (Just ["Data.Derive"]) ["--hashes"] ["Language/Haskell/TH/ZeroTH/GetOpt.hs"] + diff --git a/ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs b/ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs new file mode 100644 --- /dev/null +++ b/ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs @@ -0,0 +1,176 @@ +{-# OPTIONS_GHC + -Wall -fno-warn-missing-signatures -pgmP cpphs -optP --hashes -optP --cpp + #-} +module Language.Haskell.TH.ZeroTH.GetOpt where +import Control.Applicative ((<$>)) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid (Any(..), Last(..), Monoid(..)) +import Data.Monoid.Record (addP) +import System.Console.GetOpt (ArgDescr(..), OptDescr(..)) +import System.Console.GetOpt.Skeleton (mParseArgs) +import System.Console.GetOpt.StandardOpts (StandardFlag, stdOpts) +import System.Directory (findExecutable) +import System.Info (os) +import Distribution.Version (Version(..)) +import Language.Haskell.TH.ZeroTH.Config (Config(..)) + +getExecutable :: String -> Maybe FilePath -> IO FilePath +getExecutable _ (Just path) = return path +getExecutable name (Nothing) + = fromMaybe (error errMsg) <$> findExecutable name + where errMsg = "Couldn't find: " ++ name + +mkConfig :: TempFlags -> IO Config +mkConfig tmpFlags + = do ghcPath' <- getExecutable "ghc" . getLast $ + tempGHCPath tmpFlags + cpphsPath' <- getExecutable "cpphs" . getLast $ + tempCpphsPath tmpFlags + return + Config{ghcPath = ghcPath', cpphsPath = cpphsPath', + inputFile = fromMaybe "-" . getLast $ tempInputFile tmpFlags, + outputFile = fromMaybe "-" . getLast $ tempOutputFile tmpFlags, + ghcArgs = tempGHCArgs tmpFlags `orElse` defaultGhcArgs, + cpphsArgs = tempCpphsArgs tmpFlags, + dropImport = tempDropImport tmpFlags `orElse` defaultDrop, + wholeFile = not . getAny $ tempJustSplices tmpFlags} + where defaultGhcArgs + = ["-fno-code", "-o", nullFile, "-ohi", nullFile] + nullFile + | "mingw" `isPrefixOf` os = "NUL:" + | otherwise = "/dev/null" + defaultDrop = ["Language.Haskell.TH"] + +orElse :: [] a -> [] a -> [] a +orElse [] theDefault = theDefault +orElse x _ = x + +data TempFlags = TempFlags{tempGHCPath :: Last FilePath, + tempInputFile :: Last FilePath, tempOutputFile :: Last FilePath, + tempCpphsPath :: Last FilePath, tempGHCArgs :: [] String, + tempCpphsArgs :: [] String, tempDropImport :: [] String, + tempJustSplices :: Any, tempStdFlag :: Last StandardFlag} + +instance Monoid TempFlags where + mempty + = TempFlags mempty mempty mempty mempty mempty mempty mempty mempty + mempty + mappend (TempFlags x1 x2 x3 x4 x5 x6 x7 x8 x9) + (TempFlags y1 y2 y3 y4 y5 y6 y7 y8 y9) + = TempFlags (mappend x1 y1) (mappend x2 y2) (mappend x3 y3) + (mappend x4 y4) + (mappend x5 y5) + (mappend x6 y6) + (mappend x7 y7) + (mappend x8 y8) + (mappend x9 y9) +setTempGHCPath a0 b0 + = TempFlags a0 (tempInputFile b0) (tempOutputFile b0) + (tempCpphsPath b0) + (tempGHCArgs b0) + (tempCpphsArgs b0) + (tempDropImport b0) + (tempJustSplices b0) + (tempStdFlag b0) +setTempInputFile a0 b0 + = TempFlags (tempGHCPath b0) a0 (tempOutputFile b0) + (tempCpphsPath b0) + (tempGHCArgs b0) + (tempCpphsArgs b0) + (tempDropImport b0) + (tempJustSplices b0) + (tempStdFlag b0) +setTempOutputFile a0 b0 + = TempFlags (tempGHCPath b0) (tempInputFile b0) a0 + (tempCpphsPath b0) + (tempGHCArgs b0) + (tempCpphsArgs b0) + (tempDropImport b0) + (tempJustSplices b0) + (tempStdFlag b0) +setTempCpphsPath a0 b0 + = TempFlags (tempGHCPath b0) (tempInputFile b0) (tempOutputFile b0) + a0 + (tempGHCArgs b0) + (tempCpphsArgs b0) + (tempDropImport b0) + (tempJustSplices b0) + (tempStdFlag b0) +setTempGHCArgs a0 b0 + = TempFlags (tempGHCPath b0) (tempInputFile b0) (tempOutputFile b0) + (tempCpphsPath b0) + a0 + (tempCpphsArgs b0) + (tempDropImport b0) + (tempJustSplices b0) + (tempStdFlag b0) +setTempCpphsArgs a0 b0 + = TempFlags (tempGHCPath b0) (tempInputFile b0) (tempOutputFile b0) + (tempCpphsPath b0) + (tempGHCArgs b0) + a0 + (tempDropImport b0) + (tempJustSplices b0) + (tempStdFlag b0) +setTempDropImport a0 b0 + = TempFlags (tempGHCPath b0) (tempInputFile b0) (tempOutputFile b0) + (tempCpphsPath b0) + (tempGHCArgs b0) + (tempCpphsArgs b0) + a0 + (tempJustSplices b0) + (tempStdFlag b0) +setTempJustSplices a0 b0 + = TempFlags (tempGHCPath b0) (tempInputFile b0) (tempOutputFile b0) + (tempCpphsPath b0) + (tempGHCArgs b0) + (tempCpphsArgs b0) + (tempDropImport b0) + a0 + (tempStdFlag b0) +setTempStdFlag a0 b0 + = TempFlags (tempGHCPath b0) (tempInputFile b0) (tempOutputFile b0) + (tempCpphsPath b0) + (tempGHCArgs b0) + (tempCpphsArgs b0) + (tempDropImport b0) + (tempJustSplices b0) + a0 +-- XXX: Use Data.Derive to generate these instead +tempGHCPath' = addP tempGHCPath setTempGHCPath +tempInputFile' = addP tempInputFile setTempInputFile +tempOutputFile' = addP tempOutputFile setTempOutputFile +tempCpphsPath' = addP tempCpphsPath setTempCpphsPath +tempGHCArgs' = addP tempGHCArgs setTempGHCArgs +tempCpphsArgs' = addP tempCpphsArgs setTempCpphsArgs +tempDropImport' = addP tempDropImport setTempDropImport +tempJustSplices' = addP tempJustSplices setTempJustSplices +tempStdFlag' = addP tempStdFlag setTempStdFlag + +globalOptions :: [] (OptDescr (TempFlags -> TempFlags)) +globalOptions + = stdOpts tempStdFlag' ++ + [Option "" ["only-splices"] (NoArg $ tempJustSplices' True) + "Only pass the splices to GHC, not the whole file (for faster processing)", + Option "w" ["ghc"] (ReqArg tempGHCPath' "PATH") "Use this GHC", + Option "" ["cpphs"] (ReqArg tempCpphsPath' "PATH") + "Use this cpphs", + Option "i" ["input"] (ReqArg tempInputFile' "PATH") "Input file", + Option "o" ["output"] (ReqArg tempOutputFile' "PATH") + "Output file", + Option "" ["ghc-args"] (ReqArg (tempGHCArgs' . words) "Arguments") + "Arguments to GHC", + Option "" ["cpphs-args"] + (ReqArg (tempCpphsArgs' . words) "Arguments") + "Arguments to cpphs", + Option "d" ["drop-import"] + (ReqArg (tempDropImport' . words) "Prefix") + "Any import that starts with this prefix will be removed"] + +myParseArgs :: [] String -> IO TempFlags +myParseArgs + = mParseArgs + Version{versionBranch = [2009, 6, 23], versionTags = []} + globalOptions + tempStdFlag diff --git a/src/Comments.hs b/src/Comments.hs deleted file mode 100644 --- a/src/Comments.hs +++ /dev/null @@ -1,23 +0,0 @@ -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/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Main ( main ) where - -import Zeroth ( zeroth ) -import Setup ( parseArgs, ConfigFlags (..), mkConfigFlags ) - -import System.Environment ( getArgs ) -import System.IO ( hGetContents, stdin, stdout, hPutStr ) - -readFromFile :: FilePath -> IO String -readFromFile "-" = hGetContents stdin -readFromFile path = readFile path - -writeToFile :: FilePath -> String -> IO () -writeToFile "-" d = hPutStr stdout d -writeToFile path d = writeFile path d - - - -main :: IO () -main = do args <- getArgs - configFlags <- mkConfigFlags =<< parseArgs args - input <- readFromFile (configInputFile configFlags) - output <- zeroth (configGHCPath configFlags) - (configCpphsPath configFlags) - (configGHCArgs configFlags) - (configCpphsArgs configFlags) - input - writeToFile (configOutputFile configFlags) output - - diff --git a/src/Setup.hs b/src/Setup.hs deleted file mode 100644 --- a/src/Setup.hs +++ /dev/null @@ -1,114 +0,0 @@ -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 deleted file mode 100644 --- a/src/Zeroth.hs +++ /dev/null @@ -1,113 +0,0 @@ -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,22 +1,38 @@ Name: zeroth -Version: 2008.10.28 +Version: 2009.6.23 +Cabal-version: >= 1.6 License: BSD3 License-file: LICENSE -Maintainer: Lemmih -Build-type: Simple -Build-depends: base, haskell-src-exts, directory, process -Copyright: 2005-2008 Lemmih +Maintainer: Robin Green +Build-type: Custom +Copyright: 2005-2008 Lemmih , 2009 Robin Green Category: Language -Synopsis: ZeroTH - remove unnecessary TH depdendencies. +Synopsis: ZeroTH - remove unnecessary TH dependencies Description: TemplateHaskell is fairly useful for generating new - Haskell programs. This, however, incur a dependency on + Haskell code. This, however, can incur a dependency on TH on subsequent uses where none theoretically should exist. ZeroTH solves this by scanning a file for top-level TH - declarations, evaluates them, and then puts the generated - code back. + declarations, evaluates them, removes TH imports, and outputs + the resulting code. +Bug-reports: mailto:greenrd@greenrd.org +Stability: experimental +Tested-with: GHC == 6.10.3 +Extra-tmp-files: ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs -Executable: zeroth -Main-is: Main.hs -Other-modules: Comments, Setup, Zeroth -GHC-Options: -Wall -Hs-Source-Dirs: src +Source-repository head + Type: darcs + Location: http://patch-tag.com/publicrepos/zerothDarcs2 + +Library + Build-depends: base >= 4, base < 5, haskell-src-exts >= 1.0.0, directory, process, syb, template-haskell, hskeleton >= 0.1, hskeleton < 0.2, derive, monoid-record >= 0.1, monoid-record < 0.2, Cabal >= 1.6, Cabal < 1.7, filepath + Exposed-modules: Language.Haskell.TH.ZeroTH.Config, Language.Haskell.TH.ZeroTH.GetOpt, Language.Haskell.TH.ZeroTH, Language.Haskell.TH.ZeroTH.Helper, Language.Haskell.TH.ZeroTH.Comments, Distribution.ZeroTH + Other-modules: ListUtils + GHC-options: -Wall + Hs-source-dirs: ppsrc, . + +Executable zeroth + Build-depends: base >= 4, base < 5, haskell-src-exts >= 1.0.0, directory, process, syb, template-haskell, hskeleton >= 0.1, hskeleton < 0.2, derive, monoid-record >= 0.1, monoid-record < 0.2, Cabal >= 1.6, Cabal < 1.7, filepath + Main-is: Main.hs + Other-modules: Language.Haskell.TH.ZeroTH.Comments, ListUtils, Language.Haskell.TH.ZeroTH.Config, Language.Haskell.TH.ZeroTH.GetOpt, Language.Haskell.TH.ZeroTH, Language.Haskell.TH.ZeroTH.Helper, Distribution.ZeroTH + GHC-options: -Wall + Hs-source-dirs: ppsrc, .