diff --git a/Language/Haskell/TH/ZeroTH/GetOpt.hs b/Language/Haskell/TH/ZeroTH/GetOpt.hs new file mode 100644 --- /dev/null +++ b/Language/Haskell/TH/ZeroTH/GetOpt.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE TemplateHaskell, CPP #-} +{-# 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 ) +#ifdef version +import Distribution.Version ( Version(..) ) +#else +#define version undefined +#endif + +import Data.DeriveTH ( derive ) +import Data.Derive.LazySet ( makeLazySet ) +import Data.Derive.Monoid ( makeMonoid ) + +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 + } + +$(derive makeMonoid ''TempFlags) +$(derive makeLazySet ''TempFlags) + +-- XXX: Use Data.Derive to generate these instead +#define ADDER(FIELD,SET) FIELD ## ' = addP FIELD SET +#define ADDERT(FIELD) ADDER(temp ## FIELD, setTemp ## FIELD) +ADDERT(GHCPath) +ADDERT(InputFile) +ADDERT(OutputFile) +ADDERT(CpphsPath) +ADDERT(GHCArgs) +ADDERT(CpphsArgs) +ADDERT(DropImport) +ADDERT(JustSplices) +ADDERT(StdFlag) + +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 globalOptions tempStdFlag diff --git a/ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs b/ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs deleted file mode 100644 --- a/ppsrc/Language/Haskell/TH/ZeroTH/GetOpt.hs +++ /dev/null @@ -1,176 +0,0 @@ -{-# 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/zeroth.cabal b/zeroth.cabal --- a/zeroth.cabal +++ b/zeroth.cabal @@ -1,5 +1,5 @@ Name: zeroth -Version: 2009.6.23 +Version: 2009.6.23.2 Cabal-version: >= 1.6 License: BSD3 License-file: LICENSE