    {-# 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)