packages feed

zeroth 2008.10.28 → 2009.6.23

raw patch · 16 files changed

+573/−297 lines, 16 filesdep +Cabaldep +derivedep +filepathdep ~basedep ~haskell-src-extsbuild-type:Customsetup-changednew-uploader

Dependencies added: Cabal, derive, filepath, hskeleton, monoid-record, syb, template-haskell

Dependency ranges changed: base, haskell-src-exts

Files

+ Distribution/ZeroTH.hs view
@@ -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"
LICENSE view
@@ -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,
+ Language/Haskell/TH/ZeroTH.hs view
@@ -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])+++-}
+ Language/Haskell/TH/ZeroTH/Comments.hs view
@@ -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)
+ Language/Haskell/TH/ZeroTH/Config.hs view
@@ -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
+ Language/Haskell/TH/ZeroTH/Helper.hs view
@@ -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
+ ListUtils.hs view
@@ -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
+ Main.hs view
@@ -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
− Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
+ Setup.lhs view
@@ -0,0 +1,4 @@+#!/usr/bin/env runhaskell+> import Distribution.ZeroTH+> main = zeroTHCabalMain (Just ["Data.Derive"]) ["--hashes"] ["Language/Haskell/TH/ZeroTH/GetOpt.hs"]+
+ ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs view
@@ -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
− src/Comments.hs 
@@ -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)
− src/Main.hs 
@@ -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--
− src/Setup.hs 
@@ -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!"
− src/Zeroth.hs 
@@ -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])----}
zeroth.cabal view
@@ -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 <lemmih@gmail.com>-Build-type:    Simple-Build-depends: base, haskell-src-exts, directory, process-Copyright:     2005-2008 Lemmih <lemmih@gmail.com>+Maintainer:    Robin Green <greenrd@greenrd.org>+Build-type:    Custom+Copyright:     2005-2008 Lemmih <lemmih@gmail.com>, 2009 Robin Green <greenrd@greenrd.org> 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, .