{-# LANGUAGE TemplateHaskell, GADTs, ExplicitForAll, KindSignatures #-}

module T10828b where

import Language.Haskell.TH
import System.IO

-- attempting to mix GADT and normal constructors
$( return
   [ DataD [] (mkName "T")
           [ PlainTV (mkName "a") ]
           (Just StarT)
           [ NormalC
               (mkName "MkT")
               [ ( Bang NoSourceUnpackedness NoSourceStrictness
                 , VarT (mkName "a")
                 )
               , ( Bang NoSourceUnpackedness NoSourceStrictness
                 , VarT (mkName "a")
                 )
               ]
           , ForallC [PlainTV (mkName "a")]
                     [AppT (AppT EqualityT (VarT $ mkName "a"  ) )
                                           (ConT $ mkName "Int") ] $
             RecGadtC
                 [ (mkName "MkC")]
                 [ ( mkName "foo"
                   , Bang NoSourceUnpackedness NoSourceStrictness
                   , VarT (mkName "a")
                   )
                 , ( mkName "bar"
                   , Bang NoSourceUnpackedness NoSourceStrictness
                   , VarT (mkName "b")
                   )
                 ]
                 (AppT (ConT (mkName "T"))
                       (ConT (mkName "Int")))
           ]
           [] ])


{-# LANGUAGE TypeFamilies #-}

module T10891 where

import Language.Haskell.TH hiding (Type)
import System.IO
import Data.Kind (Type)

class C a where
  f :: a -> Int

class C' a where
  type F a :: Type
  type F a = a
  f' :: a -> Int

class C'' a where
  data Fd a :: Type

instance C' Int where
  type F Int = Bool
  f' = id

instance C'' Int where
  data Fd Int = B Bool | C Char

$(return [])

test :: ()
test =
  $(let
      display :: Name -> Q ()
      display q = do
        i <- reify q
        runIO (hPutStrLn stderr (pprint i) >> hFlush stderr)
    in do
      display ''C
      display ''C'
      display ''C''
      [| () |])


{-# LANGUAGE TemplateHaskell #-}

module T10945 where

import Language.Haskell.TH

$$(return [
   SigD (mkName "m")
        (ForallT [PlainTV (mkName "a")]
                 []
                 (AppT (AppT ArrowT (VarT (mkName "a"))) (VarT (mkName "a"))))
 , FunD (mkName "m")
        [Clause [VarP (mkName "x")] (NormalB (VarE (mkName "x"))) []]
 ])


{-# LANGUAGE TemplateHaskell #-}

module T10946 where

import Language.Haskell.TH

m :: a -> a
m x = $$([||_||])


{-# LANGUAGE TemplateHaskell #-}
module T11046 where

import T11046_helper
import GHC.TypeLits
import Control.Monad(unless)

$(check "GHC.TypeLits.*")
$(check "GHC.TypeLits.+")
$(check "GHC.TypeLits.Nat")


{-# Language TemplateHaskell #-}
module T11046_helper where
import Language.Haskell.TH

check :: String -> Q [Dec]
check x = do mb <- lookupTypeName x
             case mb of
               Nothing -> fail "Bug #11046 is still present."
               Just _  -> return []


{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
module T11145 where

data family Fuggle x y

[d| data instance Fuggle Int (Maybe (a,b)) where
      MkFuggle :: Fuggle Int (Maybe Bool) |]


{-# LANGUAGE GADTs, TemplateHaskell #-}
module T11341 where

import Language.Haskell.TH
import System.IO

type S1 = T1
data T1 a where
  MkT1 :: S1 Int

type S2 a = T2
data T2 a where
  MkT2 :: S2 Char Int

type Id a = a
type S3 a = T3
data T3 a where
      MkT3 :: Id (S3 Char Int)

$( do  -- test reification
  { TyConI dec <- runQ $ reify (mkName "T1")
  ; runIO $ putStrLn (pprint dec) >> hFlush stdout

  ; TyConI dec <- runQ $ reify (mkName "T2")
  ; runIO $ putStrLn (pprint dec) >> hFlush stdout

  ; TyConI dec <- runQ $ reify (mkName "T3")
  ; runIO $ putStrLn (pprint dec) >> hFlush stdout

  ; return [] } )


{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
module Main (main) where

import Language.Haskell.TH

infixr 7 :***:
data GADT a where
  Prefix  :: Int -> Int -> GADT Int
  (:***:) :: Int -> Int -> GADT Int

$(do gadtName   <- newName "GADT2"
     prefixName <- newName "Prefix2"
     infixName  <- newName ":****:"
     a          <- newName "a"
     return [ DataD [] gadtName [KindedTV a StarT] Nothing
              [ GadtC [prefixName]
                [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
                , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
                ] (AppT (ConT gadtName) (ConT ''Int))
              , GadtC [infixName]
                [ (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
                , (Bang NoSourceUnpackedness NoSourceStrictness,ConT ''Int)
                ] (AppT (ConT gadtName) (ConT ''Int))
              ] []
            , InfixD (Fixity 7 InfixR) infixName
            ])

$(return [])

deriving instance Show (GADT2 a)

main :: IO ()
main = do
  -- Verify that infix GADT constructors reify correctly
  putStrLn $(reify ''GADT   >>= stringE . pprint)
  putStrLn $(reify '(:***:) >>= stringE . pprint)
  -- Verify that reifyFixity returns something with (:***:)
  -- (but not with Prefix, since it has no fixity declaration)
  putStrLn $(reifyFixity 'Prefix  >>= stringE . show)
  putStrLn $(reifyFixity '(:***:) >>= stringE . show)
  -- Verify that spliced-in GADT infix constructors are actually infix
  print (1 :****: 4)


{-# LANGUAGE RankNTypes, TemplateHaskell #-}

module T11452 where

impred :: (forall a. a -> a) -> ()
impred = $$( [|| \_ -> () ||] )


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
module Main where

import Data.Kind (Type)
import Language.Haskell.TH hiding (Type)

type Id1    a       = a
type Id2 k (a :: k) = a
data Proxy1 (a :: Id1      k) = Proxy1
data Proxy2 (a :: Id2 Type k) = Proxy2

$(return [])

main :: IO ()
main = do
  putStrLn $(reify ''Proxy1 >>= stringE . pprint)
  putStrLn $(reify ''Proxy2 >>= stringE . pprint)


{-# LANGUAGE PolyKinds #-}

module T11484 where

import Data.Kind

type TySyn (k :: Type) (a :: k) = ()

$([d| type TySyn2 (k :: Type) (a :: k) = () |])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE FlexibleInstances #-}
module T11629 where

import Control.Monad
import Language.Haskell.TH

class C (a :: Bool)
class D (a :: (Bool, Bool))
class E (a :: [Bool])

instance C True
instance C 'False

instance D '(True, False)
instance D '(False, True)

instance E '[True, False]
instance E '[False, True]

do
  let getType (InstanceD _ _ ty _) = ty
      getType _                    = error "getType: only defined for InstanceD"

      failMsg a ty1 ty2 = fail $ "example " ++ a
        ++ ": ty1 /= ty2, where\n ty1 = "
        ++ show ty1 ++ "\n ty2 = " ++ show ty2

      withoutSig (ForallT tvs cxt ty) = ForallT tvs cxt (withoutSig ty)
      withoutSig (AppT ty1 ty2)       = AppT (withoutSig ty1) (withoutSig ty2)
      withoutSig (SigT ty ki)         = withoutSig ty
      withoutSig ty                   = ty

  -- test #1: type quotations and reified types should agree.
  ty1 <- [t| C True |]
  ty2 <- [t| C 'False |]
  ClassI _ insts <- reify ''C
  let [ty1', ty2'] = map getType insts

  when (ty1 /= ty1') $ failMsg "A" ty1 ty1'
  when (ty2 /= ty2') $ failMsg "B" ty2 ty2'

  -- test #2: type quotations and reified types should agree wrt
  -- promoted tuples.
  ty3 <- [t| D '(True, False) |]
  ty4 <- [t| D (False, True)  |]
  ClassI _ insts <- reify ''D
  let [ty3', ty4'] = map (withoutSig . getType) insts

  when (ty3 /= ty3') $ failMsg "C" ty3 ty3'
  -- The following won't work. See https://ghc.haskell.org/trac/ghc/ticket/12853
  -- when (ty4 /= ty4') $ failMsg "D" ty4 ty4'

  -- test #3: type quotations and reified types should agree wrt to
  -- promoted lists.
  ty5 <- [t| E '[True, False] |]
  ty6 <- [t| E [False, True]  |]

  ClassI _ insts <- reify ''E
  let [ty5', ty6'] = map (withoutSig . getType) insts

  when (ty5 /= ty5') $ failMsg "C" ty5 ty5'
  when (ty6 /= ty6') $ failMsg "D" ty6 ty6'

  return []


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DuplicateRecordFields #-}

module T11680 where

import qualified Data.List                  as List
import           Language.Haskell.TH.Syntax         (addTopDecls)

------------------------------------------------------------------------------
-- # No suggestions or exact match
ex1 :: Bool
ex1 = noMatches

------------------------------------------------------------------------------
-- # One suggestion (abcd), but no exact match
ex2 :: [a]
ex2 = abce

abcd :: String
abcd = "abcd"

------------------------------------------------------------------------------
-- # No suggestions, but an exact match after a splice
-- # Exact match following a single-line splice
-- # One splice separating use and binding
-- # Annotation does not affect identification of top-level splice
ex3 :: Int
ex3 = foo

------------------------------------------------------------------------------
-- # Suggestions (bat, baz) and an exact match after a splice
-- # Out-of-scope suggestion (bad) NOT reported
-- # Exact match following a multi-line splice
-- # Multiple splices separating use and binding
ex4 :: ()
ex4 = bar

bat :: [Double]
bat = [1.2, 3.4]

baz :: Bool
baz = True

------------------------------------------------------------------------------
-- # No suggestions, but an exact match IN a splice
ex5 :: [Double]
ex5 = ns

------------------------------------------------------------------------------
-- # Qualified suggestion and an exact local match after a splice
-- # Inline bracket does not affect identification of top-level splice
ex6 = intercalate

------------------------------------------------------------------------------
-- # Qualified suggestion, but no exact local match
ex7 = nub

------------------------------------------------------------------------------
-- # No suggestions or matches for an out-of-scope duplicate field selector
ex8 :: Int
ex8 = x undefined

------------------------------------------------------------------------------
-- # Exact match to binding added by addTopDecls in next inter-splice group
ex9 :: ()
ex9 = cat

----------------------------------------------------------------------------
-- END OF INTER-SPLICE GROUP
----------------------------------------------------------------------------

------------------------------------------------------------------------------
-- # In a splice, suggestions for out-of-scope variable (cab) dependent upon
-- #   whether that variable is used in a binding added by addTopDecls:
-- #   cat and cap both suggested for f's cab, only cap suggested for g's cab
$(do
    ds <- [d| f = cab
              cat = ()
            |]
    addTopDecls ds
    [d| g = cab
        cap = True
      |])

------------------------------------------------------------------------------
-- # Exact match to binding added by addTopDecls in current inter-splice group
ex10 :: ()
ex10 = cat

----------------------------------------------------------------------------
-- END OF INTER-SPLICE GROUP
----------------------------------------------------------------------------
$(return [])

{-# ANN foo (Just "hello") #-}
foo :: Int
foo = 23

----------------------------------------------------------------------------
-- END OF INTER-SPLICE GROUP
----------------------------------------------------------------------------
[d| ms = 3 : ns :: [Int]
    ns = 4 : ms
  |]

bar = [| 23.6 : bat |]

bad = False

intercalate = undefined

data D = D { x :: Int
           , y :: Double
           }

data E = E { x :: Bool
           , y :: String
           }


{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module T11721_TH where

import Language.Haskell.TH

data T a where
  MkT :: forall b a. b -> T a

$(return [])

main :: IO ()
main = print
  $(do let rightOrder :: [TyVarBndr] -> Bool
           rightOrder [KindedTV b _, KindedTV a _]
             = nameBase b == "b" && nameBase a == "a"
           rightOrder _ = False

       TyConI (DataD _ _ _ _
                     [ForallC con_tvbs1 _ _] _) <- reify ''T
       DataConI _ (ForallT con_tvbs2 _ _) _ <- reify 'MkT

       if rightOrder con_tvbs1 && rightOrder con_tvbs2
          then [| () |]
          else fail "T11721_TH failed")


{-# LANGUAGE TemplateHaskell #-}

module T11797 where

import Language.Haskell.TH
import System.IO

$(do dec <- [d| class Foo a where
                  meth :: a -> b -> a |]
     runIO $ do putStrLn $ pprint dec
                hFlush stdout
     return [] )

-- the key bit is the forall b. in the type of the method


{-# LANGUAGE TemplateHaskell #-}
module T11809 where

{- Test splicing in a data type with records -}

[d|
 data D a = MkD { unD :: a }

 someD = MkD "Hello"
 getD  = unD someD   -- unD should resolve to the record selector above!
 |]

getD' = unD someD    -- dito here outside of the splice!


{-# LANGUAGE TemplateHaskell #-}

module T11941 where

import Data.Monoid

const (return []) $ mempty { getFrst = Just () }


{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds
             , TypeInType, TypeApplications, TypeFamilies  #-}

module T12045TH1 where
import Data.Kind
import Language.Haskell.TH hiding (Type)

$([d| type family F (a :: k) :: Type where
                     F @Type Int = Bool
                     F @(Type->Type) Maybe = Char |])

$([d| data family D (a :: k) |])

$([d| data instance D @Type a = DBool |])

$([d| data instance D @(Type -> Type) b = DChar |])


{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds
             , TypeFamilies, DataKinds #-}

module T12045TH2 where

import Data.Kind
import Language.Haskell.TH hiding (Type)
import System.IO

type family Foo (a :: k) :: Type where
  Foo @Type a = Bool

type family Baz (a :: k)
type instance Baz @(Type->Type->Type) a = Char

$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1)
                   [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1])
              [] <- reify ''Foo
      FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2))
              [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz
      runIO $ putStrLn $ pprint foo
      runIO $ putStrLn $ pprint baz
      runIO $ putStrLn $ pprint inst
      runIO $ hFlush stdout
      return [ ClosedTypeFamilyD
                 (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1)
                 [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1]
             , OpenTypeFamilyD
                 (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2)
             , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] )


{-# Language TemplateHaskell #-}
{-# Language DisambiguateRecordFields #-}

module T12130 where

import T12130a hiding (Block)

b = $(block)


{-# LANGUAGE TemplateHaskell #-}

module T12130a where

import Language.Haskell.TH

data Block = Block
    { blockSelector :: ()
    }

block :: Q Exp
block =
    [| Block {
         -- Using record syntax is necessary to trigger the bug.
         blockSelector = ()
       }
    |]


{-# LANGUAGE TemplateHaskell #-}
module T12387 where

import Language.Haskell.TH.Lib

data Foo = Foo

$(do d <- instanceD (cxt []) (conT ''Eq `appT` conT ''Foo)
            [funD 'compare [clause [] (normalB $ varE 'undefined) []]]
     return [d])


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module Main where

import Language.Haskell.TH

data T = T (# Int, Int #)

$(return [])

main :: IO ()
main = putStrLn $(reify ''T >>= stringE . pprint)


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module T12407 where

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

$(do let ubxTup = conT (unboxedTupleTypeName 2) `appT` conT ''Int
                                                `appT` conT ''Int
     x <- newName "x"
     y <- newName "y"

     [d| f :: $(ubxTup) -> $(ubxTup)
         f $(conP (unboxedTupleDataName 2) [varP x, varP y])
             = $(conE (unboxedTupleDataName 2) `appE` varE x
                                               `appE` varE y)
      |])


{-# LANGUAGE TemplateHaskell #-}
module T12411 where

pure @Q []


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedSums #-}
module Main where

import Language.Haskell.TH

data T = T (# Int | Char #)

$(return [])

main :: IO ()
main = putStrLn $(reify ''T >>= stringE . show)


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedSums #-}
-- Essentially the same as TH_repUnboxedTuples, but for unboxed sums
module Main where

import Language.Haskell.TH

main :: IO ()
main = case bar () of
       (# a |   #) -> print a
       (#   | b #) -> print b

bar :: () -> (# String | Int #)
bar () = $( do e <- [| case (# 'b' | #) of
                        (# 'a' |   #) -> (# "One"   |   #)
                        (# 'b' |   #) -> (#         | 2 #)
                        (# _   |   #) -> (# "Three" |   #)
                        (#     | _ #) -> (#         | 4 #)
                     |]
               return e )


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedSums #-}
module T12478_3 where

import Language.Haskell.TH

$(do let ubxSum = unboxedSumT 2 `appT` conT ''Int `appT` conT ''Int
     x <- newName "x"
     y <- newName "y"

     [d| swap :: $(ubxSum) -> $(ubxSum)
         swap $(unboxedSumP (varP x) 1 2) = $(unboxedSumE (varE x) 2 2)
         swap $(unboxedSumP (varP y) 2 2) = $(unboxedSumE (varE y) 1 2)
      |])


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedSums #-}
module T12478_4 where

import Language.Haskell.TH

f :: $(unboxedSumT 1 `appT` conT ''()) -> Int
f _ = 42


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedSums #-}
module T12478_5 where

import Language.Haskell.TH

foo :: $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''())
    -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''())
foo $(conP (unboxedSumDataName 1 2) [conP '() []])
  = $(conE (unboxedSumDataName 2 2) `appE` conE '())
foo $(conP (unboxedSumDataName 2 2) [conP '() []])
  = $(conE (unboxedSumDataName 2 2) `appE` conE '())

foo2 :: (# () | () #)
     -> $(conT (unboxedSumTypeName 2) `appT` conT ''() `appT` conT ''())
foo2 (# () | #) = $(conE (unboxedSumDataName 2 2) `appE` conE '())
foo2 $(conP (unboxedSumDataName 2 2) [conP '() []]) = (# | () #)


{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module T12503 where

import Language.Haskell.TH

data T1 k
class C1 a

$(do TyConI (DataD [] tName [ KindedTV kName kKind] _ _ _)
       <- reify ''T1
     d <- instanceD (cxt [])
                    (conT ''C1 `appT`
                      (conT tName `appT` sigT (varT kName) kKind))
                    []
     return [d])

data family T2 (a :: b)
data instance T2 b
class C2 a

$(do FamilyI (DataFamilyD tName _ _) [DataInstD [] _ tyVar _ _ _]
       <- reify ''T2
     d <- instanceD (cxt [])
                    (conT ''C2 `appT` return tyVar)
                    []
     return [d])


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module T12513 where

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

f :: $([t| (# Int #) |]) -> Int
f x = x

g :: $(unboxedTupleT 1 `appT` conT ''Int) -> Int
g x = x


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module T12530 where

import Language.Haskell.TH

$([d|   -- Test the Template Haskell pretty-printing for TypeApplications
        f :: Maybe Int -> Maybe Int
        f = id @(Maybe Int)

        -- Wildcards and scoped type variables too
        g :: forall a. a
        g = undefined @(_) @(a)
    |])


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module T12646 where

import Language.Haskell.TH hiding (Type)
import System.IO
import Data.Kind (Type)

type family F (a :: k) :: Type where
    F (a :: Type -> Type) = Int
    F (a :: k) = Char

$(do info <- reify ''F
     runIO $ putStrLn $ pprint info
     runIO $ hFlush stdout
     return [])


{-# LANGUAGE TemplateHaskell #-}
module T12788 where

import Language.Haskell.TH
import T12788_Lib

data Bad = Bad { _bad :: String } deriving (Eq, Ord, Show)

$(deriveJSON defaultOptions{} ''Bad)


module T12788_Lib where

import Language.Haskell.TH

data Options = Options
    { fieldLabelModifier :: String -> String
    , constructorTagModifier :: String -> String
    , allNullaryToStringTag :: Bool
    , omitNothingFields :: Bool
    , sumEncoding :: SumEncoding
    , unwrapUnaryRecords :: Bool
    }

data SumEncoding =
    TaggedObject { tagFieldName      :: String
                 , contentsFieldName :: String
                 }
  | ObjectWithSingleField
  | TwoElemArray

deriveJSON :: Options -> Name -> Q [Dec]
deriveJSON _ _ = return []


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnboxedTuples #-}
module T12977 where

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

zero :: () -> $(conT (unboxedTupleTypeName 0))
zero () =  $(conE (unboxedTupleDataName 0))

one :: () -> $(conT (unboxedTupleTypeName 1) `appT` conT ''Int)
one () =  $(conE (unboxedTupleDataName 1)) 42


{-# LANGUAGE TemplateHaskell #-}
module T12993 where
import T12993_Lib
f = $(q)


{-# LANGUAGE TemplateHaskell #-}
module T12993_Lib (q) where
data X = X { x :: Int }
q = [|x|]


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
module T13018 where

data T a where
  MkT :: Eq b => b -> T a

$([d| pattern P :: b -> T a
      pattern P x <- MkT x
    |])


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}

module T13098 where

import Language.Haskell.TH

$( sequence [ dataD (cxt []) (mkName "T") [PlainTV (mkName "a")]
                     Nothing [normalC (mkName "T") []] []
          , pragCompleteD [mkName "T"] Nothing ] )

$([d| class LL f where
        go :: f a -> ()

      instance LL [] where
        go _ = ()

      pattern T2 :: LL f => f a
      pattern T2 <- (go -> ())

      {-# COMPLETE T2 :: [] #-}

      -- No warning
      foo :: [a] -> Int
      foo T2 = 5
    |])


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module T13123 where

import Data.Kind (Type, Constraint)

$([d| idProxy :: forall k proxy (a :: k). proxy a -> proxy a
      idProxy x = x
    |])

$([d| id2 :: Show a => a -> a
      id2 x = x
      {-# SPECIALIZE id2 :: forall k proxy (a :: k). Show (proxy a)
                         => proxy a -> proxy a #-}
    |])

$([d| wibble :: Maybe Int
      wibble = (undefined :: forall k proxy (a :: k). proxy a)
    |])

$([d| class Foo b where
        bar         :: forall k proxy (a :: k). proxy a -> b
        default bar :: forall k proxy (a :: k). proxy a -> b
        bar = undefined
    |])

$([d| data GADT where
        MkGADT :: forall k proxy (a :: k). proxy a -> GADT
    |])

$([d| data Dec13 :: (Type -> Constraint) -> Type where
        MkDec13 :: c a => a -> Dec13 c
    |])


{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -optc-DA_MACRO=1 #-}

import Language.Haskell.TH.Syntax
import System.IO (hFlush, stdout)

foreign import ccall fc :: Int -> IO Int

do addForeignSource LangC $ unlines
     [ "#include <stdio.h>"
     , "int fc(int x) {"
     , "  printf(\"calling f(%d)\\n\",x);"
     , "  fflush(stdout);"
     , "  return A_MACRO + x;"
     , "}"
     ]
   return []

foreign import ccall fcxx :: Int -> IO Int

do addForeignSource LangCxx $ unlines
     [ "#include <iostream>"
     , "extern \"C\" {"
     , "  int fcxx(int x) {"
     , "    std::cout << \"calling fcxx(\" << x << \")\" << std::endl;"
     , "    std::cout.flush();"
     , "    return A_MACRO + x;"
     , "  }"
     , "}"
     ]
   return []

main :: IO ()
main = do
  fc 2 >>= print
  hFlush stdout
  fcxx 5 >>= print
  hFlush stdout


{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH
import T13473a

[quoter|y|] = 1

main :: IO ()
main = do
  let $(varP $ mkName "x") = 1 in print x
  print y


module T13473a where

import Language.Haskell.TH
import Language.Haskell.TH.Quote

quoter :: QuasiQuoter
quoter = QuasiQuoter { quotePat  = varP . mkName
                     , quoteExp  = undefined
                     , quoteDec  = undefined
                     , quoteType = undefined }


{-# LANGUAGE TemplateHaskell #-}

import T13587A

main :: IO ()
main = do
    let sin' = $$(importDoubleToDouble "sin")
        cos' = $$(importDoubleToDouble "cos")
    --
    print (sin' 0)
    print (cos' pi)


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes     #-}

module T13587A where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

importDoubleToDouble :: String -> Q (TExp (Double -> Double))
importDoubleToDouble fname = do
    n <- newName fname
    d <- forImpD CCall unsafe fname n [t|Double -> Double|]
    addTopDecls [d]
    unsafeTExpCoerce (varE n)


{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Main where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (lift)

data family DF a
data    instance DF [a]       = DFList a
newtype instance DF (Maybe a) = DFMaybe a

$(return [])

main :: IO ()
main = print
  $(do FamilyI (DataFamilyD _ _ _) insts <- reify ''DF
       lift $ all (\case DataInstD _ _ (AppT (ConT _) (AppT _ (VarT v1))) _
                                       [NormalC _ [(_, VarT v2)]] _
                           -> v1 == v2
                         NewtypeInstD _ _ (AppT (ConT _) (AppT _ (VarT v1))) _
                                          (NormalC _ [(_, VarT v2)]) _
                           -> v1 == v2
                         _ -> error "Not a data or newtype instance")
              insts)


{-# LANGUAGE GADTs, PolyKinds, TemplateHaskell, RankNTypes #-}
module T13642 where

import Data.Kind (Type)
import Language.Haskell.TH (stringE, pprint)

foo :: IO ()
foo = putStrLn $([d| data Foo :: forall a. a -> Type where MkFoo :: Foo Int |]
                 >>= \d -> stringE (pprint d))


{-# LANGUAGE TemplateHaskell #-}

module T13776 where

import Language.Haskell.TH

spliceTy1 :: $(conT ''(,) `appT` conT ''Int `appT` conT ''Int)
spliceTy1 = (1,2)

spliceTy2 :: $(conT ''[] `appT` conT ''Int)
spliceTy2 = []

spliceExp1 :: (Int, Int)
spliceExp1 = $(conE '(,) `appE` litE (integerL 1) `appE` litE (integerL 1))

spliceExp2 :: [Int]
spliceExp2 = $(conE '[])

splicePat1 :: (Int, Int) -> ()
splicePat1 $(conP '(,) [litP (integerL 1), litP (integerL 1)]) = ()

splicePat2 :: [Int] -> ()
splicePat2 $(conP '[] []) = ()


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PolyKinds #-}
module T13781 where

import Data.Kind
import Data.Proxy

$([d| f :: Proxy (a :: (k :: Type))
      f = Proxy
    |])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module T13782 where

import Language.Haskell.TH

$(do TyConI (DataD _ _ [KindedTV a1 _] _ _ _) <- reify ''Maybe
     [f,a2] <- mapM newName ["f","a"]
     return [ SigD f (ForallT [PlainTV a1,
                               KindedTV a2 (AppT (ConT ''Maybe) (VarT a1))]
                   [] (ConT ''Int))
            , ValD (VarP f) (NormalB (LitE (IntegerL 42))) []
            ])


{-# LANGUAGE TemplateHaskell #-}
module T13837 where

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

test_local_tyfam_expansion :: String
test_local_tyfam_expansion =
  $(do fam_name <- newName "Fam"
       stringE . show =<< qReifyInstances fam_name [])


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices #-}
module T13856 where

import Language.Haskell.TH

f :: Int
f = $(lamE [] [| 42 |])


{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module Main where

import Data.Function (on)
import Language.Haskell.TH.Syntax

data a :~: b where
  Refl :: a ~ b => a :~: b

$(return [])

main :: IO ()
main = print
  $(do TyConI (DataD _ _ tycon_tyvars _
                     [ForallC con_tyvars _ _] _) <- reify ''(:~:)

       let tvbName :: TyVarBndr -> Name
           tvbName (PlainTV  n)   = n
           tvbName (KindedTV n _) = n

       lift $ and $ zipWith ((/=) `on` tvbName) tycon_tyvars con_tyvars)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where

import Data.Proxy
import GHC.Generics
import Language.Haskell.TH

main :: IO ()
main = do
  putStrLn $([t| Proxy  (:*:) |] >>= stringE . pprint)
  putStrLn $([t| Proxy '(:*:) |] >>= stringE . pprint)
  putStrLn $([t| Proxy '(:)   |] >>= stringE . pprint)


{-# LANGUAGE TemplateHaskell #-}
module T13968 where

import Language.Haskell.TH

$(pure [ValD (VarP 'succ) (NormalB (ConE 'True)) []])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE PolyKinds #-}
module Main where

import Data.Kind
import Data.Proxy
import Language.Haskell.TH hiding (Type)

-- Anonymous tyvar binder example
newtype Foo1 = Foo1 (Proxy '[False, True, False])

-- Required (dependent) tyvar binder example
type family Wurble k (a :: k) :: k
newtype Foo2 a = Foo2 (Proxy (Wurble (Maybe a) Nothing))

-- Non-injective type family example
type family Foo3Fam1 (a :: Type) :: Type where
  Foo3Fam1 a = a
type family Foo3Fam2 (a :: Foo3Fam1 b) :: b
newtype Foo3 = Foo3 (Proxy (Foo3Fam2 Int))

-- Injective type family example
type family Foo4Fam1 (a :: Type) = (r :: Type) | r -> a where
  Foo4Fam1 a = a
type family Foo4Fam2 (a :: Foo4Fam1 b) :: b
newtype Foo4 = Foo4 (Proxy (Foo4Fam2 Int))

$(return [])

main :: IO ()
main = do
  putStrLn $(reify ''Foo1 >>= stringE . pprint)
  putStrLn $(reify ''Foo2 >>= stringE . pprint)
  putStrLn $(reify ''Foo3 >>= stringE . pprint)
  putStrLn $(reify ''Foo4 >>= stringE . pprint)


{-# LANGUAGE TemplateHaskell #-}
module T14204 where

import GHC.StaticPtr
import Language.Haskell.TH

main :: IO ()
main = putStrLn (deRefStaticPtr $(pure (StaticE (LitE (StringL "wat")))))


{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE TemplateHaskell #-}

import Language.Haskell.TH.Syntax
import System.IO (hFlush, stdout)

foreign import ccall foo :: Int -> IO Int

do fpIn <- addTempFile "c"
   let cSrc = (unlines [ "#include <stdio.h>"
                       , "int foo(int x) {"
                       , "  printf(\"calling f(%d)\\n\",x);"
                       , "  fflush(stdout);"
                       , "  return 1 + x;"
                       , "}"
                       ])
   runIO $ writeFile fpIn cSrc
   addForeignFilePath LangC fpIn
   return []

main :: IO ()
main = do
  foo 2 >>= print
  hFlush stdout


{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TemplateHaskell #-}

import Language.Haskell.TH
import Prelude

main = putStrLn $(do
  expr <- [|
    do x <- getLine
       y <- getLine
       pure (x, y)
    |]
  stringE (pprint expr))


{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH.Syntax

[d| f = Bool |] >>= addTopDecls >> return []

main = return ()


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module T14646 where

$([d| f :: (forall a. a) -> Int
      f _ = undefined |])


{-# LANGUAGE TemplateHaskell #-}
module T14681 where

import Data.Functor.Identity
import Language.Haskell.TH

$([d| f = \(Identity x) -> x |])
$([d| g = $(pure $ VarE '(+) `AppE` LitE (IntegerL (-1))
                             `AppE` (LitE (IntegerL (-1)))) |])


{-# LANGUAGE TemplateHaskell #-}

module T1476 where

import Language.Haskell.TH

foo $( return $ VarP $ mkName "x" ) = x
bar $( [p| x |] ) = x

baz = [| \ $( return $ VarP $ mkName "x" ) -> $(dyn "x") |]


{-# LANGUAGE TemplateHaskell #-}

module T1476b where

import Language.Haskell.TH

baz = [| \ $( return $ VarP $ mkName "x" ) -> x |]


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module T14817 where

import Data.Kind (Type)

$([d| data family Foo :: Type
      data instance Foo :: Type |])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module T14843 where

import Language.Haskell.TH.Syntax

type T1 = $(return (PromotedTupleT 2))
type T2 = $([t| '(,) |])
type T3 = $(return (PromotedT (tupleDataName 2)))


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
module T14869 where

import Data.Kind
import GHC.Exts
import Language.Haskell.TH (pprint, reify, stringE)

type MyConstraint = Constraint
type MyLiftedRep  = LiftedRep

type family Foo1 :: Type
type family Foo2 :: Constraint
type family Foo3 :: MyConstraint
type family Foo4 :: TYPE MyLiftedRep

$(pure [])

foo1, foo2, foo3 :: String
foo1 = $(reify ''Foo1 >>= stringE . pprint)
foo2 = $(reify ''Foo2 >>= stringE . pprint)
foo3 = $(reify ''Foo3 >>= stringE . pprint)
foo4 = $(reify ''Foo4 >>= stringE . pprint)


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
module T14875 where

$([d| f :: Bool -> Bool
      f x = case x of
              (True :: Bool) -> True
              (False :: Bool) -> False

      g :: Bool -> Bool
      g x = (case x of
               True -> True
               False -> False) :: Bool
    |])


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE InstanceSigs #-}

module T14885a where

class Foo1 a where
  bar1 :: forall b. a -> b -> b
  bar1 _ x = (x :: b)

$([d| class Foo2 a where
        bar2 :: forall b. a -> b -> b
        bar2 _ x = (x :: b)

      instance Foo2 Int where
        bar2 :: forall b. Int -> b -> b
        bar2 _ x = (x :: b)
    |])


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module T14885b where

class Foo1 a where
  foo1         :: forall b. a -> b -> b
  default foo1 :: forall b. a -> b -> b
  foo1 _ x = (x :: b)

$([d| class Foo2 a where
        foo2         :: forall b. a -> b -> b
        default foo2 :: forall b. a -> b -> b
        foo2 _ x = (x :: b)
    |])


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

module T14885c where

pattern P1 :: forall a. a -> Maybe a
pattern P1 x <- Just x where
  P1 x = Just (x :: a)

$([d| pattern P2 :: forall a. a -> Maybe a
      pattern P2 x <- Just x where
        P2 x = Just (x :: a)
    |])


{-# LANGUAGE TemplateHaskell #-}
module T14888 where

import Language.Haskell.TH

foo :: $([t| (->) Bool Bool |])
foo x = x

class Functor' f where
  fmap' :: (a -> b) -> f a -> f b

instance Functor' ((->) r) where
  fmap' = (.)

$(return [])

functor'Instances :: String
functor'Instances = $(reify ''Functor' >>= stringE . pprint)


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -ddump-splices #-}
module T15243 where

data Unit = Unit

$([d| type family F (a :: k) :: k where
        F 'Unit = 'Unit
        F '(,)  = '(,)
        F '[]   = '[]
        F '(:)  = '(:)
    |])


{-# LANGUAGE TemplateHaskell #-}

module T10047A where

import Language.Haskell.TH

-- Passing var name to conE should fail.
x = $(conE 'id)


{-# LANGUAGE TemplateHaskell #-}

module T10047B where

import Language.Haskell.TH

-- Passing datacon name to varE should fail.
x = $(varE 'Just)


{-# LANGUAGE TemplateHaskell #-}

module T15321 where

foo :: String
foo = test

bar :: String
bar = $(_ "baz")


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module T15324 where

$([d| f :: forall a. (Show a => a) -> a
      f _ = undefined
    |])


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module T15331 where

import Data.Proxy

$([d| f :: Proxy (Int -> Int)
      f = Proxy @(Int -> Int)
    |])


{-# LANGUAGE TemplateHaskell #-}
module T15360a where

import Language.Haskell.TH

data T a b c = Mk a b c

bar :: $( return $ AppT (InfixT (ConT ''Int) ''T (ConT ''Bool)) (ConT ''Double) )
bar = Mk 5 True 3.14

baz :: $( return $ AppT (ParensT (ConT ''Maybe)) (ConT ''Int) )
baz = Just 5


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE StarIsType #-}
module T15360b where

import Data.Kind
import Data.Proxy

x :: Proxy $([t| * Double |])
x = Proxy

y :: Proxy $([t| 1 Int |])
y = Proxy

z :: Proxy $([t| Constraint Bool |])
z = Proxy

w :: Proxy $([t| '[] Int |])
w = Proxy


{-# LANGUAGE TemplateHaskell, TypeOperators, DataKinds #-}

module T15362 where

data Nat = Zero | Succ Nat

$( [d| type family a + b where
         Maybe Zero b = b
         Succ a + b = Succ (a + b) |] )


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T15365 where

$([d| type (|||) = Either

      (&&&) :: Bool -> Bool -> Bool
      (&&&) = (&&)

      type role (***)
      data (***)

      class (???)
      instance (???)

      data family ($$$)
      data instance ($$$)

      type family (^^^)
      type instance (^^^) = Int

      type family (###) where
        (###) = Int

      pattern (:!!!) :: Bool
      pattern (:!!!) = True
    |])


{-# LANGUAGE TemplateHaskell #-}
module T1541 where

$( [d|  infixr 3 +++
        (+++) :: Int -> Bool -> Bool
        (+++) x y = error "ruk"
   |])

-- This definition will only typecheck if the
-- the fixity of (+++) is infixr
foo p q r = p +++ q +++ r


{-# LANGUAGE TemplateHaskell #-}
module T15437 where

import T15437A

f :: Int
f = $$(foo)


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
module T15437A where

import Language.Haskell.TH.Syntax (Q, TExp)

get :: forall a. Int
get = 1

foo :: forall a. Q (TExp Int)
foo = [|| get @a ||]


{-# LANGUAGE TemplateHaskell #-}
module T15471 where

import T15471A

qux = $$(test_foo)

bar y = $$(list_foo [|| y ||] )

main = print (qux 5) >> print (bar True)


{-# LANGUAGE TemplateHaskell #-}
module T15471A where

import Language.Haskell.TH

foo1 x = x

test_foo :: Q (TExp (a -> a))
test_foo = [|| foo1 ||]

list_foo :: Q (TExp a) -> Q (TExp [a])
list_foo x = [|| [ $$x, $$x ] ||]


{-# LANGUAGE TemplateHaskell #-}
module Bug where

import Language.Haskell.TH

main :: IO ()
main = putStrLn $(recover (stringE "reifyFixity failed")
                          (do foo <- newName "foo"
                              _ <- reifyFixity foo
                              stringE "reifyFixity successful"))


{-# LANGUAGE TemplateHaskell #-}

module T15502 where

import Language.Haskell.TH.Syntax  (Lift(lift))

main = print ( $( lift (toInteger (maxBound :: Int) + 1) )
             , $( lift (minBound :: Int) )
             )


{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
module T15518 where

$([d| f :: Bool -> ()
      f = \case True  -> ()
                False -> ()
    |])


{-# LANGUAGE TemplateHaskell #-}
module T15550 where

$([d| myId :: a -> a
      myId x = x
      {-# NOINLINE [1] myId #-}
      {-# RULES "myId" forall x. myId x = x #-}
    |])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module T15572 where

import Language.Haskell.TH

$([d| type AbsoluteUnit1 = '() |])
$(pure [TySynD (mkName "AbsoluteUnit2") [] (ConT '())])


{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE TemplateHaskell #-}
module T15738 where

import Language.Haskell.TH
import System.IO

data Foo x = MkFoo x

$(do d <- [d| f :: (forall a. Eq (Foo a)) => Foo x -> Foo x -> Bool
              f = (==) |]
     runIO $ hPutStrLn stderr $ pprint d
     pure d)


{-# LANGUAGE TemplateHaskell #-}
module T15783A where

import T15783B

main = $$f


{-# LANGUAGE TemplateHaskell #-}
module T15783B(f) where

d = 0

f = [|| d ||]


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module T15792 where

import Data.Kind
import Language.Haskell.TH hiding (Type)
import System.IO

newtype T (f :: forall a. a -> Type) = MkT (f Bool)

$(pure [])

$(do info <- reify ''T
     runIO $ hPutStrLn stderr $ pprint info
     pure [])


{-# LANGUAGE TemplateHaskell #-}
module T15815A where

mkFoo tyQ = [d|
    foo :: a ~ $(tyQ) => a
    foo = undefined
  |]


{-# LANGUAGE TemplateHaskell, GADTs #-}
module T15815B where

import T15815A

mkFoo [t| Int -> Int |]


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module T15845 where

import Language.Haskell.TH
import System.IO

data family F1 a b
data instance F1 [a] b = MkF1

data family F2 a
data instance F2 a = MkF2

$(do i1 <- reify ''F1
     i2 <- reify ''F2
     runIO $ mapM_ (hPutStrLn stderr . pprint) [i1, i2]
     pure [])


{-# LANGUAGE TemplateHaskell #-}
module T15985 where

import Language.Haskell.TH

foo :: String
foo = $(stringE (pprint EqualityT))


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module T16133 where

import Data.Kind
import Language.Haskell.TH hiding (Type)

data P (a :: k) = MkP

$([d| f :: Int
      f = $(varE 'id `appTypeE` conT ''Int `appE` litE (integerL 42))

      type P' = $(conT ''P `appKindT` conT ''Type) |])


{-# LANGUAGE TemplateHaskell #-}

module Main where

import Language.Haskell.TH.Syntax
import Foreign.C.String
import Config -- from "ghc" package

$(do
   -- some targets (e.g. Darwin) require a "_" symbol prefix...
   addForeignSource LangAsm (if cLeadingUnderscore == "YES"
      then ".global \"_mydata\"\n\
           \_mydata:\n\
           \.ascii \"Hello world\\0\"\n"
      else ".global \"mydata\"\n\
           \mydata:\n\
           \.ascii \"Hello world\\0\"\n"
      )
   return [])

foreign import ccall "&mydata" mystring :: CString

main :: IO ()
main = putStrLn =<< peekCString mystring


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module T16183 where

import Data.Kind

$([d| type F1 = (Maybe :: Type -> Type) Int
      type F2 = (Int :: Type) -> (Int :: Type)
      type family F3 a where
        F3 (a :: Type) = Int
      newtype F4 = MkF4 (Int :: Type) |])


{-# LANGUAGE TemplateHaskell #-}
module T16195 where

import T16195A

main2 :: IO ()
main2 = return ()

main :: IO ()
main = $$foo

main3 :: IO ()
main3 = putStrLn ($$showC $$unitC)


{-# LANGUAGE TemplateHaskell #-}
module T16195A where

import Language.Haskell.TH

foo :: Q (TExp (IO ()))
foo = [|| return () ||]

showC :: Q (TExp (() -> String))
showC = [|| show ||]

unitC :: Q (TExp ())
unitC = [|| () ||]


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TemplateHaskell #-}
module T16293b where

import Control.Monad
import GHC.Exts
import Language.Haskell.TH

f :: ()
f = $(do PrimTyConI _ arity _ <- reify ''Proxy#
         unless (arity == 1) $
           fail $ "Unexpected arity for Proxy#: " ++ show arity
         [| () |])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module T16326_TH where

import Control.Monad.IO.Class
import Data.Kind
import Data.Proxy
import Language.Haskell.TH hiding (Type)
import System.IO

data Foo :: forall a -> a -> Type
type family Foo2 :: forall a -> a -> Type where
  Foo2 = Foo

$(do info <- reify ''Foo2
     liftIO $ hPutStrLn stderr $ pprint info

     dec <- [d| data Nested :: forall a. forall b -> forall c.
                               forall d -> forall e.
                               Proxy '[a,b,c,d,e] -> Type |]
     liftIO $ hPutStrLn stderr $ pprint dec
     pure dec)


{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH.Syntax (lift)
import T1830_3a

main :: IO ()
main = do
  print ($(lift algDT1) == algDT1)
  print ($(lift algDT2) == algDT2)
  print ($(lift algDT3) == algDT3)
  print ($(lift prim)   == prim)
  print ($(lift df1)    == df1)
  print ($(lift df2)    == df2)
  print ($(lift df3)    == df3)


{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeFamilies #-}
module T1830_3a where

import GHC.Exts
import Language.Haskell.TH.Syntax (Lift(..))

data AlgDT a b c = NormalCon a b
                 | RecCon { recCon1 :: a, recCon2 :: b}
                 | a :^: b
  deriving (Eq, Lift)

data Prim = Prim Char# Double# Int# Float# Word#
  deriving (Eq, Lift)

-- We can't test this for equality easily due to the unstable nature of
-- primitive string literal equality. We include this anyway to ensure that
-- deriving Lift for datatypes with Addr# in them does in fact work.
data AddrHash = AddrHash Addr#
  deriving Lift

data Empty deriving Lift

data family DataFam a b c

data instance DataFam Int b c = DF1 Int | DF2 b
  deriving (Eq, Lift)

newtype instance DataFam Char b c = DF3 Char
  deriving (Eq, Lift)

algDT1, algDT2, algDT3 :: AlgDT Int String ()
algDT1 = NormalCon 1 "foo"
algDT2 = RecCon 2 "bar"
algDT3 = 3 :^: "baz"

prim :: Prim
prim = Prim 'a'# 1.0## 1# 1.0# 1##

df1, df2 :: DataFam Int Char ()
df1 = DF1 1
df2 = DF2 'a'

df3 :: DataFam Char () ()
df3 = DF3 'b'


{-# LANGUAGE TemplateHaskell, FlexibleInstances,
          MultiParamTypeClasses, TypeSynonymInstances #-}
module Main where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

class Eq a => MyClass a
data Foo = Foo deriving Eq

instance MyClass Foo

data Bar = Bar
  deriving Eq

type Baz = Bar
instance MyClass Baz

data Quux a  = Quux a   deriving Eq
data Quux2 a = Quux2 a  deriving Eq
instance Eq a  => MyClass (Quux a)
instance Ord a => MyClass (Quux2 a)

class MyClass2 a b
instance MyClass2 Int Bool

$(return [])

main = do
    putStrLn $(do { info <- reify ''MyClass; lift (pprint info) })
    print $(isInstance ''Eq [ConT ''Foo] >>= lift)
    print $(isInstance ''MyClass [ConT ''Foo] >>= lift)
    print $ not $(isInstance ''Show [ConT ''Foo] >>= lift)
    print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one
    print $(isInstance ''MyClass [ConT ''Baz] >>= lift)
    print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one
    print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one
    print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift)
    print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift)


{-# LANGUAGE TemplateHaskell #-}
module ReifyPlusTypeInferenceBugs where

import Language.Haskell.TH
import System.IO

a = 1

$(return [])

b = $(do VarI _ t _ <- reify 'a
         runIO $ putStrLn ("inside b: " ++ pprint t)
         [| undefined |])

c = $([| True |])

$(return [])

d = $(do VarI _ t _ <- reify 'c
         runIO $ putStrLn ("inside d: " ++ pprint t)
         [| undefined |] )

$(do VarI _ t _ <- reify 'c
     runIO $ putStrLn ("type of c: " ++ pprint t)
     return [] )

e = $([| True |])

$(return [])

f = $(do VarI _ t _ <- reify 'e
         runIO $ putStrLn ("inside f: " ++ pprint t)
         [| undefined |] )

$(do VarI _ t _ <- reify 'e
     runIO $ putStrLn ("type of e: " ++ pprint t)
     return [] )

$( runIO $ do hFlush stdout
              hFlush stderr
              return [] )


{-# LANGUAGE TemplateHaskell #-}

-- Test Trac #2386

module T2386 where

import T2386_Lib

foo = $(makeOne)


{-# LANGUAGE TemplateHaskell #-}

module T2386_Lib(ExportedAbstract, makeOne) where

data ExportedAbstract = Yay String | NonYay Bool

makeOne = [| Yay "Yep" |]


{-# LANGUAGE TemplateHaskell #-}

-- Test Trac #2597 (first bug)

module ShouldCompile where
import T2597a_Lib

bug = $mkBug


{-# LANGUAGE TemplateHaskell #-}
-- Library module for T2597a

module T2597a_Lib where
import Language.Haskell.TH

mkBug :: ExpQ
mkBug = return $ CompE [BindS (VarP $ mkName "p") (ListE []), NoBindS
                         (VarE $ mkName "p")]


{-# LANGUAGE TemplateHaskell #-}

-- Test Trac #2597 (second bug)

module ShouldCompile where
import T2597b_Lib

bug2 = $mkBug2


{-# LANGUAGE TemplateHaskell #-}
-- Library module for T2597b

module T2597b_Lib where
import Language.Haskell.TH

mkBug2 :: ExpQ
mkBug2 = return $ DoE []


{-# LANGUAGE TemplateHaskell #-}

-- Trac #2674

module ShouldFail where

import Language.Haskell.TH

$(return [FunD (mkName "foo") []])


{-# LANGUAGE TemplateHaskell #-}
module T2685 where

import T2685a

$( th )


{-# LANGUAGE TemplateHaskell #-}
module T2685a (th) where

import Language.Haskell.TH

newtype NT = C (() -> ())

th :: Q [Dec]
th = [d| foo = C undefined |]


{-# LANGUAGE TemplateHaskell #-}

module T2700 where
import Language.Haskell.TH
import System.IO

$( do { d <- sigD (mkName "foo") [t| (Int -> Bool) -> Bool |]
      ; runIO (hPutStrLn stderr (pprint d))
      ; return [] }
  )


{-# LANGUAGE TemplateHaskell #-}
module Fixity where

class MyClass a where
    (.*.) :: a -> a -> a

f x = x

$( [d| x = undefined |] )

infixr 3 .*.
f :: Int -> Int


{-# OPTIONS -XTemplateHaskell #-}
module TH( x ) where
import Language.Haskell.TH

data T f = MkT (f Int)

x = $(return (SigE (VarE 'x) (AppT (ConT ''T) (AppT ArrowT (ConT ''Int)))))


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE RankNTypes, FlexibleContexts, ImplicitParams, TemplateHaskell #-}

-- This test makes sure TH understands types where
-- there is a predicate but no 'forall'
--
-- There are two tests in here; both should be fine
-- Trac ticket: #3100

module T3100 where

import Language.Haskell.TH

flop :: Ord Int => Int -> Int
-- Weird test case: (Ord Int) is simplifiable and redundant
flop x = x

$(do { t <- reify 'flop; return [] })

type T a = Eq a => a

$(do { reify ''T; return []})


{- LANGUAGE TemplateHaskell #-}

-- Template Haskell type splices
module T3177 where

f :: $(id [t| Int |])
f = 3

class C a where
  op :: a -> a

instance C a => C ($([t| Maybe |]) a) where
  op x = fmap op x


{- LANGUAGE TemplateHaskell #-}

-- Template Haskell type splices
-- Should fail, with a decent error message

module T3177a where

f :: $(id [t| Int Int |])
f = 3

g :: Int Int
g = 3


{-# LANGUAGE TemplateHaskell,ForeignFunctionInterface #-}

module T3319 where

import Foreign.Ptr
import Language.Haskell.TH

$(return [ForeignD (ImportF CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))])

-- Should generate the same as this:
foreign import ccall unsafe "&" foo1 :: Ptr ()


{-# LANGUAGE TemplateHaskell #-}
module T3395 where

import Language.Haskell.TH

foo = $(return $
     CompE
         [NoBindS (VarE $ mkName "undefined")
         ,BindS (VarP $ mkName "r1") (VarE $ mkName "undefined") ])


{-# LANGUAGE TemplateHaskell #-}

-- Test Trac #3467

module T3467 where

import Language.Haskell.TH
import Foreign

sizeq :: Name -> Q Exp
sizeq n = [| sizeOf (undefined :: $(conT n)) |]


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices #-}
module T3600 where
import T3600a
$(test)


{-# LANGUAGE TemplateHaskell #-}
module T3600a where

import Language.Haskell.TH

test :: Q [Dec]
test = do
     let args1 = [] :: [String]
         args2 = [] :: String
         args3 = "x" :: String
         body = [| (testFun1 args1, testFun2 args2, testFun2 args3)  |]
         decNm = mkName "myFunction"
     (:[]) `fmap` funD decNm [clause [] (normalB body) []]

testFun1 :: [String] -> String
testFun1 _ = "hello"

testFun2 :: String -> String
testFun2 _ = "goodbye"


{-# LANGUAGE TemplateHaskell #-}

module THBug1 where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

data HCons a b = HCons a b
data HNil = HNil

mhlt :: [Q Type] -> Q Type
mhlt xss = [t| $(foldThing xss)|]
  where
    foldThing (x:xs) = [t| HCons $x $(foldThing xs)|]
    foldThing []     = [t| HNil |]

mhlt1 :: [Int] -> Q Exp
mhlt1 xss = [| $(foldThing1 xss) |]
  where
    foldThing1 (x:xs) = [| x : $(foldThing1 xs)|]
    foldThing1 [] = [| [] |]


{-# LANGUAGE TemplateHaskell #-}
module T3899 where

import T3899a

f = $(nestedTuple 3)


{-# LANGUAGE TemplateHaskell #-}
module T3899a where

import Language.Haskell.TH
import Control.Monad

data Cons a b = Cons a b
data Nil = Nil

nestedTuple n = do
     xs <- replicateM n (newName "x")
     return $ LamE [foldr (\v prev -> ParensP (ConP 'Cons [VarP v,prev]))
                       (ConP 'Nil []) xs]
                   (TupE $ map VarE xs)


{-# LANGUAGE EmptyDataDecls, TypeFamilies, TemplateHaskell #-}
module Main where

import Language.Haskell.TH hiding (Type)
import Data.Kind (Type)

type family S :: (Type -> (Type -> Type -> Type))
              -> (Type -> Type) -> Type

$(return [])

test :: String
test = $(do
        test <- [d|
                type family T :: (Type -> (Type -> Type -> Type))
                              -> (Type -> Type) -> Type |]
        blah <- reify ''S
        return (LitE (StringL (pprint test ++ "\n" ++ pprint blah))))

main = putStrLn test


{-# LANGUAGE TemplateHaskell #-}
module T4124 where

class Storable a where
data X = X
[d| instance Storable $( [t| X |] ) where |]


{-# LANGUAGE TemplateHaskell #-}
module T4128 where

import Language.Haskell.TH
class C a where
data X = X
fmap return $ instanceD (cxt []) [t| C $(conT ''X) |] []


{-# LANGUAGE TypeFamilies,TemplateHaskell #-}
module Bug where

import Language.Haskell.TH
import System.IO

class C a where
    type T a

$(do { ds <- [d|
                 instance C (Maybe a) where
                    type T (Maybe a) = Char
             |]
     ; runIO $ do { putStrLn (pprint ds); hFlush stdout }
     ; return ds })


{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies,
             FlexibleInstances #-}

module T4135a where

import Control.Monad
import Language.Haskell.TH

class Foo a where
    type FooType a

createInstance' :: Q Type -> Q Dec
createInstance' t = liftM head [d|
    instance Foo $t where
      type FooType $t = String |]


{-# LANGUAGE TemplateHaskell, GADTs #-}

module T4188 where

import Language.Haskell.TH
import System.IO

class C a where {}

data T1 a where
  MkT1 :: a -> b -> T1 a

data T2 a where
  MkT2 :: (C a, C b) => a -> b -> T2 a

data T3 x where
  MkT3 :: (C x, C y) => x -> y -> T3 (x,y)

$(do { dec1 <- reify ''T1
     ; runIO (putStrLn (pprint dec1))
     ; dec2 <- reify ''T2
     ; runIO (putStrLn (pprint dec2))
     ; dec3 <- reify ''T3
     ; runIO (putStrLn (pprint dec3))
     ; runIO (hFlush stdout)
     ; return [] })


{-# LANGUAGE TemplateHaskell #-}
module T4233 where
import Language.Haskell.TH

w :: Q Type
w = varT (mkName "w")

f :: Q Type
f = [t| $w -> $w |]


{-# LANGUAGE TemplateHaskell #-}
module T4364 where

data Z

type N0 = $( [t| Z |] )
type N1 = $( [t| Z |] )


{-# OPTIONS -XTemplateHaskell #-}
module TH( x ) where
import Language.Haskell.TH

x = $(return (LitE (StringL "hello\ngoodbye\nand then")))


{-# LANGUAGE TemplateHaskell #-}
module Foo where

import Language.Haskell.TH

x :: Int
x = let args = [| show $(varE (mkName "x")) |]
    in undefined


{-# LANGUAGE TemplateHaskell #-}
module T5037 where
import Language.Haskell.TH
import System.IO

$( do ds <- [d|  f :: Maybe Int -> Int
                 f Nothing = 3
                 f (Just x) = $(varE (mkName "x"))
            |]
      runIO $ (putStrLn (pprint ds) >> hFlush stdout)
      return ds )


{-# LANGUAGE TemplateHaskell #-}
module T5126 where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

f :: Q [Dec]
f =
    [d|
        x2 :: $(conT ''Int)
        x2 = undefined
    |]


{-# LANGUAGE GADTs #-}

module T5217 where
import Language.Haskell.TH

$([d| data T a b where { T1 :: Int -> T Int Char
                       ; T2 :: a -> T a a
                       ; T3 :: a -> T [a] a
                       ; T4 :: a -> b -> T b [a] } |])


{-# LANGUAGE TemplateHaskell #-}

module T5290 where

import Language.Haskell.TH

$( let n = mkName "T"
   in return [DataD [] n [] Nothing
                [NormalC n [(Bang SourceUnpack SourceStrict,ConT ''Int)]] []] )


{-# LANGUAGE TemplateHaskell #-}
module T5358 where

import Language.Haskell.TH

t1, t2 :: Int
t1 x = x
t2 x = x

prop_x1 x = t1 x == t2 x

$(return [])

runTests = $( do VarI _ t _ <- reify (mkName "prop_x1")
                 error $ ("runTest called error: " ++ pprint t)
            )


{-# LANGUAGE TemplateHaskell #-}

module T5362() where

import System.IO
import Language.Haskell.TH

$(
     do fName <- newName "f"
        gName <- newName "g"
        let gExp = varE gName

        sdf <- sigD fName [t| () |]
        sdg <- sigD gName [t| () |]
        fdf <- funD fName [clause [] (normalB [| undefined $gExp |]) []]
        fdg <- funD gName [clause [] (normalB [| undefined       |]) []]
        let ds = [sdf, fdf, sdg, fdg]
        runIO $ do { putStrLn (pprint ds); hFlush stdout }
        return ds
     )


{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH

$( [d| g = 0
       h = $( return $ LamE [VarP (mkName "g")] (VarE 'g) ) |] )
         -- The 'g should bind to the g=0 definition

-- Should print 0, not 1!
main = print (h 1)


{-# LANGUAGE TemplateHaskell #-}

module T5404 where

foobar :: Int
foobar = $([|
      let
        bar :: Int
        bar = 5
      in bar
   |])


{-# LANGUAGE TemplateHaskell #-}
module Main where

$([d| instance Show (a -> b) where
         showsPrec _ _ = showString "<function>"
  |])

main = print id


{-# LANGUAGE TemplateHaskell #-}

module T5434 where

import T5434a

$(genShadow1)

v :: Bool
v = True

$(genShadow2)


{-# LANGUAGE TemplateHaskell #-}

module T5434a where

import Language.Haskell.TH

genShadow1 :: Q [Dec]
genShadow1 =
  [d| x :: Char
      x = 'x'
    |]

genShadow2 :: Q [Dec]
genShadow2 =
  [d| z :: Char
      z = succ x
        where x = 'y'
    |]


{-# LANGUAGE TemplateHaskell, KindSignatures, FlexibleInstances #-}

module T5452 where

import Language.Haskell.TH hiding (Type)
import Data.Kind (Type)

class C (f :: Type -> Type)
class D (f :: Type -> Type)

instance C ((,) Int)

$(do { ClassI _ [inst_dec] <- reify ''C
     ; let InstanceD o cxt (AppT _ ty) _ = inst_dec
     ; return [InstanceD o cxt
                         (foldl AppT (ConT ''D) [ty])
                         []
              ] })


{-# LANGUAGE TemplateHaskell #-}

module T5508 where

import Language.Haskell.TH

thb = $(do { let x = mkName "x"
                 v = return (LamE [VarP x] $ VarE x)
           ; [| $v . id |] })


{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
import qualified T5555_Lib as L

test :: String
test = [L.s|hello world|]

main :: IO ()
main = putStrLn test


module T5555_Lib(s) where

import Language.Haskell.TH
import Language.Haskell.TH.Quote

s :: QuasiQuoter
s = QuasiQuoter expr undefined undefined undefined

expr :: String -> Q Exp
expr = stringE


{-# LANGUAGE TemplateHaskell #-}
module T5597 where
import T5597a( f )

g = $(f [t| (Int, Int) |])


{-# LANGUAGE TemplateHaskell #-}
module T5597a where
import Language.Haskell.TH

f :: Q Type -> Q Exp
f t = [| (3,4) :: $t |]


{-# LANGUAGE TemplateHaskell #-}

module T5665 where

import T5665a

data Record = Record { recordField :: Int }

$(doSomeTH "SomeType" ''Int)


module T5665a where

import Language.Haskell.TH

doSomeTH s tp = return [NewtypeD [] n [] Nothing (NormalC n
        [(Bang NoSourceUnpackedness NoSourceStrictness, ConT tp)]) []]
   where n = mkName s


{-# LANGUAGE TemplateHaskell #-}
module T5700 where

import T5700a

data D = D

$(mkC ''D)


{-# LANGUAGE TemplateHaskell #-}
module T5700a where

import Language.Haskell.TH

class C a where
  inlinable :: a -> ()

mkC :: Name -> Q [Dec]
mkC n = return
  [InstanceD Nothing [] (AppT (ConT ''C) (ConT n))
    [ FunD 'inlinable [Clause [WildP] (NormalB (ConE '())) []],
      PragmaD (InlineP 'inlinable Inline FunLike AllPhases)
    ]
  ]


{-# LANGUAGE TemplateHaskell #-}
module T5737 where

import Language.Haskell.TH
makeAlpha n = [d| data Alpha = Alpha $(conT n) deriving (Show, Read) |]


{-# LANGUAGE TemplateHaskell #-}
module T5795 where

import Language.Haskell.TH

ty :: Q Type
ty = [t| Int |]

f :: $ty
f = undefined


{-# LANGUAGE GADTSyntax, TemplateHaskell, KindSignatures #-}

module T5882 where

import Data.Kind (Type)

data Foo :: Type -> Type where
   Foo :: a -> Foo a

$( [d|  data Bar :: Type -> Type where
           Bar :: a -> Bar a
  |] )

f (Bar x) = Foo x


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies    #-}
module T5883 where

import Language.Haskell.TH

$( [d|
        data Unit = Unit
        instance Show Unit where
          show _ = ""
          {-# INLINE show #-}
  |])


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module T5886 where

import T5886a

$(bang)


{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module T5886a where

import Language.Haskell.TH hiding (Type)
import Data.Kind (Type)

class C Î± where
  type AT Î± âˆ· Type

bang âˆ· DecsQ
bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int))
                [TySynInstD (TySynEqn Nothing (AppT (ConT ''AT) (ConT ''Int)) (ConT ''Int))]]


{-# LANGUAGE TemplateHaskell #-}
module T5968 where

data Bar a = Bar $( [t| a |] )


{-# LANGUAGE TemplateHaskell #-}
module T5971 where

import Language.Haskell.TH

_ = $(newName "x" >>= varE)


{-# LANGUAGE TemplateHaskell #-}

$( error ("foo " ++ error "bar") )


{-# LANGUAGE TemplateHaskell #-}

module T5984 where

import T5984_Lib

$nt
$dt


{-# LANGUAGE TemplateHaskell #-}

module T5984_Lib where

import Language.Haskell.TH

nt :: Q [Dec]
nt = return [NewtypeD [] foo [] Nothing (NormalC foo
      [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]) []]
  where foo = mkName "Foo"

dt :: Q [Dec]
dt = return [DataD [] bar [] Nothing [NormalC bar
      [(Bang NoSourceUnpackedness NoSourceStrictness, ConT ''Int)]] []]
  where bar = mkName "Bar"


{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds #-}

module T6005 where

$( [d|
   data Nat = Zero | Succ Nat
   data Proxy a = Proxy
   foo :: Proxy 'Zero
   foo = foo
   |])


{-# LANGUAGE TemplateHaskell #-}

module T6005a where

-- The point here is that we don't need to generate the
-- derived code inside the bracket; doing so is troublesome
-- and it should never be type incorrect, so it's also a
-- waste of effort.

$( [d|
   data Nat = Zero | Succ Nat deriving( Show )
   |] )

foo :: String
foo = show (Succ Zero)


{-# LANGUAGE TypeFamilyDependencies, DataKinds, UndecidableInstances,
             PolyKinds #-}
module T6018th where

import Language.Haskell.TH

-- Test that injectivity works correct with TH. This test is not as exhaustive
-- as the original T6018 test.

-- type family F a b c = (result :: k) | result -> a b c
-- type instance F Int  Char Bool = Bool
-- type instance F Char Bool Int  = Int
-- type instance F Bool Int  Char = Char
$( return
   [ OpenTypeFamilyD (TypeFamilyHead
       (mkName "F")
       [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ]
       (TyVarSig (KindedTV (mkName "result") (VarT (mkName "k"))))
       (Just $ InjectivityAnn (mkName "result")
                             [(mkName "a"), (mkName "b"), (mkName "c") ]))
   , TySynInstD
       (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "F")) (ConT (mkName "Int")))
                       (ConT (mkName "Char"))) (ConT (mkName "Bool")))
                 (ConT (mkName "Bool")))

   , TySynInstD
       (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "F")) (ConT (mkName "Char")))
                       (ConT (mkName "Bool"))) (ConT (mkName "Int")))
                 (ConT (mkName "Int")))
   , TySynInstD
       (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "F")) (ConT (mkName "Bool")))
                       (ConT (mkName "Int"))) (ConT (mkName "Char")))
                 (ConT (mkName "Char")))
   ] )

-- this is injective - a type variables mentioned on LHS is not mentioned on RHS
-- but we don't claim injectivity in that argument.
--
-- type family J a (b :: k) = r | r -> a
---type instance J Int b = Char
$( return
   [ OpenTypeFamilyD (TypeFamilyHead
       (mkName "J")
       [ PlainTV (mkName "a"), KindedTV (mkName "b") (VarT (mkName "k")) ]
       (TyVarSig (PlainTV (mkName "r")))
       (Just $ InjectivityAnn (mkName "r") [mkName "a"]))
   , TySynInstD
       (TySynEqn Nothing (AppT (AppT (ConT (mkName "J")) (ConT (mkName "Int")))
                       (VarT (mkName "b")))
                 (ConT (mkName "Char")))
   ] )

-- Closed type families

-- type family IClosed (a :: *) (b :: *) (c :: *) = r | r -> a b where
--     IClosed Int  Char Bool = Bool
--     IClosed Int  Char Int  = Bool
--     IClosed Bool Int  Int  = Int

$( return
   [ ClosedTypeFamilyD (TypeFamilyHead
       (mkName "I")
       [ KindedTV (mkName "a") StarT, KindedTV (mkName "b") StarT
       , KindedTV (mkName "c") StarT ]
       (TyVarSig (PlainTV (mkName "r")))
       (Just $ InjectivityAnn (mkName "r") [(mkName "a"), (mkName "b")]))

       [ TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "I")) (ConT (mkName "Int")))
                                      (ConT (mkName "Char"))) (ConT (mkName "Bool")))
                          (ConT (mkName "Bool"))

       , TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "I")) (ConT (mkName "Int")))
                                      (ConT (mkName "Char"))) (ConT (mkName "Int")))
                          (ConT (mkName "Bool"))

       , TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "I")) (ConT (mkName "Bool")))
                                      (ConT (mkName "Int"))) (ConT (mkName "Int")))
                          (ConT (mkName "Int"))
       ]
   ] )

-- reification test
$( do { decl@([ClosedTypeFamilyD (TypeFamilyHead _ _ _ (Just inj)) _]) <-
               [d| type family Bak a = r | r -> a where
                        Bak Int  = Char
                        Bak Char = Int
                        Bak a    = a |]
      ; return decl
      }
 )

-- Check whether incorrect injectivity declarations are caught

-- type family I a b c = r | r -> a b
-- type instance I Int  Char Bool = Bool
-- type instance I Int  Int  Int  = Bool
-- type instance I Bool Int  Int  = Int
$( return
   [ OpenTypeFamilyD (TypeFamilyHead
       (mkName "H")
       [ PlainTV (mkName "a"), PlainTV (mkName "b"), PlainTV (mkName "c") ]
       (TyVarSig (PlainTV (mkName "r")))
       (Just $ InjectivityAnn (mkName "r")
                             [(mkName "a"), (mkName "b") ]))

   , TySynInstD
         (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "H")) (ConT (mkName "Int")))
                                       (ConT (mkName "Char"))) (ConT (mkName "Bool")))
                           (ConT (mkName "Bool")))

   , TySynInstD
         (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "H")) (ConT (mkName "Int")))
                                       (ConT (mkName "Int"))) (ConT (mkName "Int")))
                           (ConT (mkName "Bool")))

   , TySynInstD
         (TySynEqn Nothing (AppT (AppT (AppT (ConT (mkName "H")) (ConT (mkName "Bool")))
                                       (ConT (mkName "Int"))) (ConT (mkName "Int")))
                           (ConT (mkName "Int")))
   ] )


{-# LANGUAGE TemplateHaskell #-}
module T6114 where
import Language.Haskell.TH

$(do
   xName <- newName "x"
   instanceType <- [t| $(varT xName) |]
   _ <- reifyInstances ''Eq [instanceType]
   return []
  )


{-# LANGUAGE TemplateHaskell #-}
module T7021 where

import T7021a

func :: a -> Int
func = $(test)


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ConstraintKinds, TemplateHaskell, PolyKinds, TypeFamilies, RankNTypes #-}

module T7021a where

import GHC.Exts
import Language.Haskell.TH

type IOable a = (Show a, Read a)
type family ALittleSilly :: Constraint

data Proxy a = Proxy

foo :: IOable a => a
foo = undefined

baz :: a b => Proxy a -> b
baz = undefined

bar :: ALittleSilly  => a
bar = undefined

test :: Q Exp
test = do
    Just fooName <- lookupValueName "foo"
    Just bazName <- lookupValueName "baz"
    Just barName <- lookupValueName "bar"
    reify fooName
    reify bazName
    reify barName
    [t| forall a. (Show a, (Read a, Num a)) => a -> a |]
    [| \_ -> 0 |]


{-# LANGUAGE TemplateHaskell #-}

module Main where

import T7064a

$(decls)

main = hsToTh


{-# LANGUAGE TemplateHaskell #-}

module T7064a (decls, hsToTh) where

import Language.Haskell.TH

decls = [d|
    f1 x = 1; f2 x = 2; f3 x = 3
    {-# INLINE f1 #-}
    {-# INLINE [2] f2 #-}
    {-# INLINE CONLIKE [~2] f3 #-}
    g1 x = 1; g2 x = 2; g3 x = 3
    {-# SPECIALISE g1 :: Int -> Int #-}
    {-# SPECIALISE [2] g2 :: Int -> Int #-}
    {-# SPECIALISE INLINE [~2] g3 :: Int -> Int #-}
    data T a = T a
    instance Eq a => Eq (T a) where
      {-# SPECIALISE instance Eq (T Int) #-}
      (T x) == (T y) = x == y
    {-# RULES
          "rule1" fromIntegral = id :: a -> a ;
          "rule2" [1] forall (x :: a) . fromIntegral x = x ;
          "rule3" [~1] forall (x :: a) . fromIntegral x = x
      #-}
  |]

hsToTh = do
  decls' <- runQ decls
  mapM (print . ppr) decls'


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fwarn-name-shadowing #-}

-- Should not produce a name-shadowing warning (GHC 7.4 did)

module T7092 where

import T7092a

blah = $(code)


{-# LANGUAGE TemplateHaskell #-}
module T7092a where

import Language.Haskell.TH

code :: Q Exp
code = do
  n1 <- newName "foo"
  n2 <- newName "foo"
  letE [valD (varP n1) (normalB [| (1 :: Int) |]) []]
       $ letE [valD (varP n2) (normalB [| (2 :: Int) |]) []]
       $ appE (appE [| ((+) :: Int -> Int -> Int)|] (varE n1)) (varE n2)


{-# LANGUAGE TemplateHaskell #-}

module T7241 where

import Language.Haskell.TH

$(newName "Foo" >>= \o -> return [DataD [] o [] Nothing [RecC o []] []])


{-# OPTIONS_GHC -fdefer-type-errors #-}
{-# LANGUAGE TemplateHaskell #-}

module T7276 where

x = $( [d| y = 3 |] )


{-# LANGUAGE TemplateHaskell #-}

module T7445 where
import T7445a

moo = $(foo)


{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
module T7445a ( foo ) where

import Data.Data
import Language.Haskell.TH.Quote
import Language.Haskell.TH

data Expr
    =  IntExpr Integer
    deriving (Show, Typeable, Data)

foo :: ExpQ
foo = dataToExpQ (const Nothing) (IntExpr 1)


{-# LANGUAGE DataKinds, KindSignatures, PolyKinds, TypeFamilies, TemplateHaskell #-}

module T7477 where

import Language.Haskell.TH

type family F (a :: k)
type instance F Int = Bool

$( do { info <- reifyInstances ''F [ConT ''Int]
      ; reportWarning (pprint info)
      ; return [] })


{-# LANGUAGE TemplateHaskell #-}

module T7484 where

import Language.Haskell.TH

$( return [ ValD (VarP (mkName "a ")) (NormalB (LitE (IntegerL 5))) [] ] )


{-# OPTIONS_GHC -ddump-rn -ddump-splices #-}
{-# LANGUAGE TemplateHaskell, TypeFamilies #-}
module T7532 where

import Language.Haskell.TH
import T7532a

instance C Bool where
  data D Bool = MkD

$(bang')


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module T7532a where

import Language.Haskell.TH

class C a where
     data D a

bang' :: DecsQ
bang' = return [
     InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
         DataInstD [] Nothing (AppT (ConT ''D) (ConT ''Int)) Nothing [
             NormalC (mkName "T") []] []]]


{-# LANGUAGE TemplateHaskell, TypeOperators #-}

module T7667 where

import Language.Haskell.TH

$( return [ TySynD (mkName "+") [PlainTV (mkName "a"), PlainTV (mkName "b")]
                   (AppT (AppT (ConT ''Either) (VarT $ mkName "a")) (VarT $ mkName "b")) ] )


{-# LANGUAGE TemplateHaskell #-}

module T7667a where

import Language.Haskell.TH

   -- to be correct, this should be ConE, not VarE!
false = $( return $ VarE (mkName "False") )


{-# LANGUAGE EmptyCase, TemplateHaskell, LambdaCase #-}

module T7681 where

data Void

foo :: Void -> a
foo x = $( [| case x of {} |] )

bar :: Void -> a
bar = $( [| \case {} |] )


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

class C a
instance C Int

type D a = C a

$(return [])

main = print $(
  do isCInst <- isInstance ''C [ConT ''Int]
     isDInst <- isInstance ''D [ConT ''Int]
     lift (isCInst,isDInst))


{-# LANGUAGE TemplateHaskell, TypeFamilies #-}

module T8028 where

import T8028a

import Language.Haskell.TH

$(x)

-- Check that the empty closed type family F produced by $(x) can
-- subsequently be reified
$(do f <- reify ''F
     case f of
       FamilyI (ClosedTypeFamilyD _ []) _ -> return []
       _ -> error $ show f
 )


module T8028a where

import Language.Haskell.TH

x = do n <- newName "F"
       return [ClosedTypeFamilyD (TypeFamilyHead n [] NoSig Nothing) []]


{-# LANGUAGE TemplateHaskell, RankNTypes, TypeOperators, DataKinds, PolyKinds,
             GADTs #-}

module T8031 where

import Data.Proxy
import Data.Kind

data SList :: [k] -> Type where
  SCons :: Proxy h -> Proxy t -> SList (h ': t)

$( [d| foo :: forall k (a :: k). Proxy a
           -> forall (b :: [k]). Proxy b
           -> SList (a ': b)
       foo a b = SCons a b |] )


{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}

module T8100 where

import Language.Haskell.TH

data Foo a = Foo a
data Bar = Bar Int

$( do decs <- [d| deriving instance Eq a => Eq (Foo a)
                  deriving instance Ord a => Ord (Foo a) |]
      return ( StandaloneDerivD Nothing [] (ConT ''Eq `AppT` ConT ''Bar)
             : StandaloneDerivD Nothing [] (ConT ''Ord `AppT` ConT ''Bar)
             : decs ) )

blah :: Ord a => Foo a -> Foo a -> Ordering
blah = compare

buzz :: Bar -> Bar -> Ordering
buzz = compare


{-# LANGUAGE TemplateHaskell, ParallelListComp #-}

module Main where

list = [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,6..50] ]

list' = $( [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,6..50] ] |] )

main = do putStrLn (show list)
          putStrLn (show list')
          putStrLn $ show (list == list')


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}

main :: IO ()
main = return ()


{-# LANGUAGE TemplateHaskell, DataKinds #-}

import Language.Haskell.TH

type T = $(return $ LitT $ NumTyLit (-1))


{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds #-}
{-# OPTIONS_GHC -Wall #-}

module T8499 where

import Language.Haskell.TH

$( do TyConI (DataD _ _ [KindedTV tvb_a _] _ _ _) <- reify ''Maybe
      my_a <- newName "a"
      return [TySynD (mkName "SMaybe")
                     [KindedTV my_a (AppT (ConT ''Maybe) (VarT tvb_a))]
                     (TupleT 0)] )


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}

module T8507 where

type Stringy1 a = (Read a, Show a)

$([d|type Stringy2 a = (Read a, Show a) |])


{-# LANGUAGE TemplateHaskell #-}
module T8540 where

import T8540a

baz :: Int
baz = $foo


{-# LANGUAGE TemplateHaskell #-}
module T8540a (foo) where

import Language.Haskell.TH

foo :: Q Exp
foo = [| bar |]

bar :: Int
bar = 5


{-# LANGUAGE TemplateHaskell #-}
module T8577 where

import Language.Haskell.TH

import T8577a

foo2 :: A Bool
foo2 = $$(y)


{-# LANGUAGE TemplateHaskell #-}
module T8577a where
import Language.Haskell.TH

data A a = A

x :: Q (TExp (A a))
x = [|| A ||]

y :: Q (TExp (A Int))
y = x


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -dth-dec-file #-}
module T8624 (THDec(..)) where

import Language.Haskell.TH

$(return [DataD [] (mkName "THDec") [] Nothing
          [NormalC (mkName "THDec") []] []])


{-# LANGUAGE TemplateHaskell, PatternSynonyms #-}

module T8759 where

import Language.Haskell.TH

pattern P = ()

$( do info <- reify 'P
      reportWarning (show info)
      return [] )


{-# LANGUAGE TemplateHaskell, RankNTypes, GADTs, PatternSynonyms #-}

module T8761 where

{- Testsuite for pattern synonyms as implemented by ticket #8761 -}

import Control.Monad
import Language.Haskell.TH
import System.IO

data Ex         where MkEx       :: forall a. a -> Ex
data ExProv     where MkExProv   :: forall a. (Show a) => a -> ExProv
data UnivProv a where MkUnivProv :: forall a. (Show a) => a -> UnivProv a

{- Test manual construction and pretty printing of pattern synonyms -}
do
  [qx1,qy1,qz1] <- mapM (\i -> newName $ "x" ++ show i) [1,2,3]
  let nm1       = mkName "Q1"
      prefixPat = patSynD nm1 (prefixPatSyn [qx1,qy1,qz1]) unidir
        (tupP [tupP [varP qx1, varP qy1], listP [varP qz1], wildP, wildP])

  [qx2,qy2] <- mapM (\i -> newName $ "x" ++ show i) [1,2]
  let nm2      = mkName "Q2"
      infixPat = patSynD nm2 (infixPatSyn qx2 qy2) implBidir
        (tupP [tupP [varP qx2, varP qy2]])

  let nm3           = mkName "Q3"
      [qx3,qy3,qz3] = map mkName ["qx3", "qy3", "qz3"]
      patP          = tupP [tupP [varP qx3, varP qy3], listP [varP qz3]]
      patE          = tupE [tupE [varE qx3, varE qy3], listE [varE qz3]]
      cls           = clause [varP qx3, varP qy3, varP qz3] (normalB patE) []
      recordPat     = patSynD nm3 (recordPatSyn [qx3,qy3,qz3])
                        (explBidir [cls]) patP

  pats <- sequence [prefixPat, infixPat, recordPat]
  -- pretty print the pattern synonyms:
  mapM_ (runIO . hPutStrLn stderr . pprint) pats
  -- splice in the pattern synonyms
  return pats

{- Test prefix pattern synonyms -}
[d|
 pattern P1 x y z <- ((x,y), [z], _, _)   -- unidirectional pattern
 pattern P2 x y z =  ((x,y), [z])         -- implicit bidirectional pattern
 pattern P3 x y z <- ((x,y), [z]) where   -- explicit bidirectional pattern
   P3 x y z = ((x,y), [z]) |]

{- Test infix pattern synonyms -}
[d|
 pattern x :*: y <- ((x,_), [y])
 pattern x :+: y =  (x,y)
 pattern x :~: y <- (x,y) where
   x :~: y = (x,y) |]

{- Test record pattern synonyms -}
[d|
 pattern R1 {x1, y1} <- ((x1,_), [y1])
 getX1 = x1 ((1, 2), [3]) -- should yield 1
 getY1 = y1 ((1, 2), [3]) -- should yield 3
 pattern R2 {x2, y2} =  (x2, [y2])
 pattern R3 {x3, y3} <- (x3, [y3]) where
   R3 x y = (x, [y]) |]

--x1 = "no, no, no"
--y1 = "no, no, no"

getX1' = x1 ((1, 2), [3]) -- should yield 1
getY1' = y1 ((1, 2), [3]) -- should yield 3

{- Test splicing unidirectional pattern synonyms with different types -}
[d|
 pattern P :: Bool
 pattern P <- True

 pattern Pe :: () => forall a. a -> Ex
 pattern Pe x <- MkEx x

 pattern Pu :: forall a. a -> a
 pattern Pu x <-  x

 pattern Pue :: forall a. () => forall b. a -> b -> (a, Ex)
 pattern Pue x y <- (x, MkEx y)

 pattern Pur :: forall a. (Num a, Eq a) => a -> [a]
 pattern Pur x <- [x, 1]

 pattern Purp :: forall a b. (Num a, Eq a) =>
                 Show b => a -> b -> ([a], UnivProv b)
 pattern Purp x y <- ([x, 1], MkUnivProv y)

 pattern Pure :: forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex)
 pattern Pure x y <- ([x, 1], MkEx y)

 pattern Purep :: forall a. (Num a, Eq a) =>
                 forall b. Show b => a -> b -> ([a], ExProv)
 pattern Purep x y <- ([x, 1], MkExProv y)

 pattern Pep :: () => forall a. Show a => a -> ExProv
 pattern Pep x <- MkExProv x

 pattern Pup :: forall a. () => Show a => a -> UnivProv a
 pattern Pup x <- MkUnivProv x

 pattern Puep :: forall a. () => forall b. (Show b) => a -> b -> (ExProv, a)
 pattern Puep x y <- (MkExProv y, x) |]

{- Test reification of different pattern synonyms and their types -}
do
  infos <- mapM reify [ 'P, 'Pe, 'Pu, 'Pue, 'Pur, 'Purp
                      , 'Pure, 'Purep, 'Pep, 'Pup, 'Puep ]
  mapM_ (runIO . hPutStrLn stderr . pprint) infos
    -- NB. use stderr rather than stdout, because GHC does not
    -- guarantee to flush stdout after TH code.  In particular when
    -- the output is going to a file, and we're using GHC with the
    -- runtime linker or with -fexternal-interpreter, stdout will not
    -- get flushed.
  [d| theAnswerIs = 42 |]


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE ConstraintKinds, RankNTypes #-}

module T8807 where

import Data.Proxy

foo :: $( [t| forall a b. a b => Proxy a -> b -> b |] )
foo = undefined


{-# LANGUAGE TemplateHaskell, TypeFamilyDependencies, PolyKinds #-}

module T8884 where

import Language.Haskell.TH
import System.IO

type family Foo a = r | r -> a where
  Foo x = x

type family Baz (a :: k) = (r :: k) | r -> a
type instance Baz x = x

$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1)
                   [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1])
              [] <- reify ''Foo
      FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2))
              [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz
      runIO $ putStrLn $ pprint foo
      runIO $ putStrLn $ pprint baz
      runIO $ putStrLn $ pprint inst
      runIO $ hFlush stdout
      return [ ClosedTypeFamilyD
                 (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1)
                 [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1]
             , OpenTypeFamilyD
                 (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2)
             , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] )


{-# LANGUAGE TemplateHaskell #-}

module T8932 where

$([d|
   foo :: a -> a
   foo x = x
  |])

foo :: a
foo = undefined


{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies, TemplateHaskell,
             FlexibleInstances, UndecidableInstances #-}

module T8953 where

import Data.Proxy
import Language.Haskell.TH hiding (Type)
import Data.Kind (Type)
import System.IO

type family Poly (a :: k) :: Type
type instance Poly (x :: Bool) = Int
type instance Poly (x :: Maybe k) = Double

type family Silly :: k -> Type
type instance Silly = (Proxy :: Type -> Type)
type instance Silly = (Proxy :: (Type -> Type) -> Type)

a :: Proxy (Proxy :: Type -> Type)
b :: Proxy (Proxy :: (Type -> Type) -> Type)
a = undefined
b = undefined

type StarProxy (a :: Type) = Proxy a

class PC (a :: k)
instance PC (a :: Type)
instance PC (Proxy :: (k -> Type) -> Type)

data T1 :: k1 -> k2 -> Type
data T2 :: k1 -> k2 -> Type
type family F a :: k
type family G (a :: k) :: k
type instance G T1 = T2
type instance F Char = (G T1 Bool :: (Type -> Type) -> Type)

$( do infos <- mapM reify [''Poly, ''Silly, 'a, 'b, ''StarProxy, ''PC, ''F, ''G]
      runIO $ mapM (putStrLn . pprint) infos
      runIO $ hFlush stdout
      return [] )


{-# LANGUAGE TemplateHaskell, MagicHash, UnboxedTuples #-}

module T8954 where

import Language.Haskell.TH

$( do _ <- reify '(##)
      _ <- reify '(#,#)
      _ <- reify ''(##)
      _ <- reify ''(#,#)
      _ <- reify '()
      _ <- reify ''()
      _ <- reify '[]
      _ <- reify ''[]
      return [] )


{-# LANGUAGE TemplateHaskell #-}

module T8987 where
import Language.Haskell.TH

$(reportWarning ['1', undefined] >> return [])


module Main where

import Language.Haskell.TH

main = putStrLn $ pprint foo

foo :: Dec
foo = barD
  where
       barD = FunD ( mkName "bar" )
                   [ Clause manyArgs (NormalB barBody) [] ]

       barBody = DoE [letxStmt, retxStmt]
       letxStmt = LetS [ ValD (VarP xName) (NormalB $ LitE $ IntegerL 5) [] ]
       retxStmt = NoBindS $ AppE returnVarE xVarE
       xName = mkName "x"
       returnVarE = VarE $ mkName "return"
       xVarE = VarE xName
       manyArgs = map argP [0..9]
       argP n = VarP $ mkName $ "arg" ++ show n


{-# LANGUAGE TemplateHaskell, DefaultSignatures #-}

module T9064 where

import Language.Haskell.TH
import System.IO

$( [d| class C a where
         foo :: a -> String
         default foo :: Show a => a -> String
         foo = show |] )

data Bar = Bar deriving Show
instance C Bar

x :: Bar -> String
x = foo

$( do info <- reify ''C
      runIO $ do
        putStrLn $ pprint info
        hFlush stdout
      return [] )


{-# LANGUAGE TemplateHaskell #-}

module T9066 where

$([d| data Blargh = (:<=>) Int Int
      infix 4 :<=>

      type Foo a b = Either a b
      infix 5 `Foo`
        |])


{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds, TypeFamilies #-}

module T9081 where

import Data.Proxy

$( [d|
  class kproxy ~ 'KProxy => C (kproxy :: KProxy a) where
    type TF (x :: a) :: Bool
  |])


{-# LANGUAGE TemplateHaskell #-}

module T9084 where

$([d|
   class C a where
     meth :: a -> a
     meth = undefined -- give a (silly) default
     {-# MINIMAL meth #-}
   |])


{-# LANGUAGE TemplateHaskell, PolyKinds, TypeFamilies #-}

module T9160 where

import Data.Kind (Type)

$( [d| class C (a :: k) where
          type F (a :: k) :: Type
    |]
 )


{-# LANGUAGE TemplateHaskell #-}

module T9209 where

foo = let $( [d| x = 5 |] ) in x


{-# LANGUAGE TemplateHaskell #-}

module T9262 where

import Language.Haskell.TH
import Language.Haskell.TH.Ppr
import System.IO

$(do insts <- reifyInstances ''Eq [ListT `AppT` VarT (mkName "a")]
     runIO $ putStrLn $ pprint insts
     runIO $ hFlush stdout
     return [] )


{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds #-}

module T9692 where

import Data.Kind (Type)
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Syntax hiding (Type)
import Language.Haskell.TH.Ppr
import System.IO

class C a where
        data F a (b :: k) :: Type

instance C Int where
        data F Int x = FInt x

$( do info <- qReify (mkName "F")
      runIO $ putStrLn $ pprint info
      runIO $ hFlush stdout
      return [])


module T9693 where
import Language.Haskell.TH

stuff = do
  -- let x = mkName "X"
  x <- newName "X"
  sequence $ [dataD (return []) x [] Nothing [
      normalC x []
    ] []]


{-# LANGUAGE TemplateHaskell #-}
import T9693

stuff


module T9693 where
import Language.Haskell.TH

stuff = do
  let x = mkName "X"
  -- x <- newName "X"
  sequence $ [dataD (return []) x [] Nothing [
      normalC x []
    ] []]


{-# LANGUAGE TemplateHaskell #-}

module T9738 where

import System.IO
import Language.Haskell.TH

data Foo = MkFoo

$( do decs <- [d| {-# ANN type Foo "hi" #-}
                  {-# ANN MkFoo "there" #-}
                  {-# ANN module "Charley" #-}
                   |]
      runIO $ print decs
      runIO $ hFlush stdout
      return [] )


{-# LANGUAGE TemplateHaskell #-}

-- Trac #2358

module ShouldFail where
import Language.Haskell.TH

x = $(sigE [|1|] (tupleT 1 `appT` conT ''Int))
        -- 1 :: (Int)   ( a 1-tuple type)

y = $(sigE [|1|] (tupleT 1))
        -- 1 :: (1)     (a 1-tuple tycon not applied)

z = $(tupE [ [| "yes" |] ])
        -- ("yes")      (a 1-tuple expression)


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}

module TH_class1 where

$( [d| class Classy a b c d | a -> b c, c -> d where
            f :: a -> b -> c -> d
     |] )


module TH_dataD1 where

import Language.Haskell.TH

ds :: Q [Dec]
ds = [d|
          $(do { d <- dataD (cxt []) (mkName "D") [] Nothing
                             [normalC (mkName "K") []] []
               ; return [d]})
       |]


{-# LANGUAGE TemplateHaskell #-}

module Main where

import TH_Depends_External (loadStringFromFile)

main :: IO ()
main = putStrLn $loadStringFromFile


module TH_Depends_External where

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

loadStringFromFile :: Q Exp
loadStringFromFile = do
  let externalDependency = "TH_Depends_external.txt"
  qAddDependentFile externalDependency
  s <- qRunIO $ readFile externalDependency
  stringE s


{-# LANGUAGE TemplateHaskell #-}

-- Two sliced declarations bind the same variable.
-- This test checks that there's a reasonable error message

module ShouldCompile where

$( [d| x = 1 |] )

$( [d| x = 2 |] )


{-# LANGUAGE TemplateHaskell, EmptyCase #-}
-- Trac #2431: empty case expression
--             now accepted

module Main where

import Language.Haskell.TH

f :: Int
f = $(caseE (litE $ CharL 'a') [])

main = print f


{-# LANGUAGE TemplateHaskell #-}

-- Test error message when the code in a splice
-- fails in an immediate fashion (e.g. with a
-- pattern match failure)

module ShouldCompile where

$( case reverse "no" of
        [] -> return []
 )


{-# LANGUAGE TemplateHaskell #-}

-- Test error message when the code in a splice
-- fails in a lazy fashion (e.g. a (head [])
-- thunk is embedded in the returned structure).

module TH where

$( do { ds <- [d| |]
      ; return (tail ds) }
 )


{-# LANGUAGE TemplateHaskell, ExplicitForAll #-}

module Main where

import TH_ExplicitForAllRules_a

$(decls)

main = hsToTh


{-# LANGUAGE ExplicitForAll #-}
module TH_ExplicitForAllRules_a (decls, hsToTh) where

import Language.Haskell.TH

decls = [d| {-# RULES "example" forall a. forall (x :: a). id x = x #-} |]

hsToTh = do
  decls' <- runQ decls
  mapM (print . ppr) decls'


{-# LANGUAGE TemplateHaskell #-}

-- Test for sane reporting on TH code giving up.

module ShouldCompile where

$( fail "Code not written yet..." )


{-# LANGUAGE TemplateHaskell #-}

module ShouldCompile where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax

$( do
     addModFinalizer (do b <- getQ; reportWarning (show (b::Maybe Bool)))
     return [] )
$( putQ True >> return [] )


import TH_finalizer2M

main = print (f 0)


{-# LANGUAGE TemplateHaskell #-}
module TH_finalizer2M where

import Language.Haskell.TH.Syntax

g :: IO ()
g = $(do addModFinalizer (do d <- [d| f x = (2 :: Int) |]; addTopDecls d)
         [| return ()|]
     )


{-# LANGUAGE ForeignFunctionInterface, CApiFFI, GHCForeignImportPrim,
             QuasiQuotes, TemplateHaskell, JavaScriptFFI, MagicHash,
             UnliftedFFITypes #-}

module TH_foreignCallingConventions where

import GHC.Prim
import Control.Applicative
import Language.Haskell.TH
import System.IO
import Foreign.Ptr

$( do let fi cconv safety lbl name ty =
            ForeignD (ImportF cconv safety lbl name ty)
      dec1 <- fi CCall      Interruptible "&"   (mkName "foo") <$> [t| Ptr () |]
      dec2 <- fi Prim       Safe          "bar" (mkName "bar") <$> [t| Int# -> Int# |]
      -- the declarations below would result in warnings or errors when returned
      dec3 <- fi CApi       Unsafe        "baz" (mkName "baz") <$> [t| Double -> IO () |]
      dec4 <- fi StdCall    Safe          "bay" (mkName "bay") <$> [t| (Int -> Bool) -> IO Int |]
      dec5 <- fi JavaScript Unsafe        "bax" (mkName "bax") <$> [t| Ptr Int -> IO String |]
      runIO $
        mapM_ (putStrLn . pprint) [dec1, dec2, dec3, dec4, dec5] >> hFlush stdout
      return [dec1, dec2]
 )


{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface, InterruptibleFFI #-}

module TH_foreign where

import Foreign.Ptr
import Language.Haskell.TH

$(return [ForeignD (ImportF CCall Interruptible "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))])

-- Should generate the same as this:
foreign import ccall interruptible "&" foo1 :: Ptr ()


{-# OPTIONS -ddump-splices -XExistentialQuantification #-}
{-# LANGUAGE TemplateHaskell #-}

module TH_genEx where

import TH_genExLib
import Language.Haskell.TH

class MyInterface a where
  foo :: a -> Int
  foo1 :: Int -> a -> Int

$(genAny (reify ''MyInterface))


module TH_genExLib where

import Language.Haskell.TH

genAny :: Q Info -> Q [Dec]
genAny decl = do { d <- decl
                 ; case d of
                    ClassI (ClassD _ name _ _ decls) _ -> return [genAnyClass name decls]
                    _ -> error "genAny can be applied to classes only"
        }

genAnyClass :: Name -> [Dec] -> Dec
genAnyClass name decls
  = DataD [] anyName [] Nothing [constructor] []
  where
    anyName = mkName ("Any" ++ nameBase name ++ "1111")
    constructor = ForallC [PlainTV var_a] [AppT (ConT name) (VarT var_a)] $
                  NormalC anyName
                                [(Bang NoSourceUnpackedness NoSourceStrictness, VarT var_a)]
    var_a = mkName "a"


{-# LANGUAGE ImplicitParams #-}
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

funcToReify :: (?z :: Int) => Int
funcToReify = ?z

$( [d|
        f :: (?x :: Int) => Int
        f = let ?y = 2 in ?x + ?y |] )

main = do
    putStrLn $(lift . pprint =<< reify 'funcToReify)
    print (let ?x = 3 in f)
    print $( [| let ?x = 1 in ?x |] )
    print $(letE [implicitParamBindD "y" (lift (2 :: Int))]
                 (implicitParamVarE "y") )
    putStrLn $( lift . pprint =<< [d|
        f :: (?x :: Int) => Int
        f = let ?y = 2 in ?x + ?y |] )


{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH

$(fmap (:[]) (implicitParamBindD "x" [e| 1 |]))


{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH

main = $(letE [ implicitParamBindD "x" [e| 1 |]
              , funD (mkName "y") [clause [] (normalB [e| 2 |]) []]
              ]
              (varE (mkName "y")))


{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH

main = print $(letE [implicitParamBindD "invalid name" [e| "hi" |]]
                    (implicitParamVarE "invalid name"))


{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

$(do
  invalidDecl <- valD (varP (mkName "emptyDo")) (normalB (doE [])) []
  addTopDecls [invalidDecl]
  return [])


{-# LANGUAGE TemplateHaskell #-}

-- Test that LINE pragmas influence type error messages correctly

module ShouldFail where

import Language.Haskell.TH

$( do p  <- pragLineD 42 "virtual file"
      ds <- [d| x = $(varE (mkName "doesntExist")) |]
      return (p:ds) )


-- test 'lookupTypeName' and 'lookupValueName'

import Language.Haskell.TH

import qualified TH_lookupName_Lib
import qualified TH_lookupName_Lib as TheLib

f :: String
f = "TH_lookupName.f"

data D = D

$(return [])

main = mapM_ print [
  -- looking up values
  $(do { Just n <- lookupValueName "f" ; varE n }),
  $(do { Nothing <- lookupTypeName "f";  [| "" |] }),
  -- looking up types
  $(do { Just n <- lookupTypeName "String"; sigE [| "" |] (conT n) }),
  $(do { Nothing <- lookupValueName "String"; [| "" |] }),
  -- namespacing
  $(do { Just n <- lookupValueName "D"; DataConI{} <- reify n; [| "" |] }),
  $(do { Just n <- lookupTypeName "D"; TyConI{} <- reify n; [| "" |] }),
  -- qualified lookup
  $(do { Just n <- lookupValueName "TH_lookupName_Lib.f"; varE n }),
  $(do { Just n <- lookupValueName "TheLib.f"; varE n }),
  -- shadowing
  $(TheLib.lookup_f),
  $( [| let f = "local f" in $(TheLib.lookup_f) |] ),
  $( [| let f = "local f" in $(do { Just n <- lookupValueName "f"; varE n }) |] ),
  $( [| let f = "local f" in $(varE 'f) |] ),
  let f = "local f" in $(TheLib.lookup_f),
  let f = "local f" in $(varE 'f)
 ]


module TH_lookupName_Lib where

import Language.Haskell.TH

f :: String
f = "TH_lookupName_Lib.f"

lookup_f :: Q Exp
lookup_f = do { Just n <- lookupValueName "f"; varE n }


{-# LANGUAGE TemplateHaskell #-}

-- Test name quoting and splicing, for built-in syntax

module TH_mkName where

import Language.Haskell.TH

x1 = $( return (ConE '()))
x2 = $( return (ConE '(,)))
x3 = $( return (ConE '[]))
x4 = $( return (ConE '(:)))
x5 = $( return (ConE 'Just))

y1 = $( return (ConE (mkName "()")))
y2 = $( return (ConE (mkName "(,)")))
y3 = $( return (ConE (mkName "[]")))
y4 = $( return (ConE (mkName ":")))
y5 = $( return (ConE (mkName "Just")))


{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH

eitherName, fooName, moduleFooName :: Name
eitherName = ''Either
fooName = mkName "foo"
moduleFooName = mkName "Module.foo"

main :: IO ()
main = do
  print $ nameBase eitherName
  print $ nameBase fooName
  print $ nameBase moduleFooName

  print $ nameModule eitherName
  print $ nameModule fooName
  print $ nameModule moduleFooName

  print $ namePackage eitherName
  print $ namePackage fooName
  print $ namePackage moduleFooName


{-# LANGUAGE TemplateHaskell #-}
module Main where

import Data.Maybe (Maybe(..))
import Data.Ord (Ord)
import Language.Haskell.TH (mkName, nameSpace)

main :: IO ()
main = mapM_ (print . nameSpace)
             [ 'Prelude.id
             , mkName "id"
             , 'Data.Maybe.Just
             , ''Data.Maybe.Maybe
             , ''Data.Ord.Ord
             ]


{-# LANGUAGE TemplateHaskell #-}
module TH_NestedSplices where

import Language.Haskell.TH

import TH_NestedSplices_Lib
-- This import brings in
--   spliceExpr :: String -> Q Exp -> Q Exp
--   declareFun :: String -> Q [Dec]

-- Top level splice without $
declareFun "a"

-- Splice inside splice
$(declareFun $(stringE "b"))

-- Splice inside splice without outer $
declareFun $(stringE "c")

-- Ordinary splicing
f x = $(spliceExpr "boo" [| x |])

-- Splice inside splice
g x = $(spliceExpr $(litE (stringL "boo")) [| x |])

-- Ordinary splice inside bracket
h1 = [| $(litE (integerL 3)) |]

-- Splice inside splice inside bracket
h2 = [| $(litE ($(varE 'integerL) 3)) |]


{-# LANGUAGE TemplateHaskell #-}
module TH_NestedSplices_Lib where

import Language.Haskell.TH

spliceExpr :: String -> Q Exp -> Q Exp
spliceExpr s e = [| (s, $e) |]

declareFun :: String -> Q [Dec]
declareFun s
  = do { n <- newName s
       ; d <- funD n [clause [] (normalB [| 22 |]) []]
       ; return [d] }


{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
module TH_overlaps where

import Language.Haskell.TH

class C1 a where c1 :: a
class C2 a where c2 :: a
class C3 a where c3 :: a

[d|
  instance {-# OVERLAPPABLE #-} C1 [a]      where c1 = []
  instance                      C1 [Int]    where c1 = [1]

  instance                      C2 [a]      where c2 = []
  instance {-# OVERLAPPING #-}  C2 [Int]    where c2 = [1]

  instance                      C3 [a]      where c3 = []
  instance {-# OVERLAPS #-}     C3 [[a]]    where c3 = [[]]
  instance                      C3 [[Int]]  where c3 = [[1]]
  |]

test1 :: ([Char],[Int])
test1 = (c1,c1)

test2 :: ([Char],[Int])
test2 = (c2,c2)

test3 :: ([Char],[[Char]],[[Int]])
test3 = (c3,c3,c3)


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module TH_overloadedlabels where

import Language.Haskell.TH
import GHC.OverloadedLabels

data T = T { sel :: Int}

instance IsLabel "sel" (T -> Int) where
  fromLabel (T n) = n

x :: Int
x = $(labelE "sel") (T 5)

y :: Int
y = $( [| #sel |] ) (T 6)


{-# OPTIONS -ddump-splices #-}
{-# LANGUAGE TemplateHaskell #-}
module TH_pragma where

$( [d| foo :: Int -> Int
       {-# NOINLINE foo #-}
       foo x = x + 1    |] )

$( [d| bar :: Num a => a -> a
       {-# SPECIALISE INLINE [~1] bar :: Float -> Float #-}
       bar x = x * 10        |] )


{-# LANGUAGE TemplateHaskell #-}

module TH_Promoted1Tuple where

import Language.Haskell.TH

$(sequence [tySynD (mkName "F") [] (appT (promotedTupleT 1) (conT ''Int))])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}

module TH_PromotedList where

import Language.Haskell.TH

$(let ty = AppT (AppT PromotedConsT (ConT ''Int))
            (AppT (AppT PromotedConsT (ConT ''Bool)) PromotedNilT)

  in  reportWarning (pprint ty) >>
        return [])

data Proxy a = Proxy

f :: Proxy (True ': $(appT (appT promotedConsT (conT 'False)) promotedNilT))
f = Proxy :: Proxy ('[True, False] :: [Bool])


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}

module TH_PromotedTuple where

import Language.Haskell.TH

data Equal a b where
  Refl :: Equal a a

equal :: Equal '(Int, False) $(do ty <- [t| '(Int, False) |]
                                  reportWarning (show ty)
                                  return ty)

equal = Refl


module TH_raiseErr1 where
import Language.Haskell.TH

foo = $(do { report True "Error test succeeded"; fail "" })


-- Same as T14471 but also enables RebindableSyntax, since that's a
-- tricky case.

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE TemplateHaskell #-}

import Language.Haskell.TH
import Prelude

main = putStrLn $(do
  expr <- [|
    do x <- getLine
       y <- getLine
       pure (x, y)
    |]
  stringE (pprint expr))