{-# LANGUAGE TemplateHaskell, PatternGuards, MagicHash #-} -- | This module provides a quotation feature to let you write command line -- arguments in the impure style, but have them translated into the pure style, -- as per "System.Console.CmdArgs.Implicit". An example: -- -- > {-# LANGUAGE TemplateHaskell, DeriveDataTypeable, MagicHash #-} -- > import System.Console.CmdArgs.Implicit -- > import System.Console.CmdArgs.Quote -- > -- > data Sample = Sample {hello :: String} deriving (Show, Data, Typeable) -- > -- > $(cmdArgsQuote [d| -- > sample = Sample{hello = def &=# help "World argument" &=# opt "world"} -- > &=# summary "Sample v1" -- > -- > run = cmdArgs# sample :: IO Sample -- > |]) -- > -- > main = print =<< run -- -- Inside 'cmdArgsQuote' you supply the command line parser using attributes in the -- impure style. If you run with @-ddump-splices@ (to see the Template Haskell output), -- you would see: -- -- > run = cmdArgs_ -- > (record Sample{} [hello := def += help "World argument" += opt "world"] -- > += summary "Sample v1") -- > :: IO Sample -- -- /Stubs/ -- -- To define the original parser you may use either the standard impure annotations ('(&=)', 'modes'), or -- the stub annotations versions defined in this module ('(&=#)', 'modes'). The stub versions do not include -- a "Data" constraint, so can be used in situations where the Data instance is not yet available - typically -- when defining the parser in the same module as the data type on GHC 7.2 and above. The stub versions should -- never be used outside 'cmdArgsQuote' and will always raise an error. -- -- /Explicit types/ -- -- There will be a limited number of situations where an impure parser will require additional types, typically -- on the result of 'cmdArgs' if the result is used without a fixed type - for example if you 'show' it. Most users -- will not need to add any types. In some cases you may need to remove some explicit types, where the intermediate -- type of the annotations has changed - but again, this change should be rare. -- -- /Completeness/ -- -- The translation is not complete, although works for all practical instances I've tried. The translation works -- by first expanding out the expression (inlining every function defined within the quote, inlining let bindings), -- then performs the translation. This scheme leads to two consequences: 1) Any expensive computation executed inside -- the quotation to produce the command line flags may be duplicated (a very unlikely scenario). 2) As I do not yet -- have expansion rules for all possible expressions, the expansion (and subsequently the translation) may fail. -- I am interested in any bug reports where the feature does not work as intended. module System.Console.CmdArgs.Quote( -- * Template Haskell quotation function cmdArgsQuote, -- * Stub versions of the impure annotations (&=#), modes#, cmdArgsMode#, cmdArgs#, enum# ) where import Language.Haskell.TH import Control.Arrow import Control.Monad import Data.Data import Data.Maybe import System.Console.CmdArgs.Implicit stub name = error $ "System.Console.CmdArgs.Quote." ++ name ++ ": this function is provided only for use inside cmdArgsQuote, and should never be called" -- | Version of '&=' without a 'Data' context, only to be used within 'cmdArgsQuote'. (&=#) :: a -> Ann -> a (&=#) = stub "(&=#)" -- | Version of 'modes' without a 'Data' context, only to be used within 'cmdArgsQuote'. modes# :: [a] -> a modes# = stub "modes#" -- | Version of 'cmdArgsMode' without a 'Data' context, only to be used within 'cmdArgsQuote'. cmdArgsMode# :: a -> Mode (CmdArgs a) cmdArgsMode# = stub "cmdArgsMode#" -- | Version of 'cmdArgs' without a 'Data' context, only to be used within 'cmdArgsQuote'. cmdArgs# :: a -> IO a cmdArgs# = stub "cmdArgs#" -- | Version of 'enum' without a 'Data' context, only to be used within 'cmdArgsQuote'. enum# :: [a] -> a enum# = stub "enum#" -- | Quotation function to turn an impure version of "System.Console.CmdArgs.Implicit" into a pure one. -- For details see "System.Console.CmdArgs.Quote". cmdArgsQuote :: Q [Dec] -> Q [Dec] cmdArgsQuote x = do x <- x translate $ rename $ simplify $ inline x -- | Apply the rewrite rules translate :: [Dec] -> Q [Dec] translate = descendBiM f where dull = ['Just, 'Left, 'Right, '(:)] -- Prelude constructors of non-zero arity f (RecConE x xs) = return $ let args = [anns (InfixE (Just $ VarE lbl) (ConE '(:=)) (Just val)) as | (lbl,x) <- xs, let (val, as) = asAnns x] in VarE 'record `AppE` RecConE x [] `AppE` ListE args f x | (ConE x, xs@(_:_)) <- asApps x, x `notElem` dull = do names <- forM [1..length xs] $ \i -> newName $ "_" ++ nameBase x ++ show i let (vals, ass) = unzip $ map asAnns xs bind = [ValD (VarP name) (NormalB val) [] | (name,val) <- zip names vals] args = [anns (VarE 'atom `AppE` VarE name) as | (name,as) <- zip names ass] return $ LetE bind $ VarE 'record `AppE` (ConE x `apps` map VarE names) `AppE` ListE args f x = descendM f x apps x [] = x apps x (y:ys) = apps (x `AppE` y) ys asApps (AppE x y) = let (a,b) = asApps x in (a,b++[y]) asApps x = (x,[]) anns x [] = x anns x (a:as) = anns (InfixE (Just x) (VarE '(+=)) (Just a)) as asAnns (InfixE (Just x) (VarE op) (Just y)) | op == '(+=) = let (a,b) = asAnns x in (a,b++[y]) asAnns (AppE (AppE (VarE op) x) y) | op == '(+=) = let (a,b) = asAnns x in (a,b++[y]) asAnns x = (x, []) -- | Move from the old names to the new names, sufficient for where that is the full translation rename :: [Dec] -> [Dec] rename = transformBi f where rep = let f a b c = [(a,c),(b,c)] in concat [f '(&=) '(&=#) '(+=) ,f 'modes 'modes# 'modes_ ,f 'enum 'enum# 'enum_ ,f 'cmdArgsMode 'cmdArgsMode# 'cmdArgsMode_ ,f 'cmdArgs 'cmdArgs# 'cmdArgs_] f (VarE x) | Just x <- lookup x rep = VarE x f x = x -- | Simplify the syntax tree - things like application of a lambda simplify :: [Dec] -> [Dec] simplify = transformBi f where f (AppE (LamE [VarP v] bod) x) = f $ subst v x bod f x = x subst v x bod = transform f bod where f (VarE v2) | v == v2 = x f x = x -- | Evaluate through all locally defined functions and let expressions, at most once per defn inline :: [Dec] -> [Dec] inline xs = map (dec $ addEnv xs []) xs where newEnv = concatMap $ \x -> case x of FunD x [Clause ps (NormalB e) ds] -> [(x, LamE ps $ let_ ds e)] ValD (VarP x) (NormalB e) ds -> [(x, let_ ds e)] _ -> [] addEnv xs env = without [] (newEnv xs) ++ env where -- create an environment where everything in ns is missing, recursively drop one thing each time without ns new = [(n, exp (new2 ++ env) e) | (n,e) <- new, n `notElem` ns, let new2 = without (n:ns) new] dec env (FunD n cs) = FunD n $ map (clause env) cs dec env (ValD p x ds) = ValD p (body (addEnv ds env) x) ds clause env (Clause ps x ds) = Clause ps (body (addEnv ds env) x) ds body env (GuardedB xs) = GuardedB $ map (second $ exp env) xs body env (NormalB x) = NormalB $ exp env x -- FIXME: propagating the env ignores variables shadowed by LamE/CaseE exp env (LetE ds x) = LetE ds $ exp (addEnv ds env) x exp env (VarE x) | Just x <- lookup x env = x exp env x = descend (exp env) x let_ ds e = if null ds then e else LetE ds e --------------------------------------------------------------------- -- MINI UNIPLATE - Avoid the dependency just for one small module descendBi :: (Data a, Data b) => (b -> b) -> a -> a descendBi f x | Just f <- cast f = f x | otherwise = gmapT (descendBi f) x descend :: Data a => (a -> a) -> a -> a descend f = gmapT (descendBi f) transform :: Data a => (a -> a) -> a -> a transform f = f . descend (transform f) transformBi :: (Data a, Data b) => (b -> b) -> a -> a transformBi f = descendBi (transform f) descendBiM :: (Data a, Data b, Monad m) => (b -> m b) -> a -> m a descendBiM f x | Just x <- cast x = liftM (fromJust . cast) $ f x -- guaranteed safe | otherwise = gmapM (descendBiM f) x descendM :: (Data a, Monad m) => (a -> m a) -> a -> m a descendM f = gmapM (descendBiM f)