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