Language/Haskell/TH/Quote.hs

    {-# LANGUAGE RankNTypes, ScopedTypeVariables #-}
    module Language.Haskell.TH.Quote(
            QuasiQuoter(..),
            dataToQa, dataToExpQ, dataToPatQ,
            quoteFile
        ) where

    import Data.Data
    import Language.Haskell.TH.Lib
    import Language.Haskell.TH.Syntax

    data QuasiQuoter = QuasiQuoter { quoteExp  :: String -> Q Exp,
                                     quotePat  :: String -> Q Pat,
                                     quoteType :: String -> Q Type,
                                     quoteDec  :: String -> Q [Dec] }

    dataToQa  ::  forall a k q. Data a
              =>  (Name -> k)
              ->  (Lit -> Q q)
              ->  (k -> [Q q] -> Q q)
              ->  (forall b . Data b => b -> Maybe (Q q))
              ->  a
              ->  Q q
    dataToQa mkCon mkLit appCon antiQ t =
        case antiQ t of
          Nothing ->
              case constrRep constr of
                AlgConstr _ ->
                    appCon (mkCon conName) conArgs
                  where
                    conName :: Name
                    conName =
                        case showConstr constr of
                          "(:)"       -> Name (mkOccName ":") (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))
                          con@"[]"    -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))
                          con@('(':_) -> Name (mkOccName con) (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Tuple"))
                          con         -> mkNameG_d (tyConPackage tycon)
                                                   (tyConModule tycon)
                                                   con
                      where
                        tycon :: TyCon
                        tycon = (typeRepTyCon . typeOf) t

                    conArgs :: [Q q]
                    conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
                IntConstr n ->
                    mkLit $ integerL n
                FloatConstr n ->
                    mkLit $ rationalL n
                CharConstr c ->
                    mkLit $ charL c
            where
              constr :: Constr
              constr = toConstr t

          Just y -> y

    -- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the same
    -- value. It takes a function to handle type-specific cases.
    dataToExpQ  ::  Data a
                =>  (forall b . Data b => b -> Maybe (Q Exp))
                ->  a
                ->  Q Exp
    dataToExpQ = dataToQa conE litE (foldl appE)

    -- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same
    -- value. It takes a function to handle type-specific cases.
    dataToPatQ  ::  Data a
                =>  (forall b . Data b => b -> Maybe (Q Pat))
                ->  a
                ->  Q Pat
    dataToPatQ = dataToQa id litP conP

    -- | 'quoteFile' takes a 'QuasiQuoter' and lifts it into one that read
    -- the data out of a file.  For example, suppose 'asmq' is an
    -- assembly-language quoter, so that you can write [asmq| ld r1, r2 |]
    -- as an expression. Then if you define @asmq_f = quoteFile asmq@, then
    -- the quote [asmq_f|foo.s|] will take input from file @"foo.s"@ instead
    -- of the inline text
    quoteFile :: QuasiQuoter -> QuasiQuoter
    quoteFile (QuasiQuoter { quoteExp = qe, quotePat = qp, quoteType = qt, quoteDec = qd })
      = QuasiQuoter { quoteExp = get qe, quotePat = get qp, quoteType = get qt, quoteDec = get qd }
      where
       get :: (String -> Q a) -> String -> Q a
       get old_quoter file_name = do { file_cts <- runIO (readFile file_name)
                                     ; addDependentFile file_name
                                     ; old_quoter file_cts }