module Main where

import Language.Haskell.TH

-- The recover successfully find that 'ola' is not in scope
-- and use '1' instead

y = $(recover (return (LitE (IntegerL 1)))
              (reify (mkName ("ola")) >> return (LitE (IntegerL 2))))

main = print y


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -Wall #-}
module Bug where

import Language.Haskell.TH

-- Warnings should be preserved through recover
main :: IO ()
main = putStrLn $(recover (stringE "splice failed")
                          [| let x = "a" in let x = "b" in x |])


{-# LANGUAGE RecursiveDo #-}
import Data.IORef
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import TH_recursiveDoImport

main = testRec >> testMdo

testRec = do
    putStrLn $(lift . pprint =<< recIO)
    -- Test that we got the expected structure.
    SelfRef r1 <- $(recIO)
    r2 <- readIORef r1
    SelfRef r1' <- readIORef r2
    print (r1 == r1')

testMdo =
    putStrLn $(lift . pprint =<< mdoIO)


{-# LANGUAGE RecursiveDo #-}
module TH_recursiveDoImport where
import Data.IORef
import Language.Haskell.TH

data SelfRef = SelfRef (IORef (IORef SelfRef))

recIO :: ExpQ
recIO = [e|
    do rec r1 <- newIORef r2
           r2 <- newIORef (SelfRef r1)
       readIORef r2 |]

mdoIO :: ExpQ
mdoIO = [e|
    mdo r1 <- return r2
        r2 <- return (const 1 r1)
        return r1 |]

emptyRecIO :: ExpQ
emptyRecIO = [e|
   do rec {}
      return () |]


-- test reification of data declarations

{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-}
module TH_reifyDecl1 where

import Data.Kind as K
import System.IO
import Language.Haskell.TH
import Text.PrettyPrint.HughesPJ

infixl 3 `m1`

-- simple
data T = A | B

-- parametric
data R a = C a | D

-- recursive
data List a = Nil | Cons a (List a)

-- infix operator
data Tree a = Leaf | Tree a :+: Tree a

-- type declaration
type IntList = [Int]

-- newtype declaration
newtype Length = Length Int

-- simple class
class C1 a where
  m1 :: a -> Int

-- class with instances
class C2 a where
  m2 :: a -> Int
instance C2 Int where
  m2 x = x

-- associated types
class C3 a where
  type AT1 a
  data AT2 a

instance C3 Int where
  type AT1 Int = Bool
  data AT2 Int = AT2Int

-- type family
type family TF1 a

-- type family, with instances
type family TF2 a
type instance TF2 Bool = Bool

-- data family
data family DF1 a

-- data family, with instances
data family DF2 a
data instance DF2 Bool = DBool

data family DF3 (a :: k)
data instance DF3 @K.Type a = DF3Bool
data instance DF3 @(K.Type -> K.Type) b = DF3Char

$(return [])

test :: ()
test = $(let
      display :: Name -> Q ()
      display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
    in do { display ''T
          ; display ''R
          ; display ''List
          ; display ''Tree
          ; display ''IntList
          ; display ''Length
          ; display 'Leaf
          ; display 'm1
          ; display ''C1
          ; display ''C2
          ; display ''C3
          ; display ''AT1
          ; display ''AT2
          ; display ''TF1
          ; display ''TF2
          ; display ''DF1
          ; display ''DF2
          ; display ''DF3
          ; [| () |] })


module TH_reifyDecl2 where

import Language.Haskell.TH
import System.IO

$(
    do x <- reify ''Maybe
       runIO $ hPutStrLn stderr $ pprint x
       return []
 )


-- test reification of explicit foralls in type families

{-# LANGUAGE TypeFamilies, ExplicitForAll #-}
module TH_reifyExplicitForAllFams where

import System.IO
import Language.Haskell.TH
import Text.PrettyPrint.HughesPJ

import Data.Proxy
import Data.Kind

$([d| data family F a
      data instance forall a. F (Maybe a) = MkF a |])

$([d| class C a where
        type G a b
      instance forall a. C [a] where
        type forall b. G [a] b = Proxy b |])

$([d| type family H a b where
        forall x y. H [x] (Proxy y) = Either x y
        forall z.   H z   z         = Maybe z |])

$(return [])

test :: ()
test = $(let
      display :: Name -> Q ()
      display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
    in do { display ''F
          ; display ''C
          ; display ''G
          ; display ''H
          ; [| () |] })


-- test reifyInstances

{-# LANGUAGE TypeFamilies #-}
module TH_reifyInstances where

import System.IO
import Language.Haskell.TH
import Text.PrettyPrint.HughesPJ

-- classes
class C1 a where f1 :: a

class C2 a where f2 :: a
instance C2 Int where f2 = 0
instance C2 Bool where f2 = True

-- type families
type family T1 a

type family T2 a
type instance T2 Int = Char
type instance T2 Bool = Int

-- data families
data family D1 a

data family D2 a
data instance D2 Int = DInt | DInt2
data instance D2 Bool = DBool

$(return [])

test :: ()
test = $(let
          display :: Name -> Q ()
          display n = do
               { intTy <- [t| Int |]
               ; is1 <- reifyInstances n [intTy]
               ; runIO $ hPutStrLn stderr (nameBase n)
               ; runIO $ hPutStrLn stderr (pprint is1)
               }
        in do { display ''C1
              ; display ''C2
              ; display ''T1
              ; display ''T2
              ; display ''D1
              ; display ''D2
              ; [| () |]
              })


-- test reification of local definitions
{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH.Syntax
import System.IO

-- Sidestep the staging restriction
-- printTypeOf :: String -> Q ()
#define printTypeOf(n) (addModFinalizer $ do \
                       { VarI _ t _ <- reify (mkName (n)) \
                       ; runIO $ hPutStrLn stderr (n ++ " :: " ++ show t) \
                       })

main :: IO ()
main = print (f 1 "", g 'a' 2, h True 3)
  where
    f xf yf = ( xf :: Int
              , let ff $(do printTypeOf("yf")
                            [p| z |]
                        ) = z :: $(do printTypeOf("z")
                                      [t| () |]
                                  )
                 in $(do printTypeOf("xf")
                         [| yf :: String |]
                     )
            )
    g xg y = ( $(do printTypeOf("xg")
                    [| y :: Int |]
                )
             , xg :: Char
             )
    h xh y = ( $$(do printTypeOf("xh")
                     [|| y :: Int ||]
                 )
             , xh :: Bool
             )


-- Tests that a complete type is yielded by reify for local definitions,
-- even when using functional dependencies which are resolved at the very end of
-- type checking.
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FunctionalDependencies #-}
module TH_reifyLocalDefs2 where
import Language.Haskell.TH as TH
import Language.Haskell.TH.Syntax as TH
import System.IO

class C a b | a -> b where
  yo :: a -> IO b

instance C Bool Int where
  yo _ = return 0

t3 :: IO ()
t3 = do
  x <- yo True
  $(do addModFinalizer $ do
         VarI _ t _ <- TH.reify 'x
         runIO $ hPutStrLn stderr $ show t
       [| return () |]
   )


-- Trac #2339

module Foo where

import System.IO
import Language.Haskell.TH

type C = Int

$(do
  a <- reify $ mkName "C"
  runIO $ hPutStrLn stderr (show a)
  return []
  )


-- test the representation of literals and also explicit type annotations

module Main
where

import Language.Haskell.TH

main :: IO ()
main = mapM_ putStrLn [show an_integral, show an_int, show an_integer,
                       show an_char, show an_string, show an_fractional,
                       show an_float, show an_double]

an_integral :: Integer
an_integral = $( [| 42 |] )

an_int :: Int
an_int = $( [| 42 :: Int |] )

an_integer :: Integer
an_integer = $( [| 98765432123456789876 :: Integer |] )

an_char :: Char
an_char = $( [| 'x' |] )

an_string :: String
an_string = $( [| "A String" |] )

an_fractional :: Double
an_fractional = $( [| 1.2 |] )

an_float :: Float
an_float = $( [| 1.2 :: Float |] )

an_double :: Double
an_double = $( [| 1.2 :: Double |] )


module Main
where

import Language.Haskell.TH
import System.IO

$(
  do ds <- [d|
        foo :: Int -> Int
        foo x
         | x == 5 = 6
        foo x = 7
      |]
     runIO $ do { putStrLn (pprint ds); hFlush stdout }
     return ds
 )

$(
  do ds <- [d|
        bar :: Maybe Int -> Int
        bar x
         | Just y <- x = y
        bar _ = 9
      |]
     runIO $ do { putStrLn (pprint ds) ; hFlush stdout }
     return ds
 )

main :: IO ()
main = do putStrLn $ show $ foo 5
          putStrLn $ show $ foo 8
          putStrLn $ show $ bar (Just 2)
          putStrLn $ show $ bar Nothing


-- test the representation of unboxed literals

module Main
where

$(
    [d|
        foo :: Int -> Int
        foo x
         | x == 5 = 6
        foo x = 7
      |]
 )

$(
    [d|
        bar :: Maybe Int -> Int
        bar x
         | Just y <- x = y
        bar _ = 9
      |]
 )

main :: IO ()
main = do putStrLn $ show $ foo 5
          putStrLn $ show $ foo 8
          putStrLn $ show $ bar (Just 2)
          putStrLn $ show $ bar Nothing


{-# LANGUAGE ScopedTypeVariables #-}

module Main
where

import TH_repPatSig_asserts

assertFoo [d| foo :: Int -> Int
              foo (x :: Int) = x
            |]

assertCon [| \(x :: Either Char Int -> (Char, Int)) -> x |]

assertVar [| \(x :: Maybe a) -> case x of Just y -> (y :: a) |]

main :: IO ()
main = return ()


{-# LANGUAGE ScopedTypeVariables #-}

module Main
where

import Language.Haskell.TH

$([d| f = \(_ :: Either a b) -> $(sigE (varE 'undefined) (varT ''c)) |])

main :: IO ()
main = return ()


module TH_repPatSig_asserts where

import Language.Haskell.TH

assertFoo :: Q [Dec] -> Q [Dec]
assertFoo decsQ = do
  decs <- decsQ
  case decs of
    [ SigD _ (AppT (AppT ArrowT (ConT t1)) (ConT t2)),
      FunD _ [Clause [SigP (VarP _) (ConT t3)] (NormalB (VarE _)) []] ]
      | t1 == ''Int && t2 == ''Int && t3 == ''Int -> return []
    _  -> do reportError $ "Unexpected quote contents: " ++ show decs
             return []

assertCon :: Q Exp -> Q [Dec]
assertCon expQ = do
  exp <- expQ
  case exp of
    LamE [SigP (VarP _) (AppT (AppT ArrowT (AppT (AppT (ConT eitherT)
                                                       (ConT charT1))
                                                 (ConT intT1)))
                              (AppT (AppT (TupleT 2) (ConT charT2))
                                    (ConT intT2)))]
         (VarE _)
      | eitherT == ''Either &&
        charT1 == ''Char &&
        charT2 == ''Char &&
        intT1 == ''Int &&
        intT2 == ''Int -> return []
    _ -> do reportError $ "Unexpected quote contents: " ++ show exp
            return []

assertVar :: Q Exp -> Q [Dec]
assertVar expQ = do
  exp <- expQ
  case exp of
    LamE [SigP (VarP x) (AppT (ConT _) (VarT a))]
         (CaseE (VarE x1) [Match (ConP _ [VarP y])
                                 (NormalB (SigE (VarE y1) (VarT a1))) []])
      | x1 == x &&
        y1 == y &&
        a1 == a -> return []
    _ -> do reportError $ "Unexpected quote contents: " ++ show exp
            return []


{-# LANGUAGE MagicHash #-}
-- test the representation of unboxed literals

module Main where

import GHC.Exts
import GHC.Float
import Language.Haskell.TH
import Text.PrettyPrint
import System.IO

main :: IO ()
main = do putStrLn $ show $ $( do e <- [| I# 20# |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  return e )
          putStrLn $ show $ $( do e <- [| W# 32## |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  return e )
          putStrLn $ show $ $( do e <- [| F# 12.3# |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  return e )
          putStrLn $ show $ $( do e <- [| D# 24.6## |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  return e )


{-# LANGUAGE MagicHash, UnboxedTuples #-}
-- test the representation of unboxed literals

module Main where

import GHC.Exts
import GHC.Float
import Language.Haskell.TH
import Text.PrettyPrint
import System.IO

main :: IO ()
main = do putStrLn $ show $ $( do e <- [| 20# |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  [| I# $( return e) |] )
          putStrLn $ show $ $( do e <- [| 32## |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  [| W# $(return e) |] )
          putStrLn $ show $ $( do e <- [| 12.3# |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  [| F# $(return e) |] )
          putStrLn $ show $ $( do e <- [| 24.6## |]
                                  runIO $ putStrLn $ show e
                                  runIO $ putStrLn $ pprint e
                                  runIO $ hFlush stdout
                                  [| D# $(return e) |] )


{-# LANGUAGE MagicHash #-}
-- test the representation of unboxed literals

module Main
where

import GHC.Exts
import GHC.Float
import Language.Haskell.TH
import Text.PrettyPrint
import System.IO

main :: IO ()
main = do putStrLn $ show $ $( do e <- [| I# 20# |]
                                  return e )
          putStrLn $ show $ $( do e <- [| W# 32## |]
                                  return e )
          putStrLn $ show $ $( do e <- [| F# 12.3# |]
                                  return e )
          putStrLn $ show $ $( do e <- [| D# 24.6## |]
                                  return e )


{-# LANGUAGE MagicHash, UnboxedTuples #-}
-- test the representation of unboxed literals

module Main
where

import GHC.Exts
import GHC.Float
import Language.Haskell.TH
import Text.PrettyPrint
import System.IO

main :: IO ()
main = do putStrLn $ show $ $( do e <- [| 20# |]
                                  [| I# $(return e) |] )
          putStrLn $ show $ $( do e <- [| 32## |]
                                  [| W# $(return e) |] )
          putStrLn $ show $ $( do e <- [| 12.3# |]
                                  [| F# $(return e) |] )
          putStrLn $ show $ $( do e <- [| 24.6## |]
                                  [| D# $(return e) |] )


{-# LANGUAGE TemplateHaskell, UnboxedTuples #-}
-- test the representation of unboxed tuples

module Main where

import GHC.Exts
import GHC.Float
import Language.Haskell.TH
import Text.PrettyPrint
import System.IO

main :: IO ()
main = case bar () of
       (# str, int #) ->
           print (str, int)

bar :: () -> (# String, Int #)
bar () = $( do e <- [| case (# 'b', False #) of
                       (# 'a', True  #) -> (# "One", 1 #)
                       (# 'b', False #) -> (# "Two", 2 #)
                       (# _,   _     #) -> (# "Three", 3 #)
                     |]
               runIO $ putStrLn $ show e
               runIO $ putStrLn $ pprint e
               runIO $ hFlush stdout
               return e )


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}

module TH_RichKinds where

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

$(do  tys <- sequence [ [t| forall a. (a :: Bool) |]
                      , [t| forall a. (a :: Constraint) |]
                      , [t| forall a. (a :: [Type]) |]
                      , [t| forall a. (a :: (Type, Bool)) |]
                      , [t| forall a. (a :: ()) |]
                      , [t| forall a. (a :: (Type -> Bool)
                                         -> ((Type, Type -> Type) -> Bool)) |]
                      ]

      reportWarning (pprint tys)
      return [])


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

module TH_RichKinds2 where

import qualified Data.Kind as K
import Data.Char
import Data.List
import Language.Haskell.TH

$(return [OpenTypeFamilyD (TypeFamilyHead
          (mkName "Map") [KindedTV (mkName "f")
                          (AppT (AppT ArrowT (VarT (mkName "k1")))
                           (VarT (mkName "k2"))),
                          KindedTV (mkName "l")
                          (AppT ListT
                           (VarT (mkName "k1")))]
          (KindSig (AppT ListT (VarT (mkName "k2")))) Nothing)])

$( let fixKs :: String -> String -- need to remove TH renaming index from k variables
       fixKs s =
         case (elemIndex 'k' s) of
           Nothing -> s
           Just i ->
             if i == (length s) || (s !! (i+1) /= '_') then s else
             let (prefix, suffix) = splitAt (i+2) s -- the +2 for the "k_"
                 (index, rest) = span isDigit suffix in
             if length index == 0 then s else
             prefix ++ "0" ++ (fixKs rest)
   in
   do decls <- [d| data SMaybe :: (k -> K.Type) -> (Maybe k) -> K.Type where
                     SNothing :: SMaybe s 'Nothing
                     SJust :: s a -> SMaybe s ('Just a)

                   type instance Map f '[] = '[]
                   type instance Map f (h ': t) = ((f h) ': (Map f t))
                   |]
      reportWarning (fixKs (pprint decls))
      return decls )

data SBool :: Bool -> K.Type where
  SFalse :: SBool 'False
  STrue :: SBool 'True

mbool :: SMaybe SBool ('Just 'False)
mbool = SJust SFalse


{-# LANGUAGE TemplateHaskell #-}

module TH_Roles1 where

import Language.Haskell.TH

$( return [ DataD [] (mkName "T") [PlainTV (mkName "a")] Nothing [] []
          , RoleAnnotD (mkName "T") [RepresentationalR] ] )


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

module TH_Roles2 where

import Language.Haskell.TH

$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") (VarT (mkName "k"))]
            Nothing [] []
          , RoleAnnotD (mkName "T") [RepresentationalR] ] )


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

module Roles3 where

import Language.Haskell.TH
import System.IO

$( do { decls <- [d| data Foo a (b :: k) c (d :: k)
                     type role Foo _ _ representational nominal |]
      ; runIO $ putStrLn (pprint decls) >> hFlush stdout
      ; return decls })


{-# LANGUAGE TemplateHaskell #-}

module Roles4 where

import Language.Haskell.TH
import System.IO

data Sticky a b = MkSticky (a b)

$( do roles <- reifyRoles (mkName "Sticky")
      runIO $ putStrLn (show roles) >> hFlush stdout
      return [] )


{-# LANGUAGE TemplateHaskell #-}

-- See Trac #1678

module TH where

import Language.Haskell.TH

-- foo = $(fail "hi")

foo = $(runIO (fail "hi"))


{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-}
module Foo where

$([d| f :: forall a. a->a
      f x = x::a
    |])


-- Test for trac #2956

module TH_sections where

two :: Int
two = $( [| (1 +) 1 |] )

three :: Int
three = $( [| (+ 2) 1 |] )


{-# LANGUAGE TemplateHaskell #-}

-- We should get a civilised report of conflicting variable
-- bindings in the definition spliced in by foo

module TH_spliceD1 where

import TH_spliceD1_Lib

$(foo)


{-# LANGUAGE TemplateHaskell #-}

module TH_spliceD1_Lib where
import Language.Haskell.TH

foo :: Q [Dec]
foo = sequence [funD (mkName "f")
       [
         clause
           [varP $ mkName "c",varP $ mkName "c"]
           (normalB $ [| undefined |])
           []
       ]]


module TH_spliceD2 where

import qualified TH_spliceD2_Lib

$( [d| data T = T TH_spliceD2_Lib.T |] )


module TH_spliceD2_Lib where

data T = T Int


-- test splicing of a generated data declarations

module TH_spliceDecl1
where

import Language.Haskell.TH

-- splice a simple data declaration
$(return [DataD [] (mkName "T") [] Nothing [NormalC (mkName "C") []] []])


-- test splicing of quoted data and newtype declarations

module TH_spliceDecl2
where

import Language.Haskell.TH

-- splice a simple quoted declaration (x 2)
$([d| data T1 = C1 |])

$([d| newtype T2 = C2 String |])


-- test splicing of reified and renamed data declarations

module TH_spliceDecl3
where

import Language.Haskell.TH
import TH_spliceDecl3_Lib

data T = C

$(do { TyConI d <- reify ''T; rename' d})


module TH_spliceDecl3_Lib
where

import Language.Haskell.TH

rename' :: Dec -> Q [Dec]
rename' (DataD ctxt tyName tyvars ksig cons derivs) =
  return [DataD ctxt (stripMod tyName) tyvars ksig
          (map renameCons cons) derivs]
  where
    renameCons (NormalC conName tys) = NormalC (stripMod conName) tys
    --
    stripMod v = mkName (nameBase v ++ "'")


{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances, TypeSynonymInstances #-}

module TH_spliceDecl4 where

import TH_spliceDecl4_Lib

instance IncrSelf String where
    incrSelf x = x ++ "x"

$(instanceIncrSelfTuple 2)


{-# LANGUAGE TemplateHaskell, UndecidableInstances #-}

module TH_spliceDecl4_Lib(
  instanceIncrSelfTuple,
  IncrSelf(..)
)
where
import Control.Monad
import Data.Maybe
import Language.Haskell.TH

class IncrSelf a where
    incrSelf :: a -> a

instanceIncrSelfTuple :: Int -> Q [Dec]
instanceIncrSelfTuple n = [d| incrSelf value = True |]


module Main where

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

main = print (my_id "hello")


-- test the representation of literals and also explicit type annotations

module TH_repE1
where

import Language.Haskell.TH

$( do let emptyListExpr :: ExpQ
          emptyListExpr = [| [] |]

          singletonListExpr :: ExpQ
          singletonListExpr = [| [4] |]

          listExpr :: ExpQ
          listExpr = [| [4,5,6] |]

          consExpr :: ExpQ
          consExpr = [| 4:5:6:[] |]

      [d| foo = ($emptyListExpr, $singletonListExpr, $listExpr, $consExpr) |]
 )

bar = $( [| case undefined of
                [1] -> 1 |] )


module Main where

import Language.Haskell.TH

$( do let h x = x
          foo = [| \x -> $(h [| x |]) |]

      [d| baz = $foo |]
 )

main = print (baz "Hello")


module Main where

import TH_spliceE5_Lib

v1 = "foo"

main = putStrLn $(expandVars ["v1","v2"])
-- The splice expands to refer to both v1 and v2,
-- and the test checks that we don't dependency-analyse
-- the program so that one or the other isn't in scope
-- to the type checker

v2 = "bar"


module TH_spliceE5_Lib where

import Language.Haskell.TH

expandVars :: [String] -> Q Exp
expandVars s = [| concat $(return (ListE (map f s))) |]
  where
    f x = VarE (mkName x)


module Main where

import TH_spliceE5_prof_Lib

v1 = "foo"

main = putStrLn $(expandVars ["v1","v2"])
-- The splice expands to refer to both v1 and v2,
-- and the test checks that we don't dependency-analyse
-- the program so that one or the other isn't in scope
-- to the type checker

v2 = "bar"


module Main where

import TH_spliceE5_prof_ext_Lib

v1 = "foo"

main = putStrLn $(expandVars ["v1","v2"])
-- The splice expands to refer to both v1 and v2,
-- and the test checks that we don't dependency-analyse
-- the program so that one or the other isn't in scope
-- to the type checker

v2 = "bar"


module TH_spliceE5_prof_ext_Lib where

import Language.Haskell.TH

expandVars :: [String] -> Q Exp
expandVars s = [| concat $(return (ListE (map f s))) |]
  where
    f x = VarE (mkName x)


module TH_spliceE5_prof_Lib where

import Language.Haskell.TH

expandVars :: [String] -> Q Exp
expandVars s = [| concat $(return (ListE (map f s))) |]
  where
    f x = VarE (mkName x)


{-# LANGUAGE TemplateHaskell #-}

-- This failed in 6.10.1, as the Name's for True and False in
-- Language.Haskell.TH.Syntax.{trueName,falseName} were wrong.

module TH_spliceE6 where

a = $( (\b -> [| b |]) True )
b = $( (\m -> [| m |]) (Just 'm') )
c = $( (\e -> [| e |]) (Left 'e' :: Either Char Bool) )


-- test representation and splicing of left-parenthesised right infix operators

module TH_spliceExpr1
where

import Language.Haskell.TH

foo :: Int
foo = $( [| ((+) $ 2) $ 2 |] )


{-# OPTIONS_GHC -XTemplateHaskell #-}

-- Trac #2017

module ShouldCompile where

 import Language.Haskell.TH

 $(do e <- [d| f a b
                 | a == b = a
                 | otherwise = b |]
      return e)


{-# LANGUAGE TemplateHaskell #-}

-- Tickles a GHC 6.4 buglet

module ShouldCompile where

class Foo a where
    foo :: a -> a
    foo = id

-- Splice an instance decl that uses the default method
$( [d| instance Foo () where |] )


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StaticPointers #-}

-- | A test of static forms in TH quotations.
module Main(main) where

import GHC.StaticPtr

main = print $ deRefStaticPtr $([| static g :: StaticPtr String |])

g = "found"


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE StaticPointers #-}

-- | A test to try the static form in splices, which should fail.
--
module Main(main) where

import GHC.Fingerprint
import GHC.StaticPtr

main = print $ $(case staticKey (static 'a') of
  Fingerprint w0 w1 ->
    let w0i = fromIntegral w0 :: Integer
        w1i = fromIntegral w1 :: Integer
    in
     [| fmap (\p -> deRefStaticPtr p :: Char) $ unsafeLookupStaticPtr $
          Fingerprint (fromIntegral w0i) (fromIntegral w1i)
      |]
     )


{-# LANGUAGE MagicHash #-}
module Main where

import Language.Haskell.TH
import GHC.Prim(Addr#)
import GHC.Ptr
import Foreign.Marshal.Array (peekArray)
import Data.Word (Word8)

check_equal :: [Word8] -> Addr# -> IO ()
check_equal bytes addr = do
  bytes' <- peekArray (length bytes) (Ptr addr)
  print (bytes == bytes')

main = do
  -- check round-trip
  check_equal [0..255] $(litE $ stringPrimL [0..255])

  -- check printing
  let e = LitE (StringPrimL [0..255])
  print e
  putStrLn (pprint e)


{-# LANGUAGE TypeFamilies #-}

module TH_tf1 where

import Data.Kind (Type)

$( [d| data family T a |] )
$( [d| data instance T Int = TInt Bool |] )

foo :: Bool -> T Int
foo b = TInt (b && b)

$( [d| type family S a |] )
$( [d| type instance S Int = Bool |] )

bar :: S Int -> Int
bar c = if c then 1 else 2

$( [d| type family R (a :: Type -> Type) :: Type -> Type |] )
$( [d| type instance R Maybe = [] |] )

baz :: R Maybe Int -> Int
baz = head


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-}

module TH_tf3 where

type family T a

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

$( [d| class C a
       instance a ~ Int => C a |] )


{-# LANGUAGE TemplateHaskell #-}

-- Test the use of tupleDataName, tupleTypeName

module ShouldCompile where

import Language.Haskell.TH

foo = $( sigE (appsE [conE (tupleDataName 2),
                     litE (integerL 1),
                     litE (integerL 2)])
              (appT (appT (conT (tupleTypeName 2))
                          (conT ''Integer))
                    (conT ''Integer))
        )


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

module TH_TyInstWhere1 where

$([d| type family F (a :: k) (b :: k) :: Bool where
        F a a = True
        F a b = False |])

data Proxy a = P

f :: Proxy True -> Proxy (F Int Int)
f x = x

g :: Proxy False -> Proxy (F Int Bool)
g x = x


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

module TH_TyInstWhere2 where

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

$( do { decs <- [d| type family F (a :: k) (b :: k) :: Bool where
                      F a a = True
                      F a b = False |]
      ; reportWarning (pprint decs)
      ; return [] })

$( do { dec1 <- [d| type family F1 (a :: k) :: Type where
                      F1 @Type Int = Bool
                      F1 @Bool 'False = Char |]
      ; reportWarning (pprint dec1)
      ; return [] })


{-# LANGUAGE TemplateHaskell, UnboxedTuples #-}

module TH_unboxedSingleton where

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


module TH_unresolvedInfix2 where

import Language.Haskell.TH

infixl 6 :+

data Tree = N
  | Tree :+ Tree
  | Tree :* Tree

$(return [])

-- Should fail
expr = $( let plus = conE '(:+)
              n = conE 'N
          in infixE Nothing plus (Just $ uInfixE n plus n) )


{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE NoStarIsType #-}

module TH_unresolvedInfix_Lib where

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

infixl 6 :+
infixl 7 :*

data Tree = N
  | Tree :+ Tree
  | Tree :* Tree

-- custom instance, including redundant parentheses
instance Show Tree where
  show N = "N"
  show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")"
  show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")"

-- VarE versions
infixl 6 +:
infixl 7 *:
(+:) = (:+)
(*:) = (:*)

n = conE (mkName "N")
plus = conE (mkName ":+")
times = conE (mkName ":*")

a +? b = uInfixE a plus b
a *? b = uInfixE a times b
a +! b = infixApp a plus b
a *! b = infixApp a times b

plus2 = varE (mkName "+:")
times2 = varE (mkName "*:")
plus3 = conE ('(:+))

--------------------------------------------------------------------------------
--                                  Patterns                                  --
--------------------------------------------------------------------------------
-- The only way to test pattern splices is using QuasiQuotation
mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined
p = conP (mkName "N") []
plus' = mkName ":+"
times' = mkName ":*"

a ^+? b = uInfixP a plus' b
a ^*? b = uInfixP a times' b
a ^+! b = infixP a plus' b
a ^*! b = infixP a times' b

-------------- Completely-unresolved patterns
p1 = mkQQ ( p ^+? (p ^*? p) )
p2 = mkQQ ( (p ^+? p) ^*? p )
p3 = mkQQ ( p ^+? (p ^+? p) )
p4 = mkQQ ( (p ^+? p) ^+? p )
-------------- Completely-resolved patterns
p5 = mkQQ ( p ^+! (p ^*! p) )
p6 = mkQQ ( (p ^+! p) ^*! p )
p7 = mkQQ ( p ^+! (p ^+! p) )
p8 = mkQQ ( (p ^+! p) ^+! p )
-------------- Mixed resolved/unresolved
p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) )
p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) )
p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) )
p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) )
-------------- Parens
p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p )
p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) )
p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) )
-------------- Dropping constructors
p16 = mkQQ ( p ^*? (tupP [p ^+? p]) )

--------------------------------------------------------------------------------
--                                  Types                                     --
--------------------------------------------------------------------------------

infixl 6 +
infixl 7 *
data (+) a b = Plus a b
data (*) a b = Times a b

int = conT (mkName "Int")
tyPlus = mkName "+"
tyTimes = mkName "*"

a $+? b = uInfixT a tyPlus b
a $*? b = uInfixT a tyTimes b
a $+! b = infixT a tyPlus b
a $*! b = infixT a tyTimes b


{-# LANGUAGE ViewPatterns, QuasiQuotes #-}

module Main where

import Language.Haskell.TH

main = do
  p <- runQ [p|(id -> x)|]
  print p
  putStrLn (pprint p)


{-# LANGUAGE TemplateHaskell #-}

module Main where

import Language.Haskell.TH

main = do {d <- runQ $ [| let { foo = bar where bar = 3 } in foo |];  print d}


{-# LANGUAGE TemplateHaskell       #-}

module ASCII () where

import Tree
import PatternGenerator

type EP g = Bool

templateFoo ''EP ['A'..'Z']


module PatternGenerator where

import Tree

import Language.Haskell.TH

templateFoo :: Name -> [Char] -> DecsQ
templateFoo _ _ = return []


module These where

tuc :: t (k, a)
tuc = undefined


module Tree where

import These

mp :: Maybe (Int, ())
mp = tuc


{-# LANGUAGE TemplateHaskell #-}
module A where
a = [|3|]


-- B.hs
{-# LANGUAGE TemplateHaskell #-}
module B where
import A
x = $(a)


{-# LANGUAGE TemplateHaskell #-}
module B where

import {-# SOURCE #-} A ()
--import A ()
import Language.Haskell.TH

expQ :: ExpQ
expQ = [| () |]


{-# LANGUAGE TemplateHaskell #-}
module C where

import B

foo :: a
foo = undefined
  where second = $( expQ )


module Main where

import ModuleA

main = return ()


{-# LANGUAGE TemplateHaskell #-}

module ModuleB where

import ModuleC

$(nothing)


module ModuleC where

import Language.Haskell.TH

import {-# SOURCE #-} ModuleA

nothing = return [] :: Q [Dec]


{-# LANGUAGE TemplateHaskell #-}
module Main where

import Language.Haskell.TH

main :: IO ()
main = putStrLn $(return $ LitE $ StringL "hello")


module C where

import qualified B1
import qualified B2

x = [B1.f,B2.f]


module Main (main) where

import Distribution.Simple

main :: IO ()
main = defaultMain


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
module A where

class Matrix a fa | a -> fa where
    row :: [a] -> fa


{-# LANGUAGE MultiParamTypeClasses #-}
module B where
import A

newtype Val = Val [Int]

instance Matrix Bool Val


module C where

-- !!! a test for missing instances w/ functional dependencies
-- (failed in GHC 5.00.2)

import A
import B

ct0a = row [True,False,True,False]


{-# LANGUAGE TypeOperators #-}

module A where

type a :+ b = (a,b)
infixr 1 :+


{-# LANGUAGE TypeOperators #-}

module B where
import A

a :: Int :+ Float :+ Double
a = undefined

b :: Int
b = case a of (p,q) -> p


module AbstractRefinementSubstitutions where

f :: [Integer] -> Integer
f = _

g :: [Integer] -> Integer
g = _ 0


module ConstraintSubstitutions where

g :: Ord a => [a] -> a
g = _


module DfltProb1 where

import Control.Monad.ST
import Prelude hiding (traverse)

traverse :: a -> ST s [a]
traverse = undefined

-- WORKS with signature test :: Num a => [a]
test = runST (traverse 1)

main = print test


module DfltProb2 where

{- NB: This program fails in GHC 7.4.1 but should be accepted with our new defaulting plan -}

f :: Int -> Bool
f x = const True (\y -> let w :: a -> a
                            w a = const a (y+1)
                        in w y)

{- The implication constraint we get here is that (y::beta):
            [untch=beta] forall a. 0 => Num beta
   and we can't really do any defaulting in this scope.

   Instead with our new defaulting plan we

     (i) try to approximate the whole constraint
     (ii) /then/ we try to default (and succeed)
     (iii) then try to resolve again

   See Note [Top-level Defaulting Plan] in TcSimplify -}


{-# LANGUAGE ViewPatterns, GADTs #-}

module ExPat where

data T where
  MkT :: Integral a => a -> Int -> T

-- c.f. T11700

-- Succeeds because y::Int
f x = let MkT _ y  = x
      in y

-- Remarkablly, this succeeds because
--   (toInteger (v::a)) is an Integer
g x = let MkT (toInteger -> y) _ = x
      in y


{-# LANGUAGE GADTs #-}

module ExPatFail where

data T where
  MkT :: Integral a => a -> Int -> T

-- Fails because y is bound to an existential type
-- Mind you, the error message is pretty terrible
-- c.f. T11700

f x = let MkT y _ = x
      in y


{-# LANGUAGE RankNTypes #-}

-- A classic test for type inference
-- Taken from "Haskell and principal types", Section 3
-- by Faxen, in the Haskell Workshop 2003, pp88-97

module ShouldCompile where

import GHC.List (null)
import Prelude hiding (null)

class HasEmpty a where
  isEmpty :: a -> Bool

instance HasEmpty [a] where
  isEmpty x = null x

instance HasEmpty (Maybe a) where
  isEmpty Nothing  = True
  isEmpty (Just x) = False

test1 y
  =  (null y)
  || (let f :: forall d. d -> Bool
          f x = isEmpty (y >> return x)
      in f y)

test2 y
  =  (let f :: forall d. d -> Bool
          f x = isEmpty (y >> return x)
      in f y)
  || (null y)


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}

-- Trac #1781
-- This one should really succeed, because 'plus' can only
-- be called with a = Int->Int, but the old fundep story
-- certainly made it fail, and so that's what we expect for now
-- We may become more liberal later

module ShouldCompile where

class E a b | a -> b, b -> a
instance E a a

plus :: (E a (Int -> Int)) => Int -> a
plus x y = x + y


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE ScopedTypeVariables, FlexibleContexts #-}

-- Trac #1783
-- Like Trac #1781 you could argue that this one should succeed
-- but we stick with the old behaviour for now.  When we do
-- fundeps properly it'll probably start to work

module ShouldCompile where

import Prelude hiding (foldr, foldr1)

import Data.Maybe

class Elem a e | a -> e

class Foldable a where
  foldr :: Elem a e => (e -> b -> b) -> b -> a -> b

--  foldr1 :: forall e. Elem a e => (e -> e -> e) -> a -> e  -- WORKS!
  foldr1 :: Elem a e => (e -> e -> e) -> a -> e
  foldr1 f xs = fromMaybe (error "foldr1: empty structure")
                  (foldr mf Nothing xs)
     where mf :: Elem a e => (e -> Maybe e -> Maybe e)
           mf x Nothing  = Just x
           mf x (Just y) = Just (f x y)


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, FlexibleInstances #-}

-- Trac #1795

module ShouldCompile where

data A a = A

class MkA a b | a -> b where
   mkA :: a -> A b

instance MkA a a where

translate :: (String, a) -> A a
translate a = mkA a

{- From the call to mkA

[W] MkA alpha beta
[W] alpha ~ (String,a)
[W] A beta ~ A a

==>  beta:=a, alpha:=(String,a)
-}


{-# LANGUAGE
    MultiParamTypeClasses,
    FunctionalDependencies,
    UndecidableInstances,
    FlexibleInstances,
    EmptyDataDecls #-}

-- Trac #1797

module ShouldCompile where

data True

data False

class TypeEq type1 type2 result | type1 type2 -> result where
    typeEq :: type1 -> type2 -> result

instance TypeEq soleType soleType True where
    typeEq _ _ = undefined

instance (TypeCast False result) => TypeEq type1 type2 result where
    typeEq _ _ = undefined

class TypeCast type1 type2 | type1 -> type2, type2 -> type1

instance TypeCast soleType soleType


{-# OPTIONS_GHC -frefinement-level-hole-fits=2 #-}
{-# LANGUAGE MonoLocalBinds #-}
module TG where
import Prelude ( Monad, Applicative, Functor
               , fmap, (<*>), pure, (>>=)
               , (=<<), ($), (<$>) )

data Free f a = Pure a | Free (f (Free f a))

instance Functor f => Functor (Free f) where
    fmap f = go where
      go (Pure a) =  Pure (f a)
      -- Should suggest (fmap)
      go (Free fa) = Free (_a go fa)

instance Functor f => Applicative (Free f) where
  pure = Pure
  Pure a <*> Pure b = Pure (a b)
  Pure a <*> Free mb = Free (fmap a <$> mb)
  Free ma <*> b = Free ((<*> b) <$> ma)

instance Applicative f => Monad (Free f) where
    Pure a >>= f = f a
      -- Should suggest ((=<< (_ :: a -> Free f b))
    Free f >>= g = Free (fmap _a f)


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE FunctionalDependencies, FlexibleContexts #-}

class C a where

class D a where
 dop :: a -> a

instance C a => D [a] where
 dop = undefined

class J a b | a -> b
 where j :: a -> b -> ()

instance J Bool Int where
 j = undefined

foo :: D [Int] => ()
-- Weird test case: (D [Int]) is simplifiable
foo = j True (head (dop [undefined]))

main = return ()


{-# LANGUAGE TypeFamilies #-}
module Main where

data A a

type T a = A a

f :: (A a ~ T Int) => a -> Int
f x = x

main :: IO ()
main = return ()


{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}

-- Provided by Christian Maeder; broke
-- a pre-release GHC 7.0

module HasKey where

class Ord key => HasKey x key | x -> key where
   toKey :: x -> key

newtype Keyed x = Keyed { unKey :: x }

lift :: (HasKey x1 key1,HasKey x2 key2)
   => (key1 -> key2 -> a) -> (Keyed x1 -> Keyed x2 -> a)
lift f x1 x2 = f (toKey . unKey $ x1) (toKey . unKey $ x2)

instance HasKey x key => Eq (Keyed x) where
   (==) = lift (==)

instance HasKey x key => Ord (Keyed x)


module Holes where

f = _

g :: Int -> Char
g x = _

h = _ ++ "a"

z :: [a] -> [a]
z y = const y _


module Holes3 where

f = _

g :: Int -> Char
g x = _gr

h = _aa ++ "a"

z :: [a] -> [a]
z y = const y _x


{-# OPTIONS_GHC -fshow-hole-constraints #-}
{-# LANGUAGE GADTs, TypeOperators #-}
module HoleConstraints where
import Data.Type.Equality hiding (castWith)

-- "from the signature of f1"
f1 :: Eq a => a
f1 = _

-- "from the signature of f2", only once
f2 :: (Show a, Eq a) => a
f2 = _

-- "from the instance declaration"
class C a where f3 :: a
instance Eq a => C [a] where f3 = _

-- "from a pattern with constructor ... in an equation for 'castWith'"
castWith :: a :~: b -> a -> b
castWith Refl x = _

data AnyShow where
  AnyShow :: Show a => a -> AnyShow

-- "from a pattern with constructor ... in a case alternative"
foo :: AnyShow -> String
foo a = case a of AnyShow x -> _


{-# OPTIONS_GHC -fshow-hole-constraints #-}
{-# LANGUAGE GADTs, TypeOperators #-}
module HoleConstraintsNested where
import Data.Type.Equality

data EqOrd a where EqOrd :: (Eq a, Ord a) => EqOrd a

f :: a :~: b -> EqOrd a -> Int
f d1 d2 =
  case d1 of
    Refl -> case d2 of
      EqOrd -> _


{-# LANGUAGE TypeFamilies, FlexibleContexts, MultiParamTypeClasses, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

-- This one relies on doing instance reduction
-- on a /derived/ class
--    [W] C (F a0) a0, F a0 ~ Bool
-- Currently (Oct 16) I've disabled this because it seems like
-- overkill.
--
-- See Note Note [No reduction for Derived class constraints]
-- in TcInteract

module Foo where

type family F a
type instance F Int = Bool

class C a b where

instance (b~Int) => C Bool b

blug :: C (F a) a => a -> F a
blug = error "Urk"

foo :: Bool
foo = blug undefined


import Prelude (Show, String, error, IO(), show, Ordering(EQ))

head :: [a] -> a
head (x:xs) = _
head _ = error "Empty list!"

mshow :: Show a => a -> a
mshow a = _

main :: IO ()
main = error "no main"


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}

-- Compiles fine.
-- Instance selection works fine.
-- try: :t foo (T1b T1a)

module ShouldCompile where

-- Notice: T1 is a recursive type.
-- Notice: the classes are recursive, too.
-- Why does this work when almost the same thing doesn't?
-- Say: adding an Int component to T1a makes things loop.
-- See LoopOfTheDay2.hs and LoopOfTheDay3.hs.

data T1 = T1a | T1b T1

class C0 x where foo :: x -> (); foo = undefined
class C1 x y
class C1 x y => C2 x y

instance C0 T1              => C1 () T1         -- (I1)
instance (C1 x T1)          => C2 x T1          -- (I2)
instance C2 () T1           => C0 T1            -- (I3)

baz = foo (T1b T1a)

{- Need         C0 T1
-->(I3)         C2 () T1
-->(I2)         C1 () T1
-->(I1)         C0 T1           -- STOP because we've seen this before
-}


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-}

-- Compilation loops in GHC 6.2!
-- While LoopOfTheDay1.hs did compile and work,
-- this one loops during compilation, even though
-- there is only an innocent difference regarding T1,
-- i.e., an additional, non-recursive constructor component.

module ShouldCompile where

data T1 = T1a Int | T1b T1

class C0 x where foo :: x -> (); foo = undefined
-- foo :: C0 x => x -> ()

class C1 x y
class C1 x y => C2 x y

instance C0 Int              => C1 () Int       -- I1
instance C0 T1               => C1 () T1        -- I2
instance (C1 x T1, C1 x Int) => C2 x T1         -- I3
instance C1 x Int            => C2 x Int        -- I4
instance C2 () T1            => C0 T1           -- I5
instance C2 () Int           => C0 Int          -- I6

baz = foo (T1b (T1a 3))

{- Need
                C0 T1
-->(I5)         C2 () T1
-->(I3)         C1 () T1, C1 () Int
-->(I1,I2)      C0 T1, C0 Int
-->(recusive)   C0 Int
-->(I6)         C2 () Int
-->(I4)         C1 () Int
-->(recursive)  {}
-}


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances,
             UndecidableInstances #-}

-- Instances compile fine but instance selection loops in GHC 6.2.
-- try: :t foo (T1a 1)
-- This is essentially the same as LoopOfTheDay2.hs
-- but with the innocent (?) use of overlapping instances.

module ShouldCompile where

data T1 = T1a Int | T1b T1

class C0 x where foo :: x -> (); foo = undefined
class C1 x y
class C1 x y => C2 x y

instance C0 a                => C1 () a
instance (C1 x T1, C1 x Int) => C2 x T1
instance C1 x Int            => C2 x Int
instance C2 () a             => C0 a

baz = foo (T1b (T1a 3))


-- Checks that the types of the old binder and the binder implicitly introduced by grouping are linked

{-# OPTIONS_GHC -XMonadComprehensions -XTransformListComp #-}

module ShouldCompile where

import Data.List(inits)

foo :: [[[Int]]]
foo = [ x
      | x <- [1..10]
      , then group using inits
      , then group using inits
      ]


{-# OPTIONS_GHC -Werror -fwarn-missing-export-lists #-}
module ShouldCompile (foo) where

foo :: String
foo = "foo"


{-# OPTIONS_GHC -Werror -fwarn-missing-export-lists #-}
module ShouldCompile () where

foo :: String
foo = "foo"


module MutRec where

-- Mutual recursion with different
-- names for the same type variable
f t = x
  where
    x :: [a]
    y :: b
    (x,y,z,r) = ([y,z], z, head x, t)


-- An example of RelaxedPolyRec in action which came up
-- on Haskell Cafe June 2010 (Job Vranish)

module Foo where

import Data.Maybe

-- The fixed point datatype
data Y f = Y (f (Y f))

-- Silly dummy function
maybeToInt :: Maybe a -> Int
maybeToInt = length . maybeToList

---------------------------
-- f and g are mutually recursive
-- Even though f has a totally monomorphic
-- signature, g has a very polymorphic one

f :: Y Maybe -> Int
f (Y x) = g maybeToInt x

-- With RelaxedPolyRec we can infer this type
-- g :: Functor f => (f Int -> b) -> f (Y Maybe) -> b
g h x = h $ fmap f x

-- 'test' checks that g's type is polymorphic enough
test :: Functor f => (f Int -> b) -> f (Y Maybe) -> b
test = g


{-# LANGUAGE TypeFamilies, LiberalTypeSynonyms, ImpredicativeTypes #-}
module PolyTypeDecomp where

{- The purpose of this test is to check if decomposition of wanted
   equalities in the /constraint solver/ (vs. the unifier) works properly.
   Unfortunately most equalities between polymorphic types are converted to
   implication constraints early on in the unifier, so we have to make things
   a bit more convoluted by introducing the myLength function. The wanted
   constraints we get for this program are:
      [forall a. Maybe a] ~ Id alpha
      [forall a. F [a]]   ~ Id alpha
   Which, /after reactions/ should create a fresh implication:
      forall a. Maybe a ~ F [a]
   that is perfectly soluble.
-}

type family F a
type instance F [a] = Maybe a

type family Id a
type instance Id a = a

f :: [forall a. F [a]]
f = undefined

g :: [forall a. Maybe a] -> Int
g x = myLength [x,f]

myLength :: [Id a] -> Int
myLength = undefined


{-# LANGUAGE RankNTypes #-}

module PushHRIf where

foo = (if True then id else id) :: forall a. a -> a

bar = (foo 'x', foo True)


{-# LANGUAGE RebindableSyntax, GADTs, RankNTypes, TypeOperators, ScopedTypeVariables #-}

module RebindHR where

import Prelude hiding ( (>>=) )
import Data.Typeable

data Exp = Int Int | Plus Exp Exp | Bool Bool
data TExp a where
  TInt :: Int -> TExp Int
  TPlus :: TExp Int -> TExp Int -> TExp Int
  TBool :: Bool -> TExp Bool

(>>=) :: ((forall t. Typeable t => TExp t -> Maybe r) -> Maybe r)
      -> (forall t. Typeable t => TExp t -> Maybe r)
      -> Maybe r
x >>= y = x y

check :: Exp -> (forall t. Typeable t => TExp t -> Maybe r) -> Maybe r
check (Int n) k = k (TInt n)
check (Bool b) k = k (TBool b)
check (Plus e1 e2) k = do te1 :: TExp ty1 <- check e1
                          te2 :: TExp ty2 <- check e2
                          case (eqT :: Maybe (ty1 :~: Int), eqT :: Maybe (ty2 :~: Int)) of
                            (Just Refl, Just Refl) -> k (TPlus te1 te2)
                            _ -> Nothing


{-# LANGUAGE RebindableSyntax #-}

module RebindNegate where

import Prelude ( length )

negate = length

y = - "foo"


module RefinementSubstitutions where

f :: [Integer] -> Integer
f = _

g :: [Integer] -> Integer
g = _ 0


{-# LANGUAGE FlexibleContexts #-}

module RepArrow where

import Data.Ord ( Down )  -- convenient "Id" newtype, without its constructor
import Data.Coerce

foo :: Coercible (Down (Int -> Int)) (Int -> Int) => Down (Int -> Int) -> Int -> Int
foo = coerce


{-# LANGUAGE ScopedTypeVariables #-}

module SigTyVars where

-- Here the lexically scoped type variables 'a' and 'b'
-- both map to the same skolem 'x'.  It's perhaps a bit
-- surprising, but it's awkward to prevent, and it seems
-- easier to leave it.

f :: x -> x -> [x]
f (x::a) (y::b) = [x::b, y::a]


{-# LANGUAGE ScopedTypeVariables, TypeOperators, DataKinds, PolyKinds,
             TypeFamilies, GADTs, StandaloneDeriving #-}

module SplitWD where

import Data.Kind ( Type )

data Nat = Zero | Succ Nat

type family a + b where
  Zero + b = b
  Succ a + b = Succ (a + b)
infixl 6 +

data Vec :: Type -> Nat -> Type where
  VNil :: Vec a Zero
  (:>) :: a -> Vec a n -> Vec a (Succ n)
infixr 5 :>

type family (xs :: Vec a n) +++ (ys :: Vec a m) :: Vec a (n + m) where
  VNil +++ ys = ys
  (x :> xs) +++ ys = x :> (xs +++ ys)
infixr 5 +++

data Exp :: Vec Type n -> Type -> Type where
  Var :: Elem xs x -> Exp xs x

data Elem :: forall a n. Vec a n -> a -> Type where
  Here :: Elem (x :> xs) x
  There :: Elem xs x -> Elem (y :> xs) x

-- | @Length xs@ is a runtime witness for how long a vector @xs@ is.
-- @LZ :: Length xs@ says that @xs@ is empty.
-- @LS len :: Length xs@ tells you that @xs@ has one more element
-- than @len@ says.
-- A term of type @Length xs@ also serves as a proxy for @xs@.
data Length :: forall a n. Vec a n -> Type where
  LZ :: Length VNil
  LS :: Length xs -> Length (x :> xs)

deriving instance Show (Length xs)

-- | Convert an expression typed in one context to one typed in a larger
-- context. Operationally, this amounts to de Bruijn index shifting.
-- As a proposition, this is the weakening lemma.
shift :: forall ts2 t ty. Exp ts2 ty -> Exp (t :> ts2) ty
shift = go LZ
  where
    go :: forall ts1 ty. Length ts1 -> Exp (ts1 +++ ts2) ty -> Exp (ts1 +++ t :> ts2) ty
    go l_ts1 (Var v)          = Var (shift_elem l_ts1 v)

    shift_elem :: Length ts1 -> Elem (ts1 +++ ts2) x
               -> Elem (ts1 +++ t :> ts2) x
    shift_elem = undefined


f :: [String]
f = _ "hello, world"

main :: IO ()
main = return ()


{-# LANGUAGE TypeOperators, DeriveDataTypeable #-}

-- This is a performance test.  In GHC 6.4, it simply wouldn't compile
-- because the types got exponentially large, due to poor handling of
-- type synonyms

module ShouldCompile where

import Data.Word
import Data.Int
import Data.Typeable

data HNil      = HNil      deriving (Eq,Show,Read)
data HCons e l = HCons e l deriving (Eq,Show,Read)

type e :*: l = HCons e l
        -- In GHC 6.4 the deeply-nested use of this
        -- synonym gave rise to exponential behaviour

--- list endian16
newtype Tables = Tables [TableInfo] deriving (Show, Typeable)

type TableInfo =
    AvgPot :*:
    NumPlayers :*:
    Waiting :*:
    PlayersFlop :*:
    TableName :*:
    TableID :*:
    GameType :*:
    InfoMaxPlayers :*:
    RealMoneyTable :*:
    LowBet :*:
    HighBet :*:
    MinStartMoney :*:
    MaxStartMoney :*:
    GamesPerHour :*:
    TourType :*:
    TourID :*:
    BetType :*:
    CantReturnLess :*:
    AffiliateID :*:
    NIsResurrecting :*:
    MinutesForTimeout :*:
    SeatsToResurrect :*:
    LangID :*:
    HNil

newtype TourType = TourType TourType_ deriving (Show, Typeable)
newtype AvgPot = AvgPot Word64 deriving (Show, Typeable)
newtype NumPlayers = NumPlayers Word16 deriving (Show, Typeable)
newtype Waiting = Waiting Word16 deriving (Show, Typeable)
newtype PlayersFlop = PlayersFlop Word8 deriving (Show, Typeable)
newtype TableName = TableName String deriving (Show, Typeable)
newtype TableID = TableID Word32 deriving (Show, Typeable)
newtype OldTableID = OldTableID Word32 deriving (Show, Typeable)
newtype GameType = GameType GameType_ deriving (Show, Typeable)
newtype InfoMaxPlayers = InfoMaxPlayers Word16 deriving (Show, Typeable)
newtype RealMoneyTable = RealMoneyTable Bool deriving (Show, Typeable)
newtype LowBet = LowBet RealMoney_ deriving (Show, Typeable)
newtype HighBet = HighBet RealMoney_ deriving (Show, Typeable)
newtype MinStartMoney = MinStartMoney RealMoney_ deriving (Show, Typeable)
newtype MaxStartMoney = MaxStartMoney RealMoney_ deriving (Show, Typeable)
newtype GamesPerHour = GamesPerHour Word16 deriving (Show, Typeable)
newtype TourID = TourID Word32 deriving (Show, Typeable)
newtype BetType = BetType BetType_ deriving (Show, Typeable)
newtype CantReturnLess = CantReturnLess Word32 deriving (Show, Typeable)
newtype AffiliateID = AffiliateID [Word8] deriving (Show, Typeable)
newtype NIsResurrecting = NIsResurrecting Word32 deriving (Show, Typeable)
newtype MinutesForTimeout = MinutesForTimeout Word32 deriving (Show, Typeable)
newtype SeatsToResurrect = SeatsToResurrect Word32 deriving (Show, Typeable)
newtype LangID = LangID Word32 deriving (Show, Typeable)

data GameType_
    = EmptyGame
    | Holdem
    | OmahaHoldem
    | OmahaHiLo
    | SevenCardStud
    | SevenCardStudLoHi
    | OneToOne
    | OneToOneOmaha
    | OneToOne7CS
    | OneToOneOmahaHL
    | OneToOne7CSHL
    | TeenPatti
    | OneToOneTeenPatti
      deriving (Eq, Show, Typeable)

type RealMoney_ = Word64

data TourType_
    = TourNone
    | TourSingle
    | TourMulti
    | TourHeadsUpMulti
    deriving (Enum, Eq, Show, Typeable)

data BetType_
    = BetNone
    | BetFixed
    | BetPotLimit
    | BetNoLimit
    | BetBigRiver
    | BetTeenPatti
    | BetTeenPattiFixed
    deriving (Enum, Eq, Show, Typeable)


-- Another type-synonym performance test
--      (Trac 323)
-- Fails in GHC up to 6.6

module ShouldCompile where

type S = Maybe
type S2 n = S (S n)
type S4 n = S2 (S2 n)
type S8 n = S4 (S4 n)
type S16 n = S8 (S8 n)
type S32 n = S16 (S16 n)

type N64 n = S32 (S32 n)

type N64' =
   S ( S ( S ( S ( S ( S ( S ( S (
   S ( S ( S ( S ( S ( S ( S ( S (
   S ( S ( S ( S ( S ( S ( S ( S (
   S ( S ( S ( S ( S ( S ( S ( S (
   S ( S ( S ( S ( S ( S ( S ( S (
   S ( S ( S ( S ( S ( S ( S ( S (
   S ( S ( S ( S ( S ( S ( S ( S (
   S ( S ( S ( S ( S ( S ( S ( S (
   Int
   ))))))))
   ))))))))
   ))))))))
   ))))))))
   ))))))))
   ))))))))
   ))))))))
   ))))))))


{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
module T10009 where

type family F a
type family UnF a

f :: (UnF (F b) ~ b) => F b -> ()
f = error "urk"

g :: forall a. (UnF (F a) ~ a) => a -> ()
g _ = f (undefined :: F a)

{- ---------------
[G] UnF (F b) ~ b

[W] UnF (F beta) ~ beta
[W] F a ~ F beta

-------------------
[G] g1: F a ~ fsk1         fsk1 := F a
[G] g2: UnF fsk1 ~ fsk2    fsk2 := UnF fsk1
[G] g3: fsk2 ~ a

[W] w1: F beta ~ fmv1
[W] w2: UnF fmv1 ~ fmv2
[W] w3: fmv2 ~ beta
[W] w5: fsk1 ~ fmv1   -- From F a ~ F beta
                      -- using flat-cache

---- No progress in solving -----
-- Unflatten:

[W] w3: UnF (F beta) ~ beta
[W] w5: fsk1 ~ F beta

--- Improvement

[D] F beta ~ fmv1
[D] UnF fmv1 ~ fmv2    -- (A)
[D] fmv2 ~ beta
[D] fmv1 ~ fsk1        -- (B) From F a ~ F beta
                       -- NB: put fmv on left

--> rewrite (A) with (B), and match with g2

[D] F beta ~ fmv1
[D] fmv2 ~ fsk2        -- (C)
[D] fmv2 ~ beta        -- (D)
[D] fmv1 ~ fsk1

--> rewrite (D) with (C) and re-orient

[D] F beta ~ fmv1
[D] fmv2 ~ fsk2
[D] beta ~ fsk2       -- (E)
[D] fmv1 ~ fsk1

-- Now we can unify beta!
-}

{-

-----
Inert: [G] fsk_amA ~ b_amr
       [G] UnF fsk_amy ~ fsk_amA
       [G} F b_amr ~ fsk_amy

wl: [W] F b_amr ~ F b_amt

work item: [W] UnF (F b_amt) ~ b_amt
  b_amt is the unification variable

===>      b_amt := s_amF

Inert: [G] fsk_amA ~ b_amr
       [G] UnF fsk_amy ~ fsk_amA
       [G} F b_amr ~ fsk_amy

wl: [W] F b_amr ~ F b_amt
    [W] UnF s_amD ~ s_amF

work item: [W] F b_amt ~ s_amD

===>
wl: [W] F b_amr ~ F b_amt
    [W] UnF s_amD ~ s_amF

Inert: [G] fsk_amA ~ b_amr
       [G] UnF fsk_amy ~ fsk_amA
       [G} F b_amr ~ fsk_amy
       [W] F s_amF ~ s_amD

===>
wl: [W] F b_amr ~ F b_amt

Inert: [G] fsk_amA ~ b_amr
       [G] UnF fsk_amy ~ fsk_amA
       [G} F b_amr ~ fsk_amy
       [W] F s_amF ~ s_amD
       [W] UnF s_amD ~ s_amF

===>
Inert: [G] fsk_amA ~ b_amr
       [G] UnF fsk_amy ~ fsk_amA
       [G} F b_amr ~ fsk_amy
       [W] UnF s_amD ~ s_amF
       [W] F s_amF ~ s_amD

wl:

work-item: [W] F b_amr ~ F b_amt
--> fsk_amy ~ s_amD
--> s_amD ~ fsk_amy

===>
Inert: [G] fsk_amA ~ b_amr
       [G] UnF fsk_amy ~ fsk_amA
       [G} F b_amr ~ fsk_amy
       [W] UnF s_amD ~ s_amF
       [W] F s_amF ~ s_amD
       [W] s_amD ~ fsk_amy

wl:

work item: [D] UnF s_amD ~ s_amF

--> [D] UnF fsk_amy ~ s_amF
--> [D] s_amF ~ fsk_amA

===>
Inert: [G] fsk_amA ~ b_amr
       [G] UnF fsk_amy ~ fsk_amA
       [G} F b_amr ~ fsk_amy
       [W] UnF s_amD ~ s_amF
       [W] F s_amF ~ s_amD
       [W] s_amD ~ fsk_amy
       [D] s_amF ~ fsk_amA

wl:

work item: [D] F s_amF ~ s_amD
--> F fsk_amA ~ s_amD
--> s_amd ~ b_amr
-}


{-# LANGUAGE ScopedTypeVariables #-}
module T10031 where
import Data.Coerce
coerce' :: Coercible b a => a -> b
coerce' = coerce (\x -> x :: b) :: forall a b. Coercible b a => a -> b


module T0072 where
{-# RULES
"map/empty" forall (f :: a -> _). map f [] = []
  #-}


{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE UndecidableInstances   #-}

module T10100 where

data Zero
data Succ a

class Add a b ab | a b -> ab, a ab -> b
instance Add Zero b b
instance (Add a b ab) => Add (Succ a) b (Succ ab)


{-# LANGUAGE PolyKinds, MultiParamTypeClasses, FunctionalDependencies,
             UndecidableInstances, FlexibleInstances #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module T10109 where

data Succ a

class Add (a :: k1) (b :: k2) (ab :: k3) | a b -> ab
instance (Add a b ab) => Add (Succ a) b (Succ ab)


{-# LANGUAGE FlexibleContexts, TypeFamilies #-}

module T10156 where

import Data.Coerce

data Iso a b = Iso (a -> b) (b -> a)

coerceIso :: Coercible a b => Iso a b
coerceIso = Iso coerce coerce

type family F x

f :: (Coercible a (F b), Coercible c (F b)) => a -> b -> c
f x _ = coerce x


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
    -- This test deliberately uses a simplifiable class constraint

module T10177 where

import Data.Typeable

newtype V n a = V [a]

class    Typeable a                   => C a
instance (Typeable (V n), Typeable a) => C (V n a)


module T10184 where

import Data.Coerce

newtype Bar a = Bar (Either a (Bar a))
newtype Age = MkAge Int

x :: Bar Age
x = coerce (Bar (Left (5 :: Int)))


module T10185 where

import Data.Coerce
import Data.Proxy

foo :: (Coercible (a b) (c d), Coercible (c d) (e f)) => Proxy (c d) -> a b -> e f
foo _ = coerce


{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-simplifiable-class-constraints #-}
{-# LANGUAGE MultiParamTypeClasses, TypeFamilies, GADTs,
             ConstraintKinds, DataKinds, KindSignatures,
             FlexibleInstances #-}

module T10195 where

import Data.Kind

data Foo m zp r'q = Foo zp
data Dict :: Constraint -> Type where
  Dict :: a => Dict a

type family BarFamily a b :: Bool
class Bar m m'
instance (BarFamily m m' ~ 'True) => Bar m m'

magic :: (Bar m m') => c m zp -> Foo m zp (c m' zq)
-- Weird test case: (Bar m m') is simplifiable
magic = undefined

getDict :: a -> Dict (Num a)
getDict _ = undefined
fromScalar :: r -> c m r
fromScalar = undefined

foo :: (Bar m m')
  => c m zp -> Foo m zp (c m' zq) -> Foo m zp (c m' zq)
-- Weird test case: (Bar m m') is simplifiable
foo b (Foo sc) =
  let scinv = fromScalar sc
  in case getDict scinv of
    Dict -> magic $ scinv * b


{-# OPTIONS_GHC -fdefer-type-errors -fno-warn-deferred-type-errors #-}
{-# LANGUAGE ImpredicativeTypes #-}

module T9834 where
import Control.Applicative
import Data.Functor.Identity

type Nat f g = forall a. f a -> g a

newtype Comp p q a = Comp (p (q a))

liftOuter :: (Functor p, Applicative q) => p a -> (Comp p q) a
liftOuter pa = Comp (pure <$> pa)

runIdComp :: Functor p => Comp p Identity a -> p a
runIdComp (Comp p) = runIdentity <$> p

wrapIdComp :: Applicative p => (forall q. Applicative q => Nat (Comp p q) (Comp p q)) -> p a -> p a
wrapIdComp f = runIdComp . f . liftOuter

class Applicative p => ApplicativeFix p where
  afix :: (forall q. Applicative q => (Comp p q) a -> (Comp p q) a) -> p a
  afix = wrapIdComp


{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, ConstraintKinds #-}

module Foo where

type X a = (Eq a, Show a)

class Eq a => C a b

-- HEAD was unable to find the (Eq a) superclass
-- for a while in March/April 2015
instance X a => C a [b]


{-# OPTIONS_GHC -fwarn-unused-binds #-}

module T10347 (N, mkN) where

import Data.Coerce

newtype N a = MkN Int

mkN :: Int -> N a
mkN = coerce


{-# LANGUAGE GADTs, DataKinds, KindSignatures, StandaloneDeriving, TypeOperators #-}

module T10348 where

import GHC.TypeLits
import Data.Typeable
import Data.Proxy

data Foo (n :: Nat) where
  Hey :: KnownNat n => Foo n

deriving instance Show (Foo n)

data T t where
  T :: (Show t, Typeable t) => t -> T t

deriving instance Show (T n)

hey :: KnownNat n => T (Foo n)
hey = T Hey

ho :: T (Foo 42)
ho = T Hey

f1 :: KnownNat a => Proxy a -> TypeRep
f1 = typeRep

g2 :: KnownSymbol a => Proxy a -> TypeRep
g2 = typeRep

pEqT :: (KnownSymbol a, KnownSymbol b) => Proxy a -> Proxy b -> Maybe (a :~: b)
pEqT Proxy Proxy = eqT


{-# LANGUAGE RankNTypes #-}

module T10390 where

class ApPair r where
  apPair :: (forall a . (ApPair a, Num a) => Maybe a) -> Maybe r

instance (ApPair a, ApPair b) => ApPair (a,b) where
  apPair = apPair'

apPair' :: (ApPair b, ApPair c)
        => (forall a . (Num a, ApPair a) => Maybe a) -> Maybe (b,c)
            -- NB constraints in a different order to apPair
apPair' f =  let (Just a) = apPair f
                 (Just b) = apPair f
          in Just $ (a, b)


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

module T10423 where

class Monad m => Testable m a

newtype Prop m = MkProp (m Int)

instance (Monad m, m ~ n) => Testable n (Prop m)


module T10428 where

import Data.Coerce
coerceNewtype :: (Coercible (o r) (n m' r)) => [o r] -> [n m' r]
coerceNewtype = coerce


{-# LANGUAGE ExistentialQuantification, PolyKinds,
             DataKinds, RankNTypes, GADTs, TypeOperators #-}
module T10432 where

import Data.Kind (Type)
import Data.Type.Equality

data WrappedType = forall a. WrapType a;

matchReflK :: forall ka kb (a :: ka) (b :: kb) (r :: Type).
  ('WrapType a :~: 'WrapType b) -> (('WrapType a ~ 'WrapType b) => r) -> r;
  matchReflK Refl r = r;

matchReflK2 :: forall ka kb (a :: ka) (b :: kb) (r :: Type).
               ('WrapType a :~: 'WrapType b) ->  r
matchReflK2 x = let foo :: ('WrapType a ~ 'WrapType b) => r
                    foo = undefined
                in undefined


module T10489 where

-- Triggered an ASSERT in a debug build at some point.
convert d = let d' = case d of '0' -> '!' in d'


{-# LANGUAGE FlexibleContexts #-}

module T10493 where

import Data.Coerce
import Data.Ord (Down)  -- no constructor

foo :: Coercible (Down Int) Int => Down Int -> Int
foo = coerce


module App where

import Data.Coerce

foo :: Coercible (a b) (c d) => a b -> c d
foo = coerce


{-# LANGUAGE GADTs, TypeFamilies #-}
module T10562 where

type family Flip a

data QueryRep qtyp a where
    QAtom :: a -> QueryRep () a
    QOp   :: QueryRep (Flip qtyp) a -> QueryRep qtyp a

instance Eq (QueryRep qtyp a) where
  (==) = error "urk"

instance (Ord a) => Ord (QueryRep qtyp a) where
  compare (QOp a) (QOp b) = a `compare` b


{-# LANGUAGE FlexibleInstances, FlexibleContexts, UndecidableInstances,
             DataKinds, TypeFamilies, KindSignatures, PolyKinds, FunctionalDependencies #-}
{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}

module T10564 where

import Data.Kind (Type)

class HasFieldM (l :: k) r (v :: Maybe Type)
        | l r -> v

class HasFieldM1 (b :: Maybe [Type]) (l :: k) r v
        | b l r -> v

class HMemberM (e1 :: k) (l :: [k]) (r :: Maybe [k])
        | e1 l -> r

data Label a
type family LabelsOf (a :: [Type]) ::  [Type]

instance (HMemberM (Label (l::k)) (LabelsOf xs) b,
            HasFieldM1 b l (r xs) v)
         => HasFieldM l (r xs) v where


{-# LANGUAGE LambdaCase, TypeFamilies #-}

module T10589 where

type family F a where
  F a = Bool -> a

foo = (\case True -> 5
             False -> 6) :: F Int


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module T10592 where

import Data.Kind (Type)
import Prelude (Bool(True,False),Integer,Ordering)
import qualified Prelude

--------------------
-- class hierarchy

class Boolean (Logic a) => Eq a where
    type Logic a :: Type
    (==) :: a -> a -> Logic a

    (/=) :: a -> a -> Logic a
    a/=b = not (a==b)

class Eq a => POrd a where
    inf :: a -> a -> a

class POrd a => MinBound a where
    minBound :: a

class POrd a => Lattice a where
    sup :: a -> a -> a

class (Lattice a, MinBound a) => Bounded a where
    maxBound :: a

class Bounded a => Complemented a where
    not :: a -> a

class Bounded a => Heyting a where
    infixr 3 ==>
    (==>) :: a -> a -> a

class (Complemented a, Heyting a) => Boolean a

(||) :: Boolean a => a -> a -> a
(||) = sup

(&&) :: Boolean a => a -> a -> a
(&&) = inf

--------------------
-- Bool instances
-- (these work fine)

instance Eq Bool where
    type Logic Bool = Bool
    (==) = (Prelude.==)

instance POrd Bool where
    inf True  True  = True
    inf _     _     = False

instance MinBound Bool where
    minBound = False

instance Lattice Bool where
    sup False False = False
    sup _     _     = True

instance Bounded Bool where
    maxBound = True

instance Complemented Bool where
    not True  = False
    not False = True

instance Heyting Bool where
    False ==> _ = True
    True  ==> a = a

instance Boolean Bool

--------------------
-- Integer instances
-- (these work fine)

instance Eq Integer where
    type Logic Integer = Bool
    (==) = (Prelude.==)

instance POrd Integer where
    inf = Prelude.min

instance Lattice Integer where
    sup = Prelude.max

--------------------
-- function instances
-- (these cause GHC to loop)

instance Eq b => Eq (a -> b) where
    type Logic (a -> b) = a -> Logic b
    f==g = \a -> f a == g a

instance POrd b => POrd (a -> b) where
    inf f g = \a -> inf (f a) (g a)

instance MinBound b => MinBound (a -> b) where
    minBound = \_ -> minBound

instance Lattice b => Lattice (a -> b) where
    sup f g = \a -> sup (f a) (g a)

instance Bounded b => Bounded (a -> b) where
    maxBound = \_ -> maxBound

instance Complemented b => Complemented (a -> b) where
    not f = \a -> not (f a)

instance Heyting b => Heyting (a -> b) where
    f ==> g = \a -> f a ==> g a

instance Boolean b => Boolean (a -> b)


{-# LANGUAGE ImplicitParams #-}
{-# OPTIONS_GHC -Wredundant-constraints #-}

f :: (?file1 :: String) => IO ()
f = putStrLn $ "f2: "

main :: IO ()
main = let ?file1 = "A" in f


{-# LANGUAGE GADTs #-}

module T9939 where

f1 :: (Eq a, Ord a) => a -> a -> Bool
-- Eq a redundant
f1 x y = (x == y) && (x > y)

f2 :: (Eq a, Ord a) => a -> a -> Bool
-- Ord a redundant, but Eq a is reported
f2 x y = (x == y)

f3 :: (Eq a, a ~ b, Eq b) => a -> b -> Bool
-- Eq b redundant
f3 x y = x==y

data Equal a b where
  EQUAL :: Equal a a

f4 :: (Eq a, Eq b) => a -> b -> Equal a b -> Bool
-- Eq b redundant
f4 x y EQUAL = y==y


{-# LANGUAGE TypeFamilies #-}
module T10642 where

import Data.Coerce

type family F a

newtype D a = D (F a)

-- | This works on 7.10.1, but fails on HEAD (20150711)
coerceD :: F a -> D a
coerceD = coerce


{-# LANGUAGE MagicHash #-}
module T10744 where

import GHC.Exts
import GHC.Magic

-- Checks if oneShot is open-kinded

f0 :: Int -> Int
f0 = oneShot $ \n -> n

f1 :: Int# -> Int
f1 = oneShot $ \n# -> I# n#

f2 :: Int -> Int#
f2 = oneShot $ \(I# n#) -> n#


module T10770a where

import Data.Typeable

main = print $ foo $ Just ()

foo :: Typeable (t a) => t a -> String
foo x = let k = show $ typeOf x in k


{-# LANGUAGE FlexibleContexts #-}
{-# OPTIONS_GHC -fwarn-redundant-constraints #-}
module T10770b where

f :: (Show a, Show (Maybe a)) => Maybe a -> String
f x = let k = show x in k

g :: (Show a, Show (Maybe a)) => Maybe a -> String
g x = show x


{-# OPTIONS_GHC -fwarn-monomorphism-restriction #-}

module T10935 where

f x = let y = 1+1 in (y,y)


{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE MonomorphismRestriction, ExtendedDefaultRules #-}
module T10971a where

import Data.Traversable (fmapDefault)

f = \x -> length x
g = \f x -> fmapDefault f x
h = \f x -> (fmapDefault f x, length x)


{-# LANGUAGE PolyKinds, DataKinds #-}
module T11056 where
import Data.Typeable

data T = A | B Int

bar :: TypeRep
bar = typeRep (Proxy :: Proxy '[True])

baz :: TypeRep
baz = typeRep (Proxy :: Proxy 'A)

quux :: TypeRep
quux = typeRep (Proxy :: Proxy 'B)


{-# LANGUAGE TypeFamilies #-}
module T11062 where
import T11062a
type family F a


{-# LANGUAGE TypeFamilies #-}
module T11062a where
import {-# SOURCE #-} T11062
type instance F Int = Bool


{-# LANGUAGE RankNTypes #-}

module Bug where

data T a = MkT

out :: forall a. T a -> ()
out MkT = ()

inHoisted :: forall r. () -> (forall a. T a -> r) -> r
inHoisted _ foo = foo MkT

inUnhoisted :: () -> forall r. (forall a. T a -> r) -> r
inUnhoisted _ foo = foo MkT

testHoisted :: ()
testHoisted = inHoisted () out

testUnhoisted :: ()
testUnhoisted = inUnhoisted () out

----------------

data A s = A { unA :: () }

runA1 :: (forall s. A s) -> ()
runA1 a = unA a

-- doesn't work :(
runA2 :: (forall s. A s) -> ()
runA2 (A a) = a

runA3 :: (forall s. A s) -> ()
runA3 a = case a of A x -> x

runA4 :: (forall s. A s) -> ()
runA4 a = let A x = a in x

runA5 :: (forall s. A s) -> ()
runA5 a = go a
  where go (A a) = a


{-# LANGUAGE DataKinds, KindSignatures #-}
{-# LANGUAGE GADTs #-}
module T11237 where

import qualified Data.Kind

data Works :: Data.Kind.Type where
  WorksConstr :: Works

type Set = Data.Kind.Type

data ShouldWork :: Set where
  ShouldWorkConstr :: ShouldWork


module T11246 where

import GHC.Exts

type Key a = Any


-- /tmp/panic.hs
{-# LANGUAGE FlexibleContexts        #-}
{-# LANGUAGE FlexibleInstances       #-}
{-# LANGUAGE InstanceSigs            #-}
{-# LANGUAGE TypeFamilies            #-}
{-# LANGUAGE TypeSynonymInstances    #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}

module T11254 where

class (Frac (Frac a) ~ Frac a, Fractional (Frac a), ID (Frac a)) => ID a where
  type Frac a
  embed :: a -> Frac a

instance ID Rational where
  type Frac Rational = Int
  embed :: Rational -> Rational
  embed = undefined


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}

module Data.Profunctor.Strong where

import Control.Arrow
import Control.Category
import Data.Tuple
import Prelude hiding (id,(.))

infixr 0 :->
type p :-> q = forall a b. p a b -> q a b

class Profunctor p where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d

class ProfunctorFunctor t where
  promap    :: Profunctor p => (p :-> q) -> t p :-> t q

class ProfunctorFunctor t => ProfunctorMonad t where
  proreturn :: Profunctor p => p       :-> t p
  projoin   :: Profunctor p => t (t p) :-> t p

class ProfunctorFunctor t => ProfunctorComonad t where
  proextract   :: Profunctor p => t p :-> p
  produplicate :: Profunctor p => t p :-> t (t p)

class Profunctor p => Strong p where
  first' :: p a b  -> p (a, c) (b, c)
  first' = dimap swap swap . second'

  second' :: p a b -> p (c, a) (c, b)
  second' = dimap swap swap . first'

----------------------------------------------------------------------------

newtype Tambara p a b = Tambara { runTambara :: forall c. p (a, c) (b, c) }

instance Profunctor p => Profunctor (Tambara p) where
  dimap f g (Tambara p) = Tambara $ dimap (first f) (first g) p

instance ProfunctorFunctor Tambara where
  promap f (Tambara p) = Tambara (f p)

instance ProfunctorComonad Tambara where
  proextract (Tambara p) = dimap (\a -> (a,())) fst p

  produplicate (Tambara p) = Tambara (Tambara $ dimap hither yon p)
    where
      hither :: ((a, b), c) -> (a, (b, c))
      hither ~(~(x,y),z) = (x,(y,z))

      yon    :: (a, (b, c)) -> ((a, b), c)
      yon    ~(x,~(y,z)) = ((x,y),z)

instance Profunctor p => Strong (Tambara p) where
  first' = runTambara . produplicate


{-# LANGUAGE ImpredicativeTypes #-}

-- Sept 16: this compiles again now, because I've weakened
--          ImpredicativeTypes a lot

module T11319 where

f :: Monad m => m (Maybe a)
f = return Nothing


{-# LANGUAGE RankNTypes, ScopedTypeVariables #-}

module T11339 where

import Control.Applicative ( Const(Const, getConst) )
import Data.Functor.Identity ( Identity(Identity) )

type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t

failing :: forall s t a b . Traversal s t a b -> Traversal s t a b -> Traversal s t a b
failing left right afb s = case pins t of
  [] -> right afb s
  _  -> t afb
  where
    t :: Applicative f => (a -> f b) -> f t
    -- Does not work because the MR applies to this binding group
    Bazaar { getBazaar = t } = left sell s

    sell :: a -> Bazaar a b b
    sell w   = Bazaar ($ w)

    pins :: ((a -> Const [Identity a] b) -> Const [Identity a] t) -> [Identity a]
    pins f   = getConst (f (\ra -> Const [Identity ra]))

newtype Bazaar a b t = Bazaar { getBazaar :: (forall f. Applicative f => (a -> f b) -> f t) }

instance Functor (Bazaar a b) where
  fmap f (Bazaar k) = Bazaar (fmap f . k)

instance Applicative (Bazaar a b) where
  pure a = Bazaar $ \_ -> pure a
  Bazaar mf <*> Bazaar ma = Bazaar $ \afb -> mf afb <*> ma afb


{-# LANGUAGE NoMonomorphismRestriction, RankNTypes, ScopedTypeVariables #-}

module T11339b where

import Control.Applicative ( Const(Const, getConst) )
import Data.Functor.Identity ( Identity(Identity) )

type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t

failing :: forall s t a b . Traversal s t a b -> Traversal s t a b -> Traversal s t a b
failing left right afb s = case pins t of
  [] -> right afb s
  _  -> t afb
  where
    t :: Applicative f => (a -> f b) -> f t
    -- Works because of NoMonomorphismRestriction
    Bazaar { getBazaar = t } = left sell s

    sell :: a -> Bazaar a b b
    sell w   = Bazaar ($ w)

    pins :: ((a -> Const [Identity a] b) -> Const [Identity a] t) -> [Identity a]
    pins f   = getConst (f (\ra -> Const [Identity ra]))

newtype Bazaar a b t = Bazaar { getBazaar :: (forall f. Applicative f => (a -> f b) -> f t) }

instance Functor (Bazaar a b) where
  fmap f (Bazaar k) = Bazaar (fmap f . k)

instance Applicative (Bazaar a b) where
  pure a = Bazaar $ \_ -> pure a
  Bazaar mf <*> Bazaar ma = Bazaar $ \afb -> mf afb <*> ma afb


{-# LANGUAGE MonoLocalBinds, RankNTypes, ScopedTypeVariables #-}

module T11339c where

import Control.Applicative ( Const(Const, getConst) )
import Data.Functor.Identity ( Identity(Identity) )

type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t

failing :: forall s t a b . Traversal s t a b -> Traversal s t a b -> Traversal s t a b
failing left right afb s = case pins t of
  [] -> right afb s
  _  -> t afb
  where
    t :: Applicative f => (a -> f b) -> f t
    -- Works because of MonoLocalBinds
    Bazaar { getBazaar = t } = left sell s

    sell :: a -> Bazaar a b b
    sell w   = Bazaar ($ w)

    pins :: ((a -> Const [Identity a] b) -> Const [Identity a] t) -> [Identity a]
    pins f   = getConst (f (\ra -> Const [Identity ra]))

newtype Bazaar a b t = Bazaar { getBazaar :: (forall f. Applicative f => (a -> f b) -> f t) }

instance Functor (Bazaar a b) where
  fmap f (Bazaar k) = Bazaar (fmap f . k)

instance Applicative (Bazaar a b) where
  pure a = Bazaar $ \_ -> pure a
  Bazaar mf <*> Bazaar ma = Bazaar $ \afb -> mf afb <*> ma afb


{-# LANGUAGE NoMonoLocalBinds, RankNTypes #-}

-- Ross Paterson's example from
-- https://prime.haskell.org/wiki/MonomorphicPatternBindings

module T11339d where

import Control.Monad.ST

newtype ListMap m a b = ListMap ([a] -> m [b])

runMap :: (forall s. ListMap (ST s) a b) -> [a] -> [b]
runMap lf as = runST (f as)
             where
               ListMap f = lf


{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}

module T11348 where

import Data.Kind
import Data.Proxy

type family TrivialFamily t :: Type
type instance TrivialFamily (t :: Type) = Bool

data R where
    R :: Proxy Bool -> R

type ProblemType t = 'R ('Proxy :: Proxy (TrivialFamily t))


{-# LANGUAGE ExistentialQuantification, RankNTypes, MultiParamTypeClasses,
              FunctionalDependencies, FlexibleInstances, FlexibleContexts
 #-}

module XMonad.Layout.MultiToggle where

import Data.Typeable

-- This appears to be the culprit
expand :: (HList ts a) => MultiToggleS ts l a -> MultiToggle ts l a
expand (MultiToggleS b ts) =
    resolve ts id
        (\x mt -> let g = transform' x in mt{ currLayout = g $ currLayout mt })
        (MultiToggle (EL b id) ts)

class (Typeable t) => Transformer t a | t -> a where
    transform :: t
              -> l a
              -> (forall l'. l' a -> (l' a -> l a) -> b)
              -> b

data  EL l a = forall l'. EL (l' a) (l' a -> l a)

transform' :: (Transformer t a) => t -> EL l a -> EL l a
transform' t (EL l det) = undefined

data MultiToggleS ts l a = MultiToggleS (l a) ts
                         deriving (Read, Show)

data MultiToggle ts l a = MultiToggle{
    currLayout :: EL l a,
    transformers :: ts
    }

class HList c a where
    resolve :: c -> b -> (forall t. (Transformer t a) => t -> b) -> b


module T11397 where

f :: a -> [Maybe a]
f x =
   let switch l = [l Nothing, l (Just x)]
   in  switch id

u :: a
u = u

f2 :: a
f2 = let switch l = l u in switch u

f3 :: a
f3 = let switch l = l undefined in switch undefined

newtype VectorLazy a = VectorLazy a
newtype Vector a = Vector a
newtype Pointer a = Pointer a

empty :: VectorLazy a
empty = undefined

cons :: Vector a -> Pointer a
cons = undefined

unfoldrResult :: (a -> Either c (b, a)) -> a -> (VectorLazy b, c)
unfoldrResult = undefined

switchL :: b -> (a -> Pointer a -> b) -> Pointer a -> b
switchL = undefined

inverseFrequencyModulationChunk ::
   (Num t, Ord t) =>
   (s -> Maybe (t,s)) -> (t,s) -> Vector v -> (VectorLazy v, Maybe (t,s))
inverseFrequencyModulationChunk nextC (phase,cst0) chunk =
   let {-
       switch ::
          (Maybe (t, s) -> r) ->
          ((t, v) -> (s, Pointer v) -> r) ->
          t ->
          (s, Pointer v) -> r
       -}
       switch l r t (cp0,xp0) =
          maybe
             (l Nothing)
             (\(c1,cp1) ->
                switchL
                   (l (Just (t,cp0)))
                   (\x1 xp1 -> r (t+c1,x1) (cp1,xp1))
                   xp0)
             (nextC cp0)

       {-
       go ::
          (t,v) -> (s, Pointer v) ->
          Either (Maybe (t,s)) (v, ((t,v), (s, Pointer v)))
       -}
       go (c,x) cxp =
          if c<1
            then switch Left go c cxp
            else Right (x, ((c-1,x),cxp))

   in  switch ((,) empty)
          (curry $ unfoldrResult (uncurry go))
          phase (cst0, cons chunk)


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
module T11401 where

import Data.Kind (Type)

newtype Value a = Value a
newtype CodeGen r a = CodeGen a

bind :: CodeGen r a -> (a -> CodeGen r b) -> CodeGen r b
bind (CodeGen a) k = k a

class
   (f ~ CalledFunction g, r ~ CallerResult g, g ~ CallerFunction f r) =>
       CallArgs f g r where
   type CalledFunction g :: Type
   type CallerResult g :: Type
   type CallerFunction f r :: Type
   call :: f -> g

instance CallArgs (IO a) (CodeGen r (Value a)) r where
   type CalledFunction (CodeGen r (Value a)) = IO a
   type CallerResult (CodeGen r (Value a)) = r
   type CallerFunction (IO a) r = CodeGen r (Value a)
   call = undefined

instance CallArgs b b' r => CallArgs (a -> b) (Value a -> b') r where
   type CalledFunction (Value a -> b') = a -> CalledFunction b'
   type CallerResult (Value a -> b') = CallerResult b'
   type CallerFunction (a -> b) r = Value a -> CallerFunction b r
   call = undefined

test :: IO a -> (a -> IO ()) -> CodeGen () (Value ())
test start stop  =  bind (call start) (call stop)


module T11458 where

optIntArg f = (f Nothing, f (Just True))

optIntArg2 f = (f (Just True), f Nothing)


{-# OPTIONS_GHC -fplugin=T11462_Plugin #-}

module T11462 where

impossible :: a
impossible = undefined


module T11462_Plugin(plugin) where

import TcRnMonad ( TcPlugin(..), TcPluginResult(..) )
import Plugins ( defaultPlugin, Plugin(..), CommandLineOption )

plugin :: Plugin
plugin = defaultPlugin { tcPlugin = Just . thePlugin }

thePlugin :: [CommandLineOption] -> TcPlugin
thePlugin opts = TcPlugin
  { tcPluginInit  = return ()
  , tcPluginSolve = \_ _ _ _ -> return $ TcPluginOk [] []
  , tcPluginStop  = \_ -> return ()
  }


{-# LANGUAGE FlexibleContexts, UndecidableSuperClasses #-}

module T11480 where

class C [a] => D a
class D a => C a

foo :: C a => a -> a
foo = undefined


{-# LANGUAGE PolyKinds, TypeApplications, ScopedTypeVariables #-}

module Bug where

import Data.Proxy

class C a where
  foo :: Proxy a

bar :: forall a. C a => Proxy a
bar = foo @a


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE PatternSynonyms #-}

module T11524 where

data AType (a :: k) where
    AMaybe :: AType Maybe
    AInt :: AType Int
    AApp :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
            AType a -> AType b -> AType (a b)

pattern PApp :: () => (fun ~ a b) => AType a -> AType b -> AType fun
--pattern PApp :: forall k (fun :: k) k1 (a :: k1 -> k) (b :: k1).
--            () => (fun ~ a b) => AType a -> AType b -> AType fun
pattern PApp fun arg <- AApp fun arg


{-# LANGUAGE DataKinds, TypeOperators, KindSignatures, TypeFamilies,
             ConstraintKinds, FlexibleContexts #-}
{-# OPTIONS_GHC -fplugin T11525_Plugin #-}
module T11525 where

import GHC.TypeLits
import Data.Proxy

truncateB :: KnownNat a => Proxy (a + b) -> Proxy a
truncateB Proxy = Proxy

class Bus t where
  type AddrBits t :: Nat

data MasterOut b = MasterOut
    { adr :: Proxy (AddrBits b)
    }

type WiderAddress b b' k = ( KnownNat (AddrBits b)
                           , AddrBits b' ~ (AddrBits b + k)
                           )

narrowAddress' :: (WiderAddress b b' k)
               => MasterOut b'
               -> MasterOut b
narrowAddress' m = MasterOut { adr = truncateB (adr m) }


module T11525_Plugin(plugin) where

import TcRnMonad ( TcPlugin(..), TcPluginResult(..) )
import Plugins ( defaultPlugin, Plugin(..), CommandLineOption )

plugin :: Plugin
plugin = defaultPlugin { tcPlugin = Just . thePlugin }

thePlugin :: [CommandLineOption] -> TcPlugin
thePlugin opts = TcPlugin
  { tcPluginInit  = return ()
  , tcPluginSolve = \_ _ _ _ -> return $ TcPluginOk [] []
  , tcPluginStop  = \_ -> return ()
  }


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

module T11552 where

newtype MaybeT m a =
  MaybeT { runMaybeT :: m (Maybe a) }

instance (Functor m) => Functor (MaybeT m) where
  fmap f (MaybeT ma) =
    MaybeT $ (fmap . fmap) f ma

instance forall f . (Applicative f) => Applicative (MaybeT f) where
  pure :: a -> MaybeT f a
  pure x = MaybeT (pure (pure x))

  (<*>) :: forall a b . Applicative f => MaybeT f (a -> b) -> MaybeT f a -> MaybeT f b
  (MaybeT fab) <*> (MaybeT mma) =
   let fab' :: f (Maybe (a -> b))
       fab' = fab
   in MaybeT $ undefined


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}

module T11608 where

type Traversal s t a b = forall f. Applicative f => (a -> f b) -> s -> f t

class Each s t a b | s -> a, t -> b, s b -> t, t a -> s where
  each :: Traversal s t a b
  default each :: (Traversable g, s ~ g a, t ~ g b) => Traversal s t a b
  each = traverse


{-# LANGUAGE TypeFamilies, PolyKinds #-}

module T11699 where

type family F a where F (f a) = f a


{-# LANGUAGE GADTs, TypeFamilies #-} -- Remove this line and the code compiles.

module T11700 where

data Muse
data Message
data Folder

class PersistEntity record

data Entity record where
  Entity :: PersistEntity record => record -> Entity record

fn1 :: (Entity Muse, Entity Message) -> Message
fn1 cluster = let (Entity foo, Entity msg) = cluster
              in msg
-- fn1 (Entity foo, Entity msg) = msg


{-# LANGUAGE DataKinds, PolyKinds #-}
module Example where

import Data.Typeable
import GHC.Exts

data Wat (a :: TYPE ('TupleRep '[])) = Wat a


{-# LANGUAGE UnboxedTuples #-}

module T11736 where

import Data.Proxy

foo :: Proxy (#,#)
foo = Proxy


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module T11766 where

import Data.Maybe (isJust)

data Wrapper a = Wrapper a deriving (Show)

class Resolution a
instance Resolution (Wrapper a)

class (Resolution b, Resolution d) => C a b c d | a -> b, c -> d, a d -> c, b c -> a where
  cfun :: (b -> d) -> a -> c

instance {-# OVERLAPPABLE #-} (Resolution b, Resolution d, a ~ b, c ~ d) => C a b c d where
  cfun = ($)

instance {-# OVERLAPPING #-} (C b c d e) => C (Maybe a -> b) c (Maybe a -> d) e where
  cfun f b = \x -> cfun f (b x)

foo :: Maybe a -> Wrapper Bool
foo = Wrapper . isJust

t1 = cfun id foo $! Nothing
t2 = let f = cfun id foo in f Nothing
t3 = cfun id foo Nothing
t4 = cfun id foo $ Nothing


{-# LANGUAGE ImplicitParams #-}

module T11793 where

class C a where
  op :: (?x::Int) => a -> a

-- Should be OK even without ConstrainedClassMethods


{-# LANGUAGE PolyKinds, GADTs #-}

module T11811 where

import Data.Kind

data Test (a :: x) (b :: x) :: x -> Type
  where K :: Test Int Bool Double


{-# LANGUAGE TypeApplications, ScopedTypeVariables, AllowAmbiguousTypes #-}
module T11947 where

theFloatDigits :: forall a. RealFloat a => Int
-- The type is ambiguous
theFloatDigits = floatDigits (undefined @_ @a)

foo :: IO ()
foo = print (theFloatDigits @Double, theFloatDigits @Float)
-- But the applications are not


{-# LANGUAGE ExtendedDefaultRules #-}

module T11974 where

default (Maybe, [])


{-# LANGUAGE MonadComprehensions, ParallelListComp #-}

module Foo where

foo xs ys = [ (f y True, f x 'c')
            | let f _ z = z, x <- xs
            | y <- ys ]


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ApplicativeDo #-}
module Main where
import Control.Concurrent.MVar

type Locker = forall a. IO a -> IO a

main :: IO ()
main = do
    line <- getLine
    lock <- newMVar ()
    let locker :: Locker
        locker = withMVar lock . const
    f line locker

f :: String -> Locker -> IO ()
f line locker = locker $ putStrLn line


-- This is similar to T11982b but 'locker' inlined which allows the module to
-- compile.

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ApplicativeDo #-}
module Main where
import Control.Concurrent.MVar

type Locker = forall a. IO a -> IO a

main :: IO ()
main = do
    line <- getLine
    lock <- newMVar ()
    f line $ withMVar lock . const

f :: String -> Locker -> IO ()
f line locker = locker $ putStrLn line


{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds,
    RankNTypes, ConstraintKinds, TypeFamilies #-}

module T12045a where

import Data.Kind
import Data.Typeable

data T (f :: k -> Type) a = MkT (f a)

newtype TType f a= MkTType (T @Type f a)

t1 :: TType Maybe Bool
t1 = MkTType (MkT (Just True))

t2 :: TType Maybe a
t2 = MkTType (MkT Nothing)

data Nat = O | S Nat

data T1 :: forall k1 k2. k1 -> k2 -> Type where
  MkT1 :: T1 a b

x :: T1 @_ @Nat False n
x = MkT1

-- test from trac 12045
type Cat k = k -> k -> Type

data FreeCat :: Cat k -> Cat k where
  Nil  :: FreeCat f a a
  Cons :: f a b -> FreeCat f b c -> FreeCat f a c

liftCat :: f a b -> FreeCat f a b
liftCat x = Cons x Nil

data Node = Unit | N

data NatGraph :: Cat Node where
  One  :: NatGraph Unit N
  Succ :: NatGraph N    N

one :: (FreeCat @Node NatGraph) Unit N
one = liftCat One

type Typeable1 = Typeable @(Type -> Type)
type Typeable2 = Typeable @(Type -> Type -> Type)
type Typeable3 = Typeable @(Cat Bool)

type family F a where
  F Type = Type -> Type
  F (Type -> Type) = Type
  F other = other

data T2 :: F k -> Type

foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type
foo a b = undefined

data family D (a :: k)
data instance D @Type a = DBool
data instance D @(Type -> Type) b = DChar

class C a where
  tc :: (D a) -> Int

instance C Int where
  tc DBool = 5

instance C Bool where
  tc DBool = 6

instance C Maybe where
  tc DChar = 7

-- Tests from D5229
data P a = MkP
type MkPTrue = MkP @Bool

type BoolEmpty = '[] @Bool

type family F1 (a :: k) :: Type
type G2 (a :: Bool) = F1 @Bool a


{-# LANGUAGE ExistentialQuantification #-}
module T12064 where
import T12064a
data D = forall n. K n => DCon n


module T12064a where
import {-# SOURCE #-} T12064
class K a where
  kfun :: D -> a


{-# OPTIONS_GHC -Wunused-imports #-}
module T12067 where

import Data.Functor.Identity
import Data.Coerce
import T12067a

foo :: M [a] -> MT [] a
foo = coerce


module T12067a (MT(..), M) where

import Data.Functor.Identity

newtype MT m b = MT (m b)
type M b = MT Identity b


{-# LANGUAGE ScopedTypeVariables #-}
module T12069 where

foo (_ :: p a) = [] :: [a]


{-# LANGUAGE RankNTypes #-}

module T12082 where

import Data.Typeable (Typeable)
import Control.Monad.ST (RealWorld)

f :: forall a. (forall b. Typeable b => b -> a) -> a
f = undefined :: (RealWorld -> a) -> a


{-# LANGUAGE TypeFamilies, DataKinds, UndecidableInstances #-}

module T12104 where

import GHC.TypeLits

type family F a where
  F a = TypeError (Text "error")

err :: F ()
err = ()


{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module T12133 where

import           GHC.Classes (IP(..))
import           Data.Kind (Constraint, Type)

-- | From "Data.Constraint":
data Dict :: Constraint -> Type where Dict :: a => Dict a

newtype a :- b = Sub (a => Dict b)

infixl 1 \\ -- required comment

(\\) :: a => (b => r) -> (a :- b) -> r
r \\ Sub Dict = r

-- | GHC 7.10.2 type checks this function but GHC 8.0.1 does not unless
-- you modify this example in one of the following ways:
--
--   * uncomments the type signature for 'Sub'
--
--   * flatten the nested pairs of constraints into a triple of constraints
--
--   * replace 'IP sym ty' with 'c9', where 'c9' is a new constraint variable.
--
-- The error message is listed below.
foo :: forall c1 c2 c3 sym ty
    .  (c1, c2) :- c3
    -> (c1, (IP sym ty, c2)) :- (IP sym ty, c3)
foo sp = ( Sub
--           :: ((c1, (IP sym ty, c2)) => Dict (IP sym ty, c3))
--              -> (c1, ((IP sym ty), c2)) :- (IP sym ty, c3)
         )
         ( (Dict \\ sp) :: Dict (IP sym ty, c3) )

{- Compiler error message:

GHCi, version 8.0.1: http://www.haskell.org/ghc/  :? for help
[1 of 1] Compiling T                ( t.hs, interpreted )

t.hs:44:13: error:
    â€¢ Could not deduce: IP sym ty arising from a use of â€˜Dictâ€™
      from the context: (c1, (IP sym ty, c2))
        bound by a type expected by the context:
                   (c1, (IP sym ty, c2)) => Dict (IP sym ty, c3)
        at t.hs:(40,10)-(44,49)
      or from: c3
        bound by a type expected by the context:
                   c3 => Dict (IP sym ty, c3)
        at t.hs:44:13-22
    â€¢ In the first argument of â€˜(\\)â€™, namely â€˜Dictâ€™
      In the first argument of â€˜Subâ€™, namely
        â€˜((Dict \\ sp) :: Dict (IP sym ty, c3))â€™
      In the expression: (Sub) ((Dict \\ sp) :: Dict (IP sym ty, c3))
    â€¢ Relevant bindings include
        foo :: (c1, c2) :- c3 -> (c1, (IP sym ty, c2)) :- (IP sym ty, c3)
          (bound at t.hs:40:1)
Failed, modules loaded: none.
-}


{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fdefer-out-of-scope-variables #-}

main :: IO ()
main = smth


{-# LANGUAGE FlexibleContexts, RankNTypes, TypeFamilies #-}

module T12185 where

class Foo a

newtype Bar r = Pow r deriving (Eq)

instance (Foo r) => Foo (Bar r)

type family Ctx a where Ctx t = (Foo (Bar t), Eq (Bar t))

run :: (forall t . (Ctx t) => t -> Int) -> Int
run g = undefined

foo :: (Foo (Bar t)) => t -> Int
foo = undefined

main :: IO ()
main = print $ run foo


{-# LANGUAGE DataKinds, PolyKinds, TypeFamilies #-}
module Kinds where

import GHC.Types

type family G (a :: Type) :: Type
type instance G Int = Bool

type family F (a :: Type) :: G a
type instance F Int = True


{-# LANGUAGE GADTs, RankNTypes #-}

-- Test pattern bindings, existentials, and higher rank

module T12427a where

data T where
  T1 :: a -> ((forall b. [b]->[b]) -> Int) -> T
  T2 :: ((forall b. [b]->[b]) -> Int) -> T

-- Inference
-- Worked in 7.10 (probably wrongly)
-- Failed in 8.0.1
-- Fails in 8.2 because v is polymorphic
--     and the T1 pattern match binds existentials,
--     and hence bumps levels
h11 y = case y of T1 _ v -> v

-- Worked in 7.10 (probably wrongly)
-- Failed in 8.0.1
-- Succeeds in 8.2 because the pattern match has
--   no existentials, so it doesn't matter than
--   v is polymorphic
h12 y = case y of T2 v -> v

-- Inference
-- Same results as for h11 and h12 resp
T1 _ x1 = undefined
T2 x2 = undefined

-- Works in all versions
h2 :: T -> (forall b. [b] -> [b]) -> Int
h2 y = case y of T1 _ v -> v

-- Checking
-- Fails in 7.10  (head exploded)
-- Fails in 8.0.1 (ditto)
-- Succeeds in 8.2
x3 :: (forall a. a->a) -> Int
T1 _ x3 = undefined


{-# LANGUAGE GADTs, RankNTypes #-}

module T12427b where

newtype Acquire a = Acquire {unAcquire :: (forall b. b -> b) -> IO a}

instance Functor Acquire where
    fmap = undefined

instance Applicative Acquire where
    pure = undefined
    (<*>) = undefined

instance Monad Acquire where
    Acquire f >>= g' = Acquire $ \restore -> do
        x <- f restore
        let Acquire g = g' x
        -- let g = unAcquire (g' x)
        g restore


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-}
module T12466 where

class Foo a where
  foo :: (a ~ Int => Int) -> a -> a
  foo _ a2 = a2

instance Foo Char


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module T12466a where

import GHC.TypeLits (Nat)
import Unsafe.Coerce (unsafeCoerce)

data Dict a where
  Dict :: a => Dict a

newtype a :- b = Sub (a => Dict b)

axiom :: forall a b. Dict (a ~ b)
axiom = unsafeCoerce (Dict :: Dict (a ~ a))

type Divides n m = n ~ Gcd n m
type family Gcd :: Nat -> Nat -> Nat where

dividesGcd :: forall a b c. (Divides a b, Divides a c) :- Divides a (Gcd b c)
dividesGcd = Sub axiom


{-# LANGUAGE GADTs, ConstraintKinds, Rank2Types, ImplicitParams #-}

module T12507 where

data Rec fields where
  Rec :: fields => Rec fields

qn :: Rec fields -> (fields => r) -> r
qn Rec e = e

record :: Rec (?a :: Int, ?b :: String)
record = Rec where ?a=42
                   ?b="hey"

access :: Int
access = qn record ?a


{-# LANGUAGE ImpredicativeTypes #-}

module T12644 where

data T a = T1 Int

instance Show (T a) where
  show (T1 x) = show x

t1 :: T a
t1 = T1 1

f :: String
f = show t1


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE UndecidableInstances      #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE PolyKinds                 #-}
{-# LANGUAGE TypeApplications          #-}

---------------  The original bug report --------------
--
-- See T12734a for a smaller version

module T12734 where

import Prelude
import Data.Kind
import Control.Applicative
import Control.Monad.Fix
import Control.Monad.Trans.Identity
import Control.Monad.Trans.Class
import Control.Monad.IO.Class

data A
data B
data Net
data Ty

data Layer4 t l
data TermStore

-- Helpers: Stack

data Stack layers (t :: Type -> Type) where
    SLayer :: t l -> Stack ls t -> Stack (l ': ls) t
    SNull  :: Stack '[] t

instance ( Constructor m (t l)
         , Constructor m (Stack ls t)) => Constructor m (Stack (l ': ls) t)
instance Monad m                       => Constructor m (Stack '[]       t)

-- Helpers: Expr

newtype Expr  t layers    = Expr (TermStack t layers)
type TermStack t layers = Stack layers (Layer4 (Expr t layers))

-- Helpers: Funny typeclass

class Monad m => Constructor m t

instance ( Monad m, expr ~ Expr t layers, Constructor m (TermStack t layers)
         ) => Constructor m (Layer4 expr Ty)

-- HERE IS A FUNNY BEHAVIOR: the commented line raises context reduction stack
-- overflow
test_gr ::
    ( Constructor m (TermStack t layers), Inferable A layers m, Inferable B t m
      , bind ~ Expr t layers
--  ) => m (Expr t layers)
    ) => m bind
test_gr = undefined

-- Explicit information about a type which could be inferred

class Monad m => Inferable (cls :: Type) (t :: k) m | cls m -> t

newtype KnownTyx (cls :: Type) (t :: k) (m :: Type -> Type) (a :: Type) =
    KnownTyx (IdentityT m a)
  deriving (Show, Functor, Monad, MonadIO, MonadFix, MonadTrans,
            Applicative, Alternative)

instance {-# OVERLAPPABLE #-} (t ~ t', Monad m) =>
  Inferable cls t (KnownTyx cls t' m)
instance {-# OVERLAPPABLE #-} (Inferable cls t n, MonadTrans m, Monad (m n)) =>
  Inferable cls t (m n)

runInferenceTx :: forall cls t m a. KnownTyx cls t m a -> m a
runInferenceTx = undefined

-- running it

test_ghc_err :: (MonadIO m, MonadFix m)
        => m (Expr Net '[Ty])
test_ghc_err = runInferenceTx @B  @Net
             $ runInferenceTx @A @'[Ty]
             $ (test_gr)