{-# LANGUAGE GADTs, ExistentialQuantification #-}

module Main where

succeed :: a -> Maybe a
succeed = return

data V s t where
  Z :: V (t,m) t
  S :: V m t -> V (x,m) t

data Exp s t where
  IntC  :: Int -> Exp s Int                     -- 5
  BoolC :: Bool -> Exp s Bool                   -- True
  Plus  :: Exp s Int -> Exp s Int -> Exp s Int  -- x + 3
  Lteq  :: Exp s Int -> Exp s Int -> Exp s Bool -- x <= 3
  Var   :: V s t -> Exp s t                     -- x

data Com s where
  Set :: V s t -> Exp s t -> Com s              -- x := e
  Seq :: Com s -> Com s -> Com s                -- { s1; s2; }
  If :: Exp s Bool -> Com s -> Com s -> Com s   -- if e then x else y
  While :: Exp s Bool -> Com s -> Com s         -- while e do s
  Declare :: Exp s t -> Com (t,s) -> Com s      -- { int x = 5; s }

update :: (V s t) -> t -> s -> s
update Z n (x,y) = (n,y)
update (S v) n (x,y) = (x,update v n y)

eval :: Exp s t -> s -> t
eval (IntC n) s = n
eval (BoolC b) s = b
eval (Plus x y) s = (eval x s) + (eval y s)
eval (Lteq x y) s = (eval x s) <= (eval y s)
eval (Var Z) (x,y) = x
eval (Var (S v)) (x,y) = eval (Var v) y

exec :: (Com st) -> st -> st
exec (Set v e) s = update v (eval e s) s
exec (Seq x y) s = exec y (exec x s)
exec (If test x1 x2) s =
  if (eval test s) then exec x1 s else exec x2 s
exec (While test body) s = loop s
  where loop s = if (eval test s)
                    then loop (exec body s)
                    else s
exec (Declare e body) s = store
  where (_,store) = (exec body (eval e s,s))

v0 = Z
v1 = S Z
v2 = S (S Z)
v3 = S (S (S Z))

e2 = Lteq (Plus (Var v0)(Var v1)) (Plus (Var v0) (IntC 1))

sum_var = Z
x = S Z

prog :: Com (Int,(Int,a))
prog =
 Seq (Set sum_var (IntC 0))
     (Seq (Set x (IntC 1))
     (While (Lteq (Var x) (IntC 5))
            (Seq (Set sum_var (Plus (Var sum_var)(Var x)))
                 (Set x (Plus (Var x) (IntC 1))))))

ans = exec prog (34,(12,1))
main = print ans
{-
{ sum = 0 ;
  x = 1;
  while (x <= 5)
  { sum = sum + x;
    x = x + 1;
  }
}
-}

---------------------------------------------------
-- Untyped Annotated AST

data TyAst = I | B | P TyAst TyAst

data TypeR t where
  IntR :: TypeR Int
  BoolR :: TypeR Bool
  PairR :: TypeR a -> TypeR b -> TypeR (a,b)

-- Judgments for Types
data TJudgment = forall t . TJ (TypeR t)

checkT :: TyAst -> TJudgment
checkT I = TJ IntR
checkT B = TJ BoolR
checkT (P x y) =
   case (checkT x,checkT y) of
     (TJ a, TJ b) -> TJ(PairR a b)

----------------------------------------------------
-- Equality Proofs and Type representations
data Equal a b where
  EqProof :: Equal a a

match :: TypeR a -> TypeR b -> Maybe (Equal a b)
match IntR IntR = succeed EqProof
match BoolR BoolR = succeed EqProof
match (PairR a b) (PairR c d) =
  do { EqProof <- match a c
     ; EqProof <- match b d
     ; succeed EqProof }
match _ _ = fail "match fails"

----------------------------------------------
-- checking Variables are consistent

checkV :: Int -> TypeR t -> TypeR s -> Maybe(V s t)
checkV 0 t1 (PairR t2 p) =
  do { EqProof <- match t1 t2
     ; return Z }
checkV n t1 (PairR ty p) =
  do { v <- checkV (n-1) t1 p; return(S v)}
checkV n t1 sr = Nothing

-----------------------------------------------------
data ExpAst
  = IntCA Int
  | BoolCA Bool
  | PlusA ExpAst ExpAst
  | LteqA ExpAst ExpAst
  | VarA Int TyAst

-- Judgments for Expressions
data EJudgment s = forall t . EJ (TypeR t) (Exp s t)

checkE :: ExpAst -> TypeR s -> Maybe (EJudgment s)
checkE (IntCA n) sr = succeed(EJ IntR (IntC n))
checkE (BoolCA b) sr = succeed(EJ BoolR (BoolC b))
checkE (PlusA x y) sr =
  do { EJ t1 e1 <- checkE x sr
     ; EqProof <- match t1 IntR
     ; EJ t2 e2 <- checkE y sr
     ; EqProof <- match t2 IntR
     ; succeed(EJ IntR (Plus e1 e2))}
checkE (VarA n ty) sr =
  do { TJ t <- succeed(checkT ty)
     ; v <- checkV n t sr
     ; return(EJ t (Var v)) }

-----------------------------------------------------
data ComAst
  = SetA Int TyAst ExpAst
  | SeqA ComAst ComAst
  | IfA ExpAst ComAst ComAst
  | WhileA ExpAst ComAst
  | DeclareA TyAst ExpAst ComAst

data CJudgment s = EC (Com s)

checkC :: ComAst -> TypeR s -> Maybe(CJudgment s)
checkC (SetA n ty e) sr =
  do { TJ t1 <- succeed(checkT ty)
     ; v <- checkV n t1 sr
     ; EJ t2 e1 <- checkE e sr
     ; EqProof <- match t1 t2
     ; return(EC (Set v e1))}
checkC (SeqA x y) sr =
  do { EC c1 <- checkC x sr
     ; EC c2 <- checkC y sr
     ; return(EC (Seq c1 c2)) }
checkC (IfA e x y) sr =
  do { EJ t1 e1 <- checkE e sr
     ; EqProof <- match t1 BoolR
     ; EC c1 <- checkC x sr
     ; EC c2 <- checkC y sr
     ; return(EC(If e1 c1 c2)) }
checkC (WhileA e x) sr =
  do { EJ t1 e1 <- checkE e sr
     ; EqProof <- match t1 BoolR
     ; EC c1 <- checkC x sr
     ; return(EC(While e1 c1)) }
checkC (DeclareA ty e c) sr =
  do { TJ t1 <- succeed(checkT ty)
     ; EJ t2 e2 <- checkE e sr
     ; EqProof <- match t1 t2
     ; EC c2 <- checkC c (PairR t1 sr)
     ; return(EC(Declare e2 c2)) }

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

e1 = Lteq (Plus (Var sum_var)(Var x)) (Plus (Var x) (IntC 1))

{-
data Store s
  = M (Code s)
  | forall a b . N (Code a) (Store b) where s = (a,b)

eval2 :: Exp s t -> Store s -> Code t
eval2 (IntC n) s = lift n
eval2 (BoolC b) s = lift b
eval2 (Plus x y) s = [| $(eval2 x s) + $(eval2 y s) |]
eval2 (Lteq x y) s = [| $(eval2 x s) <= $(eval2 y s) |]
eval2 (Var Z) (N a b) = a
eval2 (Var (S v)) (N a b) = eval2 (Var v) b
eval2 (Var Z) (M x) = [| fst $x |]
eval2 (Var (S v)) (M x) = eval2 (Var v) (M [| snd $x |])

test e = [| \ (x,(y,z)) -> $(eval2 e (N [|x|] (N [|y|] (M [|z|])))) |]

-- test e1 --->  [| \ (x,(y,z)) -> x + y <= y + 1 |]
-}


{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies  #-}

module CanDoRep0 where

import GHC.Generics (Generic)

-- We should be able to generate a generic representation for these types
data A                                          deriving Generic

data B a                                        deriving Generic

data C = C0 | C1                                deriving Generic

data D a = D0 | D1 { d11 :: a, d12 :: (D a) }   deriving Generic

data (:*:) a b = a :*: b                        deriving Generic

data family F a
data instance F Int = FInt                      deriving Generic


{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}

module CanDoRep1 where

import GHC.Generics (Generic, Generic1)

-- We should be able to generate a generic representation for these types
data A a                                deriving Generic1

data B a = B0 | B1                      deriving Generic1

data C a = C0 | C1 { c11 :: a, c12 :: (C a) }
  deriving (Generic, Generic1)

data D a = D (Either Int a)             deriving Generic1

data E a = E (Either Int (E a))         deriving Generic1

data F c b a = F (c, b, a)              deriving Generic1
data G c b a = G [(c, c, c, c, b, a)]   deriving (Generic1, Show)

data Odd a = Odd a (Even a)             deriving Generic1
data Even a = NilEven | Even a (Odd a)  deriving Generic1

data Odd' a = Odd' a (Even' a)          deriving Generic1
data Even' a = NilEven' | Even' a (Odd' a)

data H b a = H0 | H1 (H b b)            deriving Generic1

data (:*:) a b = a :*: b                deriving (Generic, Generic1)


{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExistentialQuantification  #-}
{-# LANGUAGE StandaloneDeriving         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE DatatypeContexts           #-}

module CannotDoRep0_0 where

import GHC.Generics hiding (P, D)

-- We do not support existential quantification
data Dynamic = forall a. Dynamic a deriving Generic

-- Partial instantiation of types is not allowed
data P a = P a
deriving instance Generic (P Int)

-- This gets trickier for data families
data family D a b
data instance D Char b
data instance (Show b) => D Int b
data instance D () ()

-- Bad: second argument is instantiated
deriving instance Generic (D Char Char)
-- Bad: has context
deriving instance Generic (D Int a)
-- Ok
deriving instance Generic (D () ())


{-# LANGUAGE DeriveGeneric, DatatypeContexts #-}

module CannotDoRep0_1 where

import GHC.Generics

-- We do not support datatypes with context
data (Show a) => Context a = Context a deriving Generic


{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE GADTs               #-}

module CannotDoRep0_2 where

import GHC.Generics

-- We do not support GADTs
data Term a where
  Int :: Term Int

deriving instance Generic (Term a)


{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE ExistentialQuantification  #-}

module CannotDoRep1_0 where

import GHC.Generics

-- We do not support existential quantification
data Dynamic a = forall b. Dynamic b a deriving Generic1


{-# LANGUAGE DeriveGeneric, DatatypeContexts #-}

module CannotDoRep1_1 where

import GHC.Generics

-- We do not support datatypes with context
data (Show a) => Context a = Context a deriving Generic1


{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE StandaloneDeriving  #-}
{-# LANGUAGE GADTs               #-}

module CannotDoRep1_2 where

import GHC.Generics

-- We do not support GADTs
data Term a where
  Int :: Term Int

deriving instance Generic1 Term


{-# LANGUAGE DeriveGeneric       #-}

module GenCannotDoRep1_3 where

import GHC.Generics

-- We do not support occurrences of the type variable except as the last
-- argument
data B a b = B (a, b)

data T a = T (B a Int) deriving Generic1


{-# LANGUAGE DeriveGeneric       #-}

module GenCannotDoRep1_4 where

import GHC.Generics

-- We do not support contravariant occurrences of the type variable
data T a = T (a -> Int) deriving Generic1


{-# LANGUAGE DeriveGeneric       #-}

module GenCannotDoRep1_6 where

import GHC.Generics

-- We do not support occurrences of the type variable except as the last
-- argument: == (->) ((->) a Int) Int
data T a = T ((a -> Int) -> Int) deriving Generic1


{-# LANGUAGE DeriveGeneric       #-}

module GenCannotDoRep1_7 where

import GHC.Generics

-- We do not support occurrences of the type variable except as the last
-- argument
data I a = I (a, Int) deriving Generic1


{-# LANGUAGE DeriveGeneric, TypeFamilies      #-}

module GenCannotDoRep1_8 where

import GHC.Generics

data B a = B (a -> Int)

type family TF (a :: *) :: *

-- We do not support type families
data T a = T (TF a) deriving Generic1


{-# LANGUAGE DeriveFunctor   #-}
{-# LANGUAGE DeriveGeneric   #-}
{-# OPTIONS_GHC -ddump-deriv #-}

module GenDerivOutput where

import GHC.Generics (Generic, Generic1)

data List a = Nil | Cons { element :: a, rest :: List a }
  deriving (Generic, Generic1, Functor)

data Rose a = Empty | Rose a (List (Rose a))
  deriving (Generic, Generic1)


{-# LANGUAGE DeriveGeneric   #-}
{-# OPTIONS_GHC -ddump-deriv #-}

module GenDerivOutput1_0 where

import GHC.Generics (Generic1)

data List a = Nil | Cons { element :: a, rest :: List a } deriving Generic1


{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -ddump-deriv #-}

module CanDoRep1_1 where

import GHC.Generics (Generic, Generic1)

-- We should be able to generate both generic representations for these types,
-- without duplicating the meta ty cons
data Da a = D0 | D1 { d11a :: a, d12a :: (Da a) }
  deriving (Generic, Generic1)

data Db a = D0b | D1b { d11b :: a, d12b :: (Db a) }
  deriving (Generic)
deriving instance Generic1 Db

data Dc a = D0c | D1c { d11c :: a, d12c :: (Dc a) }
  deriving (Generic1)
deriving instance Generic (Dc a)

data Dd a = D0d | D1d { d11d :: a, d12d :: (Dd a) }
deriving instance Generic (Dd a)
deriving instance Generic1 Dd


{-# LANGUAGE DeriveGeneric #-}

module Main where

import GHC.Generics

data    X = X   deriving Generic
newtype Y = Y X deriving Generic

main = print [isNewtype (from X), isNewtype (from (Y X))]


{-# LANGUAGE StandaloneDeriving #-}

module ShouldFail0 where

import GHC.Generics (Generic)

data X = X

deriving instance Generic X

-- Should fail (no XDeriveGeneric)


{-# LANGUAGE StandaloneDeriving #-}

module ShouldFail1_0 where

import GHC.Generics (Generic1)

data X a = X

deriving instance Generic1 X

-- Should fail (no XDeriveGeneric)


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
module Main where

import Data.Proxy (Proxy(..))
import GHC.Generics

main :: IO ()
main = do
  print (fullyStrict (Proxy :: Proxy (StrictMaybe Bool)))
  print (fullyStrict (Proxy :: Proxy (Maybe Bool)))

data StrictMaybe a = StrictNothing | StrictJust !a
  deriving (FullyStrict, Generic)

instance FullyStrict Bool
instance FullyStrict a => FullyStrict (Maybe a)

class FullyStrict a where
  fullyStrict :: proxy a -> Bool
  default fullyStrict :: (GFullyStrict (Rep a)) => proxy a -> Bool
  fullyStrict _ = gfullyStrict (Proxy :: Proxy (Rep a p))

class GFullyStrict f where
  gfullyStrict :: proxy (f p) -> Bool

instance GFullyStrict V1 where
  gfullyStrict _ = True

instance GFullyStrict U1 where
  gfullyStrict _ = True

instance FullyStrict c => GFullyStrict (Rec0 c) where
  gfullyStrict _ = fullyStrict (Proxy :: Proxy c)

instance GFullyStrict f => GFullyStrict (D1 c f) where
  gfullyStrict _ = gfullyStrict (Proxy :: Proxy (f p))

instance GFullyStrict f => GFullyStrict (C1 c f) where
  gfullyStrict _ = gfullyStrict (Proxy :: Proxy (f p))

instance (GFullyStrict f, Selector c) => GFullyStrict (S1 c f) where
  gfullyStrict _ = gfullyStrict (Proxy :: Proxy (f p))
                && selDecidedStrictness (undefined :: S1 c f p) /= DecidedLazy

instance (GFullyStrict f, GFullyStrict g) => GFullyStrict (f :+: g) where
  gfullyStrict _ =
    gfullyStrict (Proxy :: Proxy (f p)) && gfullyStrict (Proxy :: Proxy (g p))

instance (GFullyStrict f, GFullyStrict g) => GFullyStrict (f :*: g) where
  gfullyStrict _ =
    gfullyStrict (Proxy :: Proxy (f p)) && gfullyStrict (Proxy :: Proxy (g p))


module Main where

import GHC.Generics

main = do
  putStrLn $ packageName $ from $ Just True
  putStrLn $ packageName $ from $ True


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
module T10361a where

class C1 a where
  type T1 a
  type instance T1 a = Char

class C2 a where -- equivalent to C1
  type T2 a
  type instance T2 a = Char

class C3 a where -- equivalent to C1, C2
  type T3 a
  type instance T3 a = Char

data A = B
  deriving C1

deriving instance C2 A

instance C3 A

test1 :: T1 A
test1 = 'x'

test2 :: T2 A
test2 = 'x'

test3 :: T3 A
test3 = 'x'


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

module T10361b where

import GHC.Generics

---------------------------------------------------------------------
class Convert a where
    type Result a
    type instance Result a = GResult (Rep a)

    convert :: a -> Result a
    default convert
            :: (Generic a, GConvert (Rep a), Result a ~ GResult (Rep a))
            => a -> Result a
    convert x = gconvert (from x)

instance Convert Float where
    type Result Float = Float
    convert = id

instance Convert Int where
    type Result Int = Int
    convert = id

---------------------------------------------------------------------
class GConvert f where
    type GResult f
    gconvert :: f p -> GResult f

instance (Convert c) => GConvert (K1 i c) where
    type GResult (K1 i c) = Result c
    gconvert (K1 x) = convert x

instance (GConvert f) => GConvert (M1 i t f) where
    type GResult (M1 i t f) = GResult f
    gconvert (M1 x) = gconvert x

instance (GConvert f, GConvert g) => GConvert (f :*: g) where
    type GResult (f :*: g) = (GResult f, GResult g)
    gconvert (x :*: y) = (gconvert x, gconvert y)

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

data Data1 = Data1 Int Float
    deriving (Generic)

instance Convert Data1

val :: (Int, Float)
val = convert $ Data1 0 0.0

data Data2 = Data2 Int Float
    deriving (Generic, Convert)


{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Main (main) where

import GHC.Generics

infixr 1 `T`
data T a = T a a deriving Generic
instance HasFixity (T a)

data I a = a `I` a deriving Generic
instance HasFixity (I a)

class HasFixity a where
  fixity :: a -> Fixity
  default fixity :: (Generic a, GHasFixity (Rep a)) => a -> Fixity
  fixity = gfixity . from

class GHasFixity f where
  gfixity :: f a -> Fixity

instance GHasFixity f => GHasFixity (D1 d f) where
  gfixity (M1 x) = gfixity x

instance Constructor c => GHasFixity (C1 c f) where
  gfixity c = conFixity c

main :: IO ()
main = do
  putStrLn $ show (fixity (T "a" "b")) ++ ", " ++ show (fixity ("a" `I` "b"))


{-#LANGUAGE TypeApplications#-}
{-#LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE AllowAmbiguousTypes #-}
{-#LANGUAGE FlexibleInstances #-}
{-#LANGUAGE ScopedTypeVariables #-}
{-#LANGUAGE DefaultSignatures #-}
module T12220 where

-- | Type a is only used for
-- type application.
class ToUse a where
    toUse :: Int -> Int

-- | The type used for
-- type application
data Default

-- | The instance using Default as type application.
-- To call use:
-- > toUse @Default
instance ToUse Default where
    toUse a = 3*a

-- | Typeclass whose methods work
-- only with type application.
class Uses a b where
    uses :: b -> [b]
    -- | Default Signature, which generates the problem.
    -- It is the same as the normal one
    -- Comment it to 'fix' the bug.
    default uses :: b -> [b]
    uses v = [v]

-- | But this one doesn't.
-- Unless you comment the default signature.
instance (Uses t a, Uses t b, Uses t c) => Uses t (a,b,c)


module T15012 where

import GHC.Generics
import T15012a

blah :: IO ()
blah = print $ from1 $ TyFamily 1 2


{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeFamilies #-}
module T15012a where

import GHC.Generics

type FakeOut a = Int

data family   TyFamily y z
data instance TyFamily a b = TyFamily Int (FakeOut b)
  deriving Generic1


{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE StandaloneDeriving     #-}
{-# LANGUAGE UndecidableInstances   #-}

-- DeriveAnyClass not enabled

module T5462No1 where

import GHC.Generics hiding (C, C1, D)
import GFunctor

class C1 a where
  c1 :: a -> Int

class C2 a where
  c2 :: a -> Int
  c2 _ = 0

newtype F a = F1 [a]
  deriving (Show, Eq, Generic, Generic1, GFunctor)

data G = G1 deriving (C1)
data H = H1 deriving (C2)


{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE DeriveGeneric          #-}
{-# LANGUAGE DeriveFunctor          #-}
{-# LANGUAGE DefaultSignatures      #-}
{-# LANGUAGE StandaloneDeriving     #-}
{-# LANGUAGE UndecidableInstances   #-}
{-# LANGUAGE DeriveAnyClass    #-}

module Main where

import GHC.Generics hiding (C, C1, D)
import GEq1A
import Enum
import GFunctor

data A = A1
  deriving (Show, Generic, GEq, GEnum)

data B a = B1 | B2 a (B a)
  deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor)

data C phantom a = C1 | C2 a (C phantom a)
  deriving (Show, Generic, Generic1, GEq, GEnum, GFunctor)

data D f a = D1 (f a) (f (D f a)) deriving (Generic, Generic1)
deriving instance (Show (f a), Show (f (D f a))) => Show (D f a)
deriving instance (GEq  (f a), GEq  (f (D f a))) => GEq  (D f a)

data E f a = E1 (f a)
  deriving (Show, Eq, Generic, Generic1, GFunctor)

main = print (
               geq A1 A1
             , take 10 (genum :: [A])

             , geq (B2 A1 B1) B1
             , gmap (++ "lo") (B2 "hel" B1)
             , take 3 (genum :: [B A])

             , geq (C2 A1 C1) C1
             , gmap (++ "lo") (C2 "hel" C1)

             , geq (D1 "a" []) (D1 "a" [])

             , gmap (++ "lo") (E1 ["hel"])
             )


{-# LANGUAGE FlexibleContexts              #-}
{-# LANGUAGE FlexibleInstances             #-}
{-# LANGUAGE DeriveGeneric                 #-}
{-# LANGUAGE DefaultSignatures             #-}
{-# LANGUAGE StandaloneDeriving            #-}
{-# LANGUAGE UndecidableInstances          #-}
{-# LANGUAGE DeriveAnyClass                #-}
{-# LANGUAGE GeneralizedNewtypeDeriving    #-}

module Main where

import GHC.Generics hiding (C, C1, D)
import GFunctor

class C1 a where
  c1 :: a -> Int
  c1 _ = 1

class C2 a where
  c21 :: a -> Int
  c21 = c22
  c22 :: a -> Int
  c22 = c21
  {-# MINIMAL c21 | c22 #-}

newtype D = D Int deriving C1

instance C1 Int where c1 _ = 2

newtype F a = F1 [a]
  deriving (Show, Eq, Generic, Generic1, GFunctor)

data G = G1 deriving (C1)
data H = H1 deriving (C2)

main = print (c1 (D 3))


{-# LANGUAGE StandaloneDeriving, DeriveGeneric #-}

module T5884 where

import GHC.Generics
import T5884Other

deriving instance Generic (Pair a)


module T5884Other where

data Pair a = Pair a a


{-# LANGUAGE DeriveGeneric #-}
module T7878A where

import T7878B
import GHC.Generics

data Test deriving Generic


module T7878B where

import {-# SOURCE #-} T7878A


{-# Language DeriveGeneric, MagicHash #-}

import GHC.Generics
import GHC.Prim

data Array a = Array (Array# a) deriving Generic1
newtype Vec a = MkVec {unVec :: Array a} deriving Generic1


{-# OPTIONS_GHC -Wall #-}
{-# Language TypeFamilies #-}
{-# Language DeriveGeneric #-}

module T8479 where

import GHC.Generics
import Data.Kind (Type)

class Blah (a :: Type -> Type) where
  type F a :: Type -> Type

data Foo (f :: Type -> Type) a = MkFoo ((F f) a) deriving Generic1


{-# LANGUAGE TypeFamilies       #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE FlexibleInstances  #-}
{-# LANGUAGE StandaloneDeriving #-}

module T9563 where

import Data.Kind (Type)
import GHC.Generics

data family F typ :: Type -> Type
data A
data instance F A a = AData a
  deriving (Generic, Generic1)

data family G a b c d
data instance G Int b Float d = H deriving Generic

deriving instance Generic1 (G Int b Float)


{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DefaultSignatures #-}

module Enum where

import GHC.Generics

-----------------------------------------------------------------------------
-- Utility functions for Enum'
-----------------------------------------------------------------------------

infixr 5 |||

-- | Interleave elements from two lists. Similar to (++), but swap left and
-- right arguments on every recursive application.
--
-- From Mark Jones' talk at AFP2008
(|||) :: [a] -> [a] -> [a]
[]     ||| ys = ys
(x:xs) ||| ys = x : ys ||| xs

-- | Diagonalization of nested lists. Ensure that some elements from every
-- sublist will be included. Handles infinite sublists.
--
-- From Mark Jones' talk at AFP2008
diag :: [[a]] -> [a]
diag = concat . foldr skew [] . map (map (\x -> [x]))

skew :: [[a]] -> [[a]] -> [[a]]
skew []     ys = ys
skew (x:xs) ys = x : combine (++) xs ys

combine :: (a -> a -> a) -> [a] -> [a] -> [a]
combine _ xs     []     = xs
combine _ []     ys     = ys
combine f (x:xs) (y:ys) = f x y : combine f xs ys

findIndex :: (a -> Bool) -> [a] -> Maybe Int
findIndex p xs = let l = [ i | (y,i) <- zip xs [(0::Int)..], p y]
                 in if (null l)
                    then Nothing
                    else Just (head l)

--------------------------------------------------------------------------------
-- Generic enum
--------------------------------------------------------------------------------

class Enum' f where
  enum' :: [f a]

instance Enum' U1 where
  enum' = [U1]

instance (GEnum c) => Enum' (K1 i c) where
  enum' = map K1 genum

instance (Enum' f) => Enum' (M1 i c f) where
  enum' = map M1 enum'

instance (Enum' f, Enum' g) => Enum' (f :+: g) where
  enum' = map L1 enum' ||| map R1 enum'

instance (Enum' f, Enum' g) => Enum' (f :*: g) where
  enum' = diag [ [ x :*: y | y <- enum' ] | x <- enum' ]

instance (GEnum a) => GEnum (Maybe a)
instance (GEnum a) => GEnum [a]

genumDefault :: (Generic a, Enum' (Rep a)) => [a]
genumDefault = map to enum'

class GEnum a where
  genum :: [a]

  default genum :: (Generic a, Enum' (Rep a)) => [a]
  genum = genumDefault

instance GEnum Int where
  genum = [0..] ||| (neg 0) where
    neg n = (n-1) : neg (n-1)


{-# LANGUAGE TypeOperators, DeriveGeneric, TypeFamilies,
             FlexibleInstances, MagicHash #-}

module Main where

import Data.Kind
import GHC.Exts
import GHC.Generics hiding (C, D)
import GEq1A

-- We should be able to generate a generic representation for these types

data C = C0 | C1
  deriving Generic

data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
  deriving Generic

data (:**:) a b = a :**: b
  deriving Generic

data family F a b :: Type -> Type
data instance F Int b c = F b Int c
  deriving Generic

data U a = U a Addr# Char# Double# Float# Int# Word#
  deriving Generic

data family UF a b :: Type -> Type
data instance UF Int b c = UF b c Addr# Char# Double# Float# Int# Word#
  deriving Generic

-- Example values
c0 = C0
c1 = C1

d0 :: D Char
d0 = D0
d1 = D1 'p' D0

p1 :: Int :**: Char
p1 = 3 :**: 'p'

f1 :: F Int Float Char
f1 = F 0.0 3 'h'
f2 = F 0.0 4 'h'

u0 :: U Int
u0 = U 1 "1"# '1'# 1.0## 1.0# 1# 1##
{-# NOINLINE u0 #-}

uf0 :: UF Int Int Int
uf0 = UF 2 2 "1"# '2'# 2.0## 2.0# 2# 2##
{-# NOINLINE uf0 #-}

-- Generic instances
instance                   GEq C
instance (GEq a)        => GEq (D a)
instance (GEq a, GEq b) => GEq (a :**: b)
instance (GEq b, GEq c) => GEq (F Int b c)
instance (GEq a)        => GEq (U a)
instance (GEq b, GEq c) => GEq (UF Int b c)

-- Tests
teq0 = geq c0  c1
teq1 = geq d0  d1
teq2 = geq d0  d0
teq3 = geq p1  p1
teq4 = geq f1  f2
teq5 = geq u0  u0
teq6 = geq uf0 uf0

main = mapM_ print [teq0, teq1, teq2, teq3, teq4, teq5, teq6]


{-# LANGUAGE TypeOperators, DefaultSignatures,
             FlexibleContexts, FlexibleInstances, MagicHash #-}

module GEq1A where

import GHC.Exts
import GHC.Generics

class GEq' f where
  geq' :: f a -> f a -> Bool

instance GEq' U1 where
  geq' _ _ = True

instance (GEq c) => GEq' (K1 i c) where
  geq' (K1 a) (K1 b) = geq a b

-- No instances for P or Rec because geq is only applicable to types of kind *

instance (GEq' a) => GEq' (M1 i c a) where
  geq' (M1 a) (M1 b) = geq' a b

instance (GEq' a, GEq' b) => GEq' (a :+: b) where
  geq' (L1 a) (L1 b) = geq' a b
  geq' (R1 a) (R1 b) = geq' a b
  geq' _      _      = False

instance (GEq' a, GEq' b) => GEq' (a :*: b) where
  geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2

-- Unboxed types
instance GEq' UAddr where
  geq' (UAddr a1) (UAddr a2)     = isTrue# (eqAddr# a1 a2)
instance GEq' UChar where
  geq' (UChar c1) (UChar c2)     = isTrue# (eqChar# c1 c2)
instance GEq' UDouble where
  geq' (UDouble d1) (UDouble d2) = isTrue# (d1 ==## d2)
instance GEq' UFloat where
  geq' (UFloat f1) (UFloat f2)   = isTrue# (eqFloat# f1 f2)
instance GEq' UInt where
  geq' (UInt i1) (UInt i2)       = isTrue# (i1 ==# i2)
instance GEq' UWord where
  geq' (UWord w1) (UWord w2)     = isTrue# (eqWord# w1 w2)

class GEq a where
  geq :: a -> a -> Bool
  default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
  geq x y = geq' (from x) (from y)

-- Base types instances (ad-hoc)
instance GEq Char   where geq = (==)
instance GEq Int    where geq = (==)
instance GEq Float  where geq = (==)

-- Generic instances
instance (GEq a) => GEq (Maybe a)
instance (GEq a) => GEq [a]


{-# LANGUAGE TypeOperators, DefaultSignatures, FlexibleInstances, DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}

module Main where

import GHC.Generics hiding (C, D)

class GEq' f where
  geq' :: f a -> f a -> Bool

instance GEq' U1 where
  geq' _ _ = True

instance (GEq c) => GEq' (K1 i c) where
  geq' (K1 a) (K1 b) = geq a b

-- No instances for P or Rec because geq is only applicable to types of kind *

instance (GEq' a) => GEq' (M1 i c a) where
  geq' (M1 a) (M1 b) = geq' a b

instance (GEq' a, GEq' b) => GEq' (a :+: b) where
  geq' (L1 a) (L1 b) = geq' a b
  geq' (R1 a) (R1 b) = geq' a b
  geq' _      _      = False

instance (GEq' a, GEq' b) => GEq' (a :*: b) where
  geq' (a1 :*: b1) (a2 :*: b2) = geq' a1 a2 && geq' b1 b2

class GEq a where
  geq :: a -> a -> Bool
  default geq :: (Generic a, GEq' (Rep a)) => a -> a -> Bool
  geq x y = geq' (from x) (from y)

-- Base types instances (ad-hoc)
instance GEq Char   where geq = (==)
instance GEq Int    where geq = (==)
instance GEq Float  where geq = (==)
{-
-- Generic instances
instance (GEq a) => GEq (Maybe a)
instance (GEq a) => GEq [a]
-}

data C = C0 | C1
  deriving Generic

data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
  deriving Generic

data (:**:) a b = a :**: b
  deriving Generic

-- Example values
c0 = C0
c1 = C1

d0 :: D Char
d0 = D0
d1 = D1 'p' D0

p1 :: Int :**: Char
p1 = 3 :**: 'p'

-- Generic instances
instance                   GEq C
instance (GEq a)        => GEq (D a)
instance (GEq a, GEq b) => GEq (a :**: b)

-- Tests
teq0 = geq c0 c1
teq1 = geq d0 d1
teq2 = geq d0 d0
teq3 = geq p1 p1

main = mapM_ print [teq0, teq1, teq2, teq3]


{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE DefaultSignatures          #-}

module GFunctor (
  -- * Generic Functor class
    GFunctor(..)
  ) where

import GHC.Generics

--------------------------------------------------------------------------------
-- Generic fmap
--------------------------------------------------------------------------------

class GFunctor' f where
  gmap' :: (a -> b) -> f a -> f b

instance GFunctor' U1 where
  gmap' _ U1 = U1

instance GFunctor' Par1 where
  gmap' f (Par1 a) = Par1 (f a)

instance GFunctor' (K1 i c) where
  gmap' _ (K1 a) = K1 a

instance (GFunctor f) => GFunctor' (Rec1 f) where
  gmap' f (Rec1 a) = Rec1 (gmap f a)

instance (GFunctor' f) => GFunctor' (M1 i c f) where
  gmap' f (M1 a) = M1 (gmap' f a)

instance (GFunctor' f, GFunctor' g) => GFunctor' (f :+: g) where
  gmap' f (L1 a) = L1 (gmap' f a)
  gmap' f (R1 a) = R1 (gmap' f a)

instance (GFunctor' f, GFunctor' g) => GFunctor' (f :*: g) where
  gmap' f (a :*: b) = gmap' f a :*: gmap' f b

instance (GFunctor f, GFunctor' g) => GFunctor' (f :.: g) where
  gmap' f (Comp1 x) = Comp1 (gmap (gmap' f) x)

class GFunctor f where
  gmap :: (a -> b) -> f a -> f b
  default gmap :: (Generic1 f, GFunctor' (Rep1 f))
               => (a -> b) -> f a -> f b
  gmap f = to1 . gmap' f . from1

-- Base types instances
instance GFunctor Maybe
instance GFunctor []
instance GFunctor ((,) a)


{-# LANGUAGE DeriveGeneric #-}

module Main where

import GHC.Generics hiding (C, D)
import GFunctor

-- We should be able to generate a generic representation for these types
data D a = D0 | D1 { d11 :: a, d12 :: (D a) }
  deriving (Show, Generic, Generic1)

-- Example values
d0 :: D Char
d0 = D0
d1 = D1 (Just 'p') D0

d2 :: (Fractional a) => D (a,a)
d2 = D1 (3,0.14) D0

-- Generic instances
instance GFunctor D

-- Tests
main = print ( gmap (+1) (Just 2)
             , gmap (+1) [0,1,2]
             , gmap (+1) (0,0)
             , gmap undefined d0 :: D ()
             , gmap (const 'q') d1
             , gmap (\(a,b) -> a + b) d2 :: D Float)


{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE DefaultSignatures          #-}

module GMap (
  -- * Generic map class
    GMap(..)
  ) where

import GHC.Generics

--------------------------------------------------------------------------------
-- Generic map
--------------------------------------------------------------------------------

class GMap t where
  gmap :: (a -> b) -> t a -> t b
  default gmap :: (Generic1 t, GMap (Rep1 t)) => (a -> b) -> t a -> t b
  gmap f = to1 . gmap f . from1

instance GMap Par1 where gmap f (Par1 x) = Par1 $ f x
instance GMap f => GMap (Rec1 f) where gmap f (Rec1 x) = Rec1 $ gmap f x

instance GMap U1 where gmap _ U1 = U1

instance GMap (K1 i c) where gmap _ (K1 x) = K1 x

instance (GMap a) => GMap (M1 i d a) where gmap f (M1 x) = M1 $ gmap f x

instance (GMap a, GMap b) => GMap (a :+: b) where
  gmap f (L1 x) = L1 $ gmap f x
  gmap f (R1 x) = R1 $ gmap f x

instance (GMap a, GMap b) => GMap (a :*: b) where
  gmap f (x :*: y) = gmap f x :*: gmap f y

-- Base types instances
instance GMap []   where gmap = map
instance GMap Maybe    where gmap = fmap
instance GMap ((,) a)    where gmap f ~(x, y) = (x, f y)


{-# LANGUAGE DeriveGeneric #-}

module Main where

import GHC.Generics (Generic1)
import GMap

-- We should be able to generate a generic representation for these types
data D a = D0 | D1 { d11 :: a, d12 :: (D a) } deriving (Show, Generic1)

-- Example values
d0 :: D Char
d0 = D0
d1 = D1 (Just 'p') D0

d2 :: D (Int,Float)
d2 = D1 (3,0.14) D0

-- Generic instances
instance GMap D

-- Tests
main = do
  print $ gmap id d0
  (let isJust (Just _) = True
       isJust Nothing = False in print $ gmap isJust d1)
  print $ gmap fst d2


{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE DefaultSignatures          #-}
{-# LANGUAGE MagicHash                  #-}
{-# LANGUAGE PolyKinds                  #-}

module GShow (
  -- * Generic show class
    GShow(..)
  ) where

import GHC.Exts
import GHC.Generics

--------------------------------------------------------------------------------
-- Generic show
--------------------------------------------------------------------------------

data Type = Rec | Tup | Pref | Inf String

class GShow' f where
  gshowsPrec' :: Type -> Int -> f a -> ShowS
  isNullary   :: f a -> Bool
  isNullary = error "generic show (isNullary): unnecessary case"

instance GShow' U1 where
  gshowsPrec' _ _ U1 = id
  isNullary _ = True

instance (GShow c) => GShow' (K1 i c) where
  gshowsPrec' _ n (K1 a) = gshowsPrec n a
  isNullary _ = False

-- No instances for P or Rec because gshow is only applicable to types of kind *

instance (GShow' a, Constructor c) => GShow' (M1 C c a) where
  gshowsPrec' _ n c@(M1 x) =
    case (fixity, conIsTuple c) of
      (Prefix,False) -> showParen (n > 10 && not (isNullary x))
                         ( showString (conName c)
                         . if (isNullary x) then id else showChar ' '
                         . showBraces t (gshowsPrec' t 10 x))
      (Prefix,True)  -> showParen (n > 10) (showBraces t (gshowsPrec' t 10 x))
      (Infix _ m,_)  -> showParen (n > m)  (showBraces t (gshowsPrec' t m  x))
      where fixity = conFixity c
            t = if (conIsRecord c) then Rec else
                 if (conIsTuple c) then Tup else
                  case fixity of
                    Prefix    -> Pref
                    Infix _ _ -> Inf (show (conName c))
            showBraces :: Type -> ShowS -> ShowS
            showBraces Rec     p = showChar '{' . p . showChar '}'
            showBraces Tup     p = showChar '(' . p . showChar ')'
            showBraces Pref    p = p
            showBraces (Inf _) p = p
            conIsTuple c = case conName c of
                             ('(':',':_) -> True
                             otherwise   -> False

  isNullary (M1 x) = isNullary x

instance (Selector s, GShow' a) => GShow' (M1 S s a) where
  gshowsPrec' t n s@(M1 x) | selName s == "" = showParen (n > 10)
                                                 (gshowsPrec' t n x)
                           | otherwise       =   showString (selName s)
                                               . showString " = "
                                               . gshowsPrec' t 0 x
  isNullary (M1 x) = isNullary x

instance (GShow' a) => GShow' (M1 D d a) where
  gshowsPrec' t n (M1 x) = gshowsPrec' t n x

instance (GShow' a, GShow' b) => GShow' (a :+: b) where
  gshowsPrec' t n (L1 x) = gshowsPrec' t n x
  gshowsPrec' t n (R1 x) = gshowsPrec' t n x

instance (GShow' a, GShow' b) => GShow' (a :*: b) where
  gshowsPrec' t@Rec     n (a :*: b) =
    gshowsPrec' t n     a . showString ", " . gshowsPrec' t n     b
  gshowsPrec' t@(Inf s) n (a :*: b) =
    gshowsPrec' t n     a . showString s    . gshowsPrec' t n     b
  gshowsPrec' t@Tup     n (a :*: b) =
    gshowsPrec' t n     a . showChar ','    . gshowsPrec' t n     b
  gshowsPrec' t@Pref    n (a :*: b) =
    gshowsPrec' t (n+1) a . showChar ' '    . gshowsPrec' t (n+1) b

  -- If we have a product then it is not a nullary constructor
  isNullary _ = False

-- Unboxed instances
instance GShow' UChar where
  gshowsPrec' _ _ (UChar c)   = showsPrec 0 (C# c) . showChar '#'
instance GShow' UDouble where
  gshowsPrec' _ _ (UDouble d) = showsPrec 0 (D# d) . showString "##"
instance GShow' UFloat where
  gshowsPrec' _ _ (UFloat f)  = showsPrec 0 (F# f) . showChar '#'
instance GShow' UInt where
  gshowsPrec' _ _ (UInt i)    = showsPrec 0 (I# i) . showChar '#'
instance GShow' UWord where
  gshowsPrec' _ _ (UWord w)   = showsPrec 0 (W# w) . showString "##"

class GShow a where
  gshowsPrec :: Int -> a -> ShowS
  default gshowsPrec :: (Generic a, GShow' (Rep a)) => Int -> a -> ShowS
  gshowsPrec n = gshowsPrec' Pref n . from

  gshows :: a -> ShowS
  gshows = gshowsPrec 0

  gshow :: a -> String
  gshow x = gshows x ""

-- Base types instances
instance GShow Char   where gshowsPrec = showsPrec
instance GShow Double where gshowsPrec = showsPrec
instance GShow Int    where gshowsPrec = showsPrec
instance GShow Float  where gshowsPrec = showsPrec
instance {-# OVERLAPPING #-}
         GShow String where gshowsPrec = showsPrec
instance GShow Word   where gshowsPrec = showsPrec
instance GShow Bool   where gshowsPrec = showsPrec

intersperse :: a -> [a] -> [a]
intersperse _ []    = []
intersperse _ [h]   = [h]
intersperse x (h:t) = h : x : (intersperse x t)

instance (GShow a) => GShow [a] where
  gshowsPrec _ l =   showChar '['
                   . foldr (.) id
                      (intersperse (showChar ',') (map (gshowsPrec 0) l))
                   . showChar ']'

instance (GShow a)          => GShow (Maybe a)
instance (GShow a, GShow b) => GShow (a,b)


{-# LANGUAGE DeriveGeneric, MagicHash #-}

module Main where

import GHC.Exts
import GHC.Generics hiding (C, D)
import GShow

-- We should be able to generate a generic representation for these types
data D a = D0 | D1 { d11 :: a, d12 :: (D a) } deriving Generic
data U a = U a Char# Double# Float# Int# Word# deriving Generic

-- Example values
d0 :: D Char
d0 = D0
d1 = D1 (Just 'p') D0

d2 :: D (Int,Float)
d2 = D1 (3,0.14) D0

u0 :: U Int
u0 = U 1 '1'# -1.0## -1.0# -1# 1##

-- Generic instances
instance (GShow a) => GShow (D a)
instance (GShow a) => GShow (U a)

-- Tests
main = mapM_ putStrLn [gshow d0, gshow d1, gshow d2, gshow u0]


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T10604_Authenticated where

import GHC.Generics

data AuthParam = Prover | Verifier

class MapAuth f where
    mapAuth :: f 'Prover -> f 'Verifier
    default mapAuth :: (GMapAuth (Rep1 f), Generic1 f)
                    => f 'Prover -> f 'Verifier
    mapAuth = to1 . gmapAuth . from1

class GMapAuth f where
    gmapAuth :: f 'Prover -> f 'Verifier

instance GMapAuth V1 where
    gmapAuth = undefined

instance GMapAuth U1 where
    gmapAuth U1 = U1

instance (GMapAuth l, GMapAuth r) => GMapAuth (l :+: r) where
    gmapAuth (L1 x) = L1 (gmapAuth x)
    gmapAuth (R1 x) = R1 (gmapAuth x)

instance (GMapAuth l, GMapAuth r) => GMapAuth (l :*: r) where
    gmapAuth (x :*: y) = gmapAuth x :*: gmapAuth y

instance GMapAuth (K1 i c) where
    gmapAuth (K1 c) = K1 c

instance (GMapAuth f) => GMapAuth (M1 i t f) where
    gmapAuth (M1 x) = M1 (gmapAuth x)

instance (MapAuth f) => GMapAuth (Rec1 f) where
    gmapAuth (Rec1 x) = Rec1 (mapAuth x)


{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
module T10604_bad_variable_occurrence where

import GHC.Generics

newtype Fix f = In { out :: f (Fix f) }
  deriving Generic1


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -ddump-deriv -fprint-explicit-kinds #-}
module T10604_deriving where

import GHC.Generics
import Data.Kind (Type)

data Empty (a :: Bool)
  deriving (Generic, Generic1)
data Proxy (a :: k) = Proxy
  deriving (Functor, Generic, Generic1)
data Wrap (a :: Type -> Type) = Wrap (Proxy a)
  deriving (Generic, Generic1)
data Wrap2 (a :: k -> Type) = Wrap2 (Proxy (Proxy a))
  deriving (Generic, Generic1)
data SumOfProducts a = Prod1 (Proxy a) (Proxy a) | Prod2 (Proxy a) (Proxy a)
  deriving (Generic, Generic1)

data Starify a = Starify1 a | Starify2 Int
  deriving (Generic, Generic1)


{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE KindSignatures #-}
module T10604_no_PolyKinds where

import GHC.Generics

data F (f :: * -> *) = F deriving Generic1


{-# LANGUAGE MultiParamTypeClasses      #-}
{-# LANGUAGE TypeSynonymInstances       #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE TypeOperators              #-}
{-# LANGUAGE DefaultSignatures          #-}
{- # LANGUAGE IncoherentInstances        #-} -- necessary, unfortunately
{-# LANGUAGE OverlappingInstances        #-}

module GUniplate where

import GHC.Generics

--------------------------------------------------------------------------------
-- Generic Uniplate
--------------------------------------------------------------------------------

class Uniplate' f b where
  children' :: f a -> [b]

instance Uniplate' U1 a where
  children' U1 = []

instance {-# OVERLAPPING #-} Uniplate' (K1 i a) a where
  -- overlaps the (Uniplate' (K1 i a) b) instance
  children' (K1 a) = [a]

instance Uniplate' (K1 i a) b where
  children' (K1 _) = []

instance (Uniplate' f b) => Uniplate' (M1 i c f) b where
  children' (M1 a) = children' a

instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :+: g) b where
  children' (L1 a) = children' a
  children' (R1 a) = children' a

instance (Uniplate' f b, Uniplate' g b) => Uniplate' (f :*: g) b where
  children' (a :*: b) = children' a ++ children' b

class Uniplate a where
  children :: a -> [a]
  default children :: (Generic a, Uniplate' (Rep a) a) => a -> [a]
  children = children' . from

-- Base types instances
instance Uniplate Char  where children _ = []
instance Uniplate Int   where children _ = []
instance Uniplate Float where children _ = []

instance Uniplate [a] where
  children []    = []
  children (_:t) = [t]


{-# LANGUAGE DeriveGeneric #-}

module Main where

import GHC.Generics
import GUniplate

data Tree     = Leaf | Node Int Tree Tree deriving (Show, Generic)
data Pair a b = Pair a b                  deriving (Show, Generic)

instance Uniplate Tree
instance Uniplate (Pair a b)

-- Tests
t1 = children ('p')
t2 = children (Pair "abc" (Pair "abc" 2))
t3 = children (Node 2 Leaf Leaf)

main = print (t1, t2, t3)


module Main where

import Config

main :: IO ()
main = putStrLn cProjectName


module Main where

import DynFlags
import GHC
import qualified GHC.LanguageExtensions as LangExt

import Control.Monad (forM_)
import Control.Monad.IO.Class (liftIO)
import System.Environment (getArgs)

main :: IO ()
main = do
  [libdir] <- getArgs
  runGhc (Just libdir) $ do
    dflags <- getSessionDynFlags
    setSessionDynFlags $ dflags
      `gopt_unset` Opt_ImplicitImportQualified
      `xopt_unset` LangExt.ImplicitPrelude

    forM_ exprs $ \expr ->
      handleSourceError printException $ do
        dyn <- dynCompileExpr expr
        liftIO $ print dyn
  where
  exprs =
    [ ""
    , "(),()"
    , "()"
    , "\"test\""
    , unlines [ "[()]"
              , " :: [()]"
              ]
    ]


module Main where

import DynFlags
import GHC

import Control.Monad.IO.Class (liftIO)
import System.Environment
import HeaderInfo
import Outputable
import StringBuffer

main :: IO ()
main = do
  [libdir] <- getArgs
  runGhc (Just libdir) $ do
    dflags <- getSessionDynFlags
    let dflags' = dflags `gopt_set` Opt_KeepRawTokenStream
                         `gopt_set` Opt_Haddock
        filename = "T10942_A.hs"
    setSessionDynFlags dflags'
    stringBuffer <- liftIO $ hGetStringBuffer filename
    liftIO $ print (map unLoc (getOptions dflags' stringBuffer filename))


{-

A normal comment, to check if we can still pick up the CPP directive after it.

-}
-- Check that we can parse a file with leading comments

-- ^ haddock
-- * haddock
-- | haddock
-- $ haddock
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
module T10942 where

main = return ()


import System.Environment
import DynFlags
import FastString
import GHC
import StringBuffer
import Lexer
import SrcLoc

main :: IO ()
main = do
    [libdir] <- getArgs

    let stringBuffer = stringToStringBuffer "-- $bar some\n-- named chunk"
        loc = mkRealSrcLoc (mkFastString "Foo.hs") 1 1

    token <- runGhc (Just libdir) $ do
        dflags <- getSessionDynFlags
        let pstate = mkPState (dflags `gopt_set` Opt_Haddock) stringBuffer loc
        case unP (lexer False return) pstate of
            POk _ token -> return (unLoc token)
            _           -> error "No token"

    -- #11579
    -- Expected:                    "ITdocCommentNamed "bar some\n named chunk"
    -- Actual (with ghc-8.0.1-rc2): "ITdocCommentNamed "bar some"
    print token


module Main where

import DynFlags

import Control.Monad
import Data.List

-- Verify bogus flags aren't printed on flagsForCompletion and
-- allNonDeprecatedFlags:
--  * -fwarn-
--  * -fno-warn-
--
-- Should print nothing
main :: IO ()
main = mapM_ print $ fwarnFlags (flagsForCompletion True) ++ nonDepFwarnFlags

-- Get flags beginning with -fwarn- and -fno-warn-
fwarnFlags :: [String] -> [String]
fwarnFlags = filter isFwarn
  where isFwarn flag = any (flip isPrefixOf $ flag) ["-fwarn-", "-fno-warn"]

-- Get suggested flags for -fwarn-, -fno-warn-
nonDepFwarnFlags :: [String]
nonDepFwarnFlags = filter isFwarn allNonDeprecatedFlags
  where isFwarn "-fwarn-"    = True
        isFwarn "-fno-warn-" = True
        isFwarn _            = False


{-# LANGUAGE PatternGuards #-}
{-# LANGUAGE ViewPatterns     #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies     #-}
module Main where

import System.IO
import GHC
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )

main::IO()
main = do
        let c="module Test where\ndata DataT=MkData {name :: String}\n"
        writeFile "Test.hs" c
        [libdir] <- getArgs
        ok<-    runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        setSessionDynFlags dflags
                        let mn =mkModuleName "Test"
                        addTarget Target { targetId = TargetModule mn, targetAllowObjCode = True, targetContents = Nothing }
                        load LoadAllTargets
                        modSum <- getModSummary mn
                        p <- parseModule modSum
                        t <- typecheckModule p
                        d <- desugarModule t
                        l <- loadModule d
                        let ts=typecheckedSource l
--                        liftIO (putStr (showSDocDebug (ppr ts)))
                        let fs=filterBag isDataCon ts
                        return $ not $ isEmptyBag fs
        removeFile "Test.hs"
        print ok
    where
      isDataCon (dL->L _ (AbsBinds { abs_binds = bs }))
        = not (isEmptyBag (filterBag isDataCon bs))
      isDataCon (dL->L l (f@FunBind {}))
        | (MG _ (dL->L _ (m:_)) _) <- fun_matches f,
          ((dL->L _ (c@ConPatOut{})):_)<-hsLMatchPats m,
          (dL->L l _)<-pat_con c
        = isGoodSrcSpan l       -- Check that the source location is a good one
      isDataCon _
        = False


module Main where

import System.IO
import DynFlags
import GHC
import Exception
import Module
import FastString
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import PrelNames

main :: IO()
main
  = do  [libdir] <- getArgs
        ok <- runGhc (Just libdir) $ do
          dflags <- getSessionDynFlags
          setSessionDynFlags dflags
          liftIO (setUnsafeGlobalDynFlags dflags)

          setContext [ IIDecl (simpleImportDecl pRELUDE_NAME)
                     , IIDecl (simpleImportDecl (mkModuleNameFS (fsLit "System.IO")))]
          runDecls "data X = Y ()"
          execStmt "print True" execOptions
          gtry $ execStmt "print (Y ())" execOptions :: GhcMonad m => m (Either SomeException ExecResult)
          runDecls "data X = Y () deriving Show"
          _ <- dynCompileExpr "'x'"
          execStmt "print (Y ())" execOptions
          execStmt "System.IO.hFlush System.IO.stdout" execOptions
        print "done"


module Main where

import GHC
import GhcMonad
import Outputable
import System.IO
import System.Environment( getArgs )

main
 = do { [libdir] <- getArgs
      ; runGhc (Just libdir) $ do
           flags <- getSessionDynFlags
           setSessionDynFlags (flags{ hscTarget = HscInterpreted, ghcLink = LinkInMemory})
           target <- guessTarget "T8639_api_a.hs" Nothing
           setTargets [target]
           load LoadAllTargets
           imps <- mapM parseImportDecl ["import Prelude", "import System.IO", "import T8639_api_a"]
           setContext (map IIDecl imps)

           -- With the next line, you get an "Not in scope" exception.
           -- If you comment out this runStmt, it runs without error and prints the  type.
           execStmt "putStrLn (show 3)" execOptions
           execStmt "hFlush stdout" execOptions

           ty <- exprType TM_Inst "T8639_api_a.it"
           liftIO (putStrLn (showPpr flags ty))
       ; hFlush stdout }


module Main where

import GHC
import DynFlags
import System.Environment
import GhcMonad

testStrings = [
    "import Data.Maybe"
  , "import qualified Data.Maybe"
  , "import Data.Maybe (isJust)"

  , "add a b = a+b"
  , "data Foo = Foo String"
  , "deriving instance Show Foo"
  , "{-# WARNING Foo \"Just a warning\" #-}"
  , "{-# ANN foo (Just \"Hello\") #-}"
  , "{-# RULES \"map/map\" forall f g xs. map f (map g xs) = map (f.g) xs #-}"
  , "class HasString a where\n\
    \  update :: a -> (String -> String) -> a\n\
    \  upcase :: a -> a\n\
    \  upcase x = update x (fmap toUpper)\n\
    \  content :: a -> String\n\
    \  default content :: Show a => a -> String\n\
    \  content = show"
  , "instance HasString Foo where\n\
    \  update (Foo s) f = Foo (f s)\n\
    \  content (Foo s) = s"

  , "add a b"
  , "let foo = add a b"
  , "x <- foo y"
  , "5 + 8"

  , "a <-"
  , "2 +"
  , "@#"
  ]

main = do
  [libdir] <- getArgs
  runGhc (Just libdir) $ do
    liftIO (putStrLn "Is import:")
    testWithParser isImport

    liftIO (putStrLn "Is declaration:")
    testWithParser isDecl

    liftIO (putStrLn "Is statement:")
    testWithParser isStmt

  where
    testWithParser parser = do
      dflags <- getSessionDynFlags
      liftIO . putStrLn . unlines $ map (testExpr (parser dflags)) testStrings

    testExpr parser expr = do
      expr ++ ": " ++ show (parser expr)


module Main where

import GHC
import Packages
import GhcMonad
import Outputable
import System.Environment
import DynFlags
import Module

main =
  do [libdir] <- getArgs
     _ <- runGhc (Just libdir) $ do
                dflags <- getSessionDynFlags
                setSessionDynFlags dflags
                dflags <- getSessionDynFlags
                liftIO $ print (mkModuleName "Outputable" `elem` listVisibleModuleNames dflags)
     _ <- runGhc (Just libdir) $ do
                dflags <- getSessionDynFlags
                setSessionDynFlags (dflags {
                    packageFlags = [ExposePackage "-package ghc"
                                                  (PackageArg "ghc")
                                                  (ModRenaming True [])]
                    })
                dflags <- getSessionDynFlags
                liftIO $ print (mkModuleName "Outputable" `elem` listVisibleModuleNames dflags)
     return ()


{-# LANGUAGE TypeOperators #-}
module AnnotationLet (foo) where

{
import qualified Data.List as DL
;
foo = let
        a 0 = 1
        a _ = 2
        b = 2
      in a b
;
infixr 8 +
;
data ((f + g)) a = InL (f a) | InR (g a)
;
}


{-# LANGUAGE RankNTypes #-}

-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

-- import Data.Generics
import Data.Data
import Data.List
import System.IO
import GHC
import DynFlags
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir] <- getArgs
        testOneFile libdir "AnnotationLet"

testOneFile libdir fileName = do
        p <- runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        setSessionDynFlags dflags
                        let mn =mkModuleName fileName
                        addTarget Target { targetId = TargetModule mn
                                         , targetAllowObjCode = True
                                         , targetContents = Nothing }
                        load LoadAllTargets
                        modSum <- getModSummary mn
                        p <- parseModule modSum
                        t <- typecheckModule p
                        d <- desugarModule t
                        l <- loadModule d
                        let ts=typecheckedSource l
                            r =renamedSource l
                        -- liftIO (putStr (showSDocDebug (ppr ts)))
                        return (pm_annotations p)

        let anns = p
            (l,_) = fst $ head $ Map.toList (fst anns)
            annModule = (getAnnotation anns l AnnModule)
            annLet    = (getAnnotation anns l AnnLet)

        putStrLn (intercalate "\n" [showAnns anns,pp annModule,pp annLet,pp l])

showAnns (anns,_) = "[\n" ++ (intercalate "\n"
   $ map (\((s,k),v)
              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
   $ Map.toList anns)
    ++ "]\n"

pp a = showPpr unsafeGlobalDynFlags a


{-# LANGUAGE TupleSections,TypeFamilies #-}
{-# LANGUAGE PatternGuards,ScopedTypeVariables #-}
module AnnotationTuple (foo) where

{
import qualified Data.List as DL
;
foo = let
        a = 1
        b = 2
      in a + b

;
bar = print $ map (1, "hello"   , 6.5,, [5, 5, 6, 7]) [Just (), Nothing]
;
baz = (1, "hello", 6.5,,,,) 'a' (Just ())
;
data family GMap k :: * -> *
;
match n
      | Just 5 <- Just n
      , Just 6 <- Nothing
      , Just 7 <- Just 9
      = Just 8
;
boo :: Int = 3
}
-- Note: the trailing whitespace in this file is used to check that we
-- have an annotation for it.


{-# LANGUAGE PatternSynonyms #-}
module BundleExport(P(.., A), Q(B)) where

data P = P

data Q = Q

pattern A = P
pattern B = Q


{-# LANGUAGE RankNTypes #-}

-- This program must be called with GHC's libdir and the file to be checked as
-- the command line arguments.
module CheckUtils where

import Data.Data
import Data.List
import System.IO
import GHC
import BasicTypes
import DynFlags
import MonadUtils
import Outputable
import ApiAnnotation
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Dynamic ( fromDynamic,Dynamic )

_main::IO()
_main = do
        [libdir,fileName] <- getArgs
        testOneFile libdir fileName

testOneFile libdir fileName = do
       ((anns,cs),p) <- runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        setSessionDynFlags dflags
                        let mn =mkModuleName fileName
                        addTarget Target { targetId = TargetModule mn
                                         , targetAllowObjCode = True
                                         , targetContents = Nothing }
                        load LoadAllTargets
                        modSum <- getModSummary mn
                        p <- parseModule modSum
                        return (pm_annotations p,p)

       let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)

           problems = filter (\(s,a) -> not (Set.member s spans))
                             $ getAnnSrcSpans (anns,cs)

           exploded = [((kw,ss),[anchor])
                      | ((anchor,kw),sss) <- Map.toList anns,ss <- sss]

           exploded' = Map.toList $ Map.fromListWith (++) exploded

           problems' = filter (\(_,anchors)
                                -> not (any (\a -> Set.member a spans) anchors))
                              exploded'

       putStrLn "---Problems---------------------"
       putStrLn (intercalate "\n" [showAnns $ Map.fromList $ map snd problems])
       putStrLn "---Problems'--------------------"
       putStrLn (intercalate "\n" [pp $ Map.fromList $ map fst problems'])
       putStrLn "--------------------------------"
       putStrLn (intercalate "\n" [showAnns anns])

    where
      getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
      getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns

      getAllSrcSpans :: (Data t) => t -> [SrcSpan]
      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
        where
          getSrcSpan :: SrcSpan -> [SrcSpan]
          getSrcSpan ss = [ss]

showAnns anns = "[\n" ++ (intercalate "\n"
   $ map (\((s,k),v)
              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
   $ Map.toList anns)
    ++ "]\n"

pp a = showPpr unsafeGlobalDynFlags a

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

-- Copied from syb for the test

-- | Generic queries of type \"r\",
--   i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r

-- | Make a generic query;
--   start from a type-specific case;
--   return a constant otherwise
--
mkQ :: ( Typeable a
       , Typeable b
       )
    => r
    -> (b -> r)
    -> a
    -> r
(r `mkQ` br) a = case cast a of
                        Just b  -> br b
                        Nothing -> r

-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r

-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results

everything k f x = foldl k (f x) (gmapQ (everything k f) x)


{-# LANGUAGE RankNTypes #-}

-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

-- import Data.Generics
import Data.Data
import Data.List
import System.IO
import GHC
import DynFlags
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir] <- getArgs
        testOneFile libdir "CommentsTest" True
        testOneFile libdir "CommentsTest" False

testOneFile libdir fileName useHaddock = do
    p <- runGhc (Just libdir) $ do
        dflags <- getSessionDynFlags
        let dflags' = if useHaddock
                        then gopt_set (gopt_set dflags Opt_Haddock)
                                       Opt_KeepRawTokenStream
                        else gopt_set (gopt_unset dflags Opt_Haddock)
                                       Opt_KeepRawTokenStream
        setSessionDynFlags dflags'
        let mn =mkModuleName fileName
        addTarget Target { targetId = TargetModule mn
                         , targetAllowObjCode = True
                         , targetContents = Nothing }
        load LoadAllTargets
        modSum <- getModSummary mn
        p <- parseModule modSum
        t <- typecheckModule p
        d <- desugarModule t
        l <- loadModule d
        let ts=typecheckedSource l
            r =renamedSource l
        -- liftIO (putStr (showSDocDebug (ppr ts)))
        return (pm_annotations p)

    let anns = p

    putStrLn (intercalate "\n" [showAnns anns])

showAnns (_,anns) = "[\n" ++ (intercalate "\n"
   $ map (\(s,v)
              -> ("( " ++ pp s ++" =\n[" ++ showToks v ++ "])\n"))
   $ Map.toList anns)
    ++ "]\n"

showToks ts = intercalate ",\n\n"
            $ map (\(L p t) -> "(" ++ pp p ++ "," ++ show t ++ ")") ts

pp a = showPpr unsafeGlobalDynFlags a


{-# LANGUAGE DeriveFoldable #-}
module CommentsTest (foo) where
{-
An opening comment
  {- with a nested one -}
  {-# nested PRAGMA #-}
-}

import qualified Data.List as DL

-- | The function @foo@ does blah
foo = let
        a = 1
        b = 2 -- value 2
      in a + b


{-# LANGUAGE ParallelListComp,
             TransformListComp,
             RecordWildCards #-}
--             MonadComprehensions,

module ListComprehensions where

import GHC.Exts
import qualified Data.Map as M
import Data.Ord (comparing)
import Data.List (sortBy)

-- Letâ€™s look at a simple, normal list comprehension to start:

parallelListComp :: [Int]
parallelListComp = [ x + y * z
                   | x <- [0..10]
                   | y <- [10..20]
                   | z <- [20..30]
                   ]

oldest :: [Int] -> [String]
oldest tbl = [ "str"
             | n <- tbl
             , then id
             ]


{-# LANGUAGE RankNTypes #-}

-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

-- import Data.Generics
import Data.Data
import Data.List
import System.IO
import GHC
import BasicTypes
import DynFlags
import MonadUtils
import Outputable
import ApiAnnotation
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import System.Exit
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir] <- getArgs
        testOneFile libdir "ListComprehensions"
        exitSuccess

testOneFile libdir fileName = do
       ((anns,cs),p) <- runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        setSessionDynFlags dflags
                        let mn =mkModuleName fileName
                        addTarget Target { targetId = TargetModule mn
                                         , targetAllowObjCode = True
                                         , targetContents = Nothing }
                        load LoadAllTargets
                        modSum <- getModSummary mn
                        p <- parseModule modSum
                        t <- typecheckModule p
                        d <- desugarModule t
                        l <- loadModule d
                        let ts=typecheckedSource l
                            r =renamedSource l
                        return (pm_annotations p,p)

       let spans = Set.fromList $ getAllSrcSpans (pm_parsed_source p)

       putStrLn (pp spans)
       putStrLn "--------------------------------"
       putStrLn (intercalate "\n" [showAnns anns])

    where
      getAnnSrcSpans :: ApiAnns -> [(SrcSpan,(ApiAnnKey,[SrcSpan]))]
      getAnnSrcSpans (anns,_) = map (\a@((ss,_),_) -> (ss,a)) $ Map.toList anns

      getAllSrcSpans :: (Data t) => t -> [SrcSpan]
      getAllSrcSpans ast = everything (++) ([] `mkQ` getSrcSpan) ast
        where
          getSrcSpan :: SrcSpan -> [SrcSpan]
          getSrcSpan ss = [ss]

showAnns anns = "[\n" ++ (intercalate "\n"
   $ map (\((s,k),v)
              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
   $ Map.toList anns)
    ++ "]\n"

pp a = showPpr unsafeGlobalDynFlags a

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

-- Copied from syb for the test

-- | Generic queries of type \"r\",
--   i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r

-- | Make a generic query;
--   start from a type-specific case;
--   return a constant otherwise
--
mkQ :: ( Typeable a
       , Typeable b
       )
    => r
    -> (b -> r)
    -> a
    -> r
(r `mkQ` br) a = case cast a of
                        Just b  -> br b
                        Nothing -> r

-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r

-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results

everything k f x = foldl k (f x) (gmapQ (everything k f) x)


module Main where

-- Testing that check-api-annotations can load a main module file
main = putStrLn "hello"


{-# LANGUAGE RankNTypes #-}

-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

-- import Data.Generics
import Data.Data
import Data.List
import System.IO
import GHC
import BasicTypes
import DynFlags
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir] <- getArgs
        testOneFile libdir "AnnotationTuple"

testOneFile libdir fileName = do
       ((anns,cs),p) <- runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        setSessionDynFlags dflags
                        let mn =mkModuleName fileName
                        addTarget Target { targetId = TargetModule mn
                                         , targetAllowObjCode = True
                                         , targetContents = Nothing }
                        load LoadAllTargets
                        modSum <- getModSummary mn
                        p <- parseModule modSum
                        t <- typecheckModule p
                        d <- desugarModule t
                        l <- loadModule d
                        let ts=typecheckedSource l
                            r =renamedSource l
                        return (pm_annotations p,p)

       let tupArgs = gq (pm_parsed_source p)

       putStrLn (pp tupArgs)
       putStrLn (intercalate "\n" [showAnns anns])

    where
     gq ast = everything (++) ([] `mkQ` doLHsTupArg) ast

     doLHsTupArg :: LHsTupArg GhcPs -> [(SrcSpan,String,HsExpr GhcPs)]
     doLHsTupArg (L l arg@(Present {}))
                                = [(l,"p",ExplicitTuple noExt [L l arg] Boxed)]
     doLHsTupArg (L l arg@(Missing {}))
                                = [(l,"m",ExplicitTuple noExt [L l arg] Boxed)]

showAnns anns = "[\n" ++ (intercalate "\n"
   $ map (\((s,k),v)
              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
   $ Map.toList anns)
    ++ "]\n"

pp a = showPpr unsafeGlobalDynFlags a

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

-- Copied from syb for the test

-- | Generic queries of type \"r\",
--   i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r

-- | Make a generic query;
--   start from a type-specific case;
--   return a constant otherwise
--
mkQ :: ( Typeable a
       , Typeable b
       )
    => r
    -> (b -> r)
    -> a
    -> r
(r `mkQ` br) a = case cast a of
                        Just b  -> br b
                        Nothing -> r

-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r

-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results

everything k f x = foldl k (f x) (gmapQ (everything k f) x)


{-# LANGUAGE TypeOperators, TypeFamilies #-}
{-# OPTIONS -Wno-star-is-type #-}

module X (type (X.*)) where

type family (*) a b where { (*) a b = Either b a }


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

-- import Data.Generics
import Data.Data
import Data.List
import System.IO
import GHC
import BasicTypes
import DynFlags
import FastString
import ForeignCall
import MonadUtils
import Outputable
import HsDecls
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir,fileName] <- getArgs
        testOneFile libdir fileName

testOneFile libdir fileName = do
       ((anns,cs),p) <- runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        setSessionDynFlags dflags
                        let mn =mkModuleName fileName
                        addTarget Target { targetId = TargetModule mn
                                         , targetAllowObjCode = True
                                         , targetContents = Nothing }
                        load LoadAllTargets
                        modSum <- getModSummary mn
                        p <- parseModule modSum
                        return (pm_annotations p,p)

       let tupArgs = gq (pm_parsed_source p)

       putStrLn (pp tupArgs)
       -- putStrLn (intercalate "\n" [showAnns anns])

    where
     gq ast = everything (++) ([] `mkQ` doWarningTxt
                               `extQ` doImportDecl
                               `extQ` doCType
                               `extQ` doRuleDecl
                               `extQ` doCCallTarget
                               `extQ` doHsExpr
                              ) ast

     doWarningTxt :: WarningTxt -> [(String,[Located (SourceText,FastString)])]
     doWarningTxt ((WarningTxt _ ss))    = [("w",map conv ss)]
     doWarningTxt ((DeprecatedTxt _ ss)) = [("d",map conv ss)]

     doImportDecl :: ImportDecl GhcPs
                  -> [(String,[Located (SourceText,FastString)])]
     doImportDecl (ImportDecl _ _ _ Nothing _ _ _ _ _ _) = []
     doImportDecl (ImportDecl _ _ _ (Just ss) _ _ _ _ _ _)
                                                     = [("i",[conv (noLoc ss)])]

     doCType :: CType -> [(String,[Located (SourceText,FastString)])]
     doCType (CType src (Just (Header hs hf)) c)
                                    = [("c",[noLoc (hs,hf),noLoc c])]
     doCType (CType src Nothing  c) = [("c",[noLoc c])]

     doRuleDecl :: RuleDecl GhcPs
                -> [(String,[Located (SourceText,FastString)])]
     doRuleDecl (HsRule _ ss _ _ _ _ _) = [("r",[ss])]

     doCCallTarget :: CCallTarget
                   -> [(String,[Located (SourceText,FastString)])]
     doCCallTarget (StaticTarget s f _ _) = [("st",[(noLoc (s,f))])]

     doHsExpr :: HsExpr GhcPs -> [(String,[Located (SourceText,FastString)])]
     doHsExpr (HsCoreAnn _ src ss _) = [("co",[conv (noLoc ss)])]
     doHsExpr (HsSCC     _ src ss _) = [("sc",[conv (noLoc ss)])]
     doHsExpr (HsTickPragma _ src (ss,_,_) _ss2 _) = [("tp",[conv (noLoc ss)])]
     doHsExpr _ = []

     conv (GHC.L l (StringLiteral st fs)) = GHC.L l (st,fs)

showAnns anns = "[\n" ++ (intercalate "\n"
   $ map (\((s,k),v)
              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
   $ Map.toList anns)
    ++ "]\n"

pp a = showPpr unsafeGlobalDynFlags a

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

-- Copied from syb for the test

-- | Generic queries of type \"r\",
--   i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r

-- | Make a generic query;
--   start from a type-specific case;
--   return a constant otherwise
--
mkQ :: ( Typeable a
       , Typeable b
       )
    => r
    -> (b -> r)
    -> a
    -> r
(r `mkQ` br) a = case cast a of
                        Just b  -> br b
                        Nothing -> r

-- | Extend a generic query by a type-specific case
extQ :: ( Typeable a
        , Typeable b
        )
     => (a -> q)
     -> (b -> q)
     -> a
     -> q
extQ f g a = maybe (f a) g (cast a)

-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r

-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results

everything k f x = foldl k (f x) (gmapQ (everything k f) x)


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

-- import Data.Generics
import Data.Data hiding (Fixity)
import Data.List
import System.IO
import GHC
import BasicTypes
import DynFlags
import FastString
import ForeignCall
import MonadUtils
import Outputable
import HsDecls
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir,fileName] <- getArgs
        testOneFile libdir fileName

testOneFile libdir fileName = do
       ((anns,cs),p) <- runGhc (Just libdir) $ do
                        dflags <- getSessionDynFlags
                        setSessionDynFlags dflags
                        let mn =mkModuleName fileName
                        addTarget Target { targetId = TargetModule mn
                                         , targetAllowObjCode = True
                                         , targetContents = Nothing }
                        load LoadAllTargets
                        modSum <- getModSummary mn
                        p <- parseModule modSum
                        return (pm_annotations p,p)

       let tupArgs = gq (pm_parsed_source p)

       putStrLn (intercalate "\n" $ map show tupArgs)
       -- putStrLn (pp tupArgs)
       -- putStrLn (intercalate "\n" [showAnns anns])

    where
     gq ast = everything (++) ([] `mkQ` doFixity
                               `extQ` doRuleDecl
                               `extQ` doHsExpr
                               `extQ` doInline
                              ) ast

     doFixity :: Fixity -> [(String,[String])]
     doFixity (Fixity (SourceText ss) _ _) = [("f",[ss])]

     doRuleDecl :: RuleDecl GhcPs
                -> [(String,[String])]
     doRuleDecl (HsRule _ _ (ActiveBefore (SourceText ss) _) _ _ _ _)
       = [("rb",[ss])]
     doRuleDecl (HsRule _ _ (ActiveAfter (SourceText ss) _) _ _ _ _)
       = [("ra",[ss])]
     doRuleDecl (HsRule _ _ _ _ _ _ _) = []

     doHsExpr :: HsExpr GhcPs -> [(String,[String])]
     doHsExpr (HsTickPragma _ src (_,_,_) ss _) = [("tp",[show ss])]
     doHsExpr _ = []

     doInline (InlinePragma _ _ _ (ActiveBefore (SourceText ss) _) _)
         = [("ib",[ss])]
     doInline (InlinePragma _ _ _ (ActiveAfter (SourceText ss) _) _)
         = [("ia",[ss])]
     doInline (InlinePragma _ _ _ _ _ ) = []

showAnns anns = "[\n" ++ (intercalate "\n"
   $ map (\((s,k),v)
              -> ("(AK " ++ pp s ++ " " ++ show k ++" = " ++ pp v ++ ")\n"))
   $ Map.toList anns)
    ++ "]\n"

pp a = showPpr unsafeGlobalDynFlags a

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

-- Copied from syb for the test

-- | Generic queries of type \"r\",
--   i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r

-- | Make a generic query;
--   start from a type-specific case;
--   return a constant otherwise
--
mkQ :: ( Typeable a
       , Typeable b
       )
    => r
    -> (b -> r)
    -> a
    -> r
(r `mkQ` br) a = case cast a of
                        Just b  -> br b
                        Nothing -> r

-- | Extend a generic query by a type-specific case
extQ :: ( Typeable a
        , Typeable b
        )
     => (a -> q)
     -> (b -> q)
     -> a
     -> q
extQ f g a = maybe (f a) g (cast a)

-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r

-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results

everything k f x = foldl k (f x) (gmapQ (everything k f) x)


{-# LANGUAGE ScopedTypeVariables #-}
module Test10255 where

import Data.Maybe

fob (f :: (Maybe t -> Int)) =
  undefined


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

module Test10268 where

th = $footemplate

give :: b -> Pattern '[b] a
give = undefined

pfail :: Pattern '[] a
pfail = undefined


module Test10269 where

(f =*= g) sa i = undefined


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

module Test10276 where

f1 = [| bar |]
f2 = [e| bar |]

class QQExp a b where
  qqExp x = [||fst $ runState $$(qqExpM x)
                        ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]

class QQExp2 a b where
  qqExp x = [e||fst $ runState $$(qqExpM x)
                        ((0,M.empty) :: (Int,M.Map L.Name [L.Operand]))||]


{-# LANGUAGE ScopedTypeVariables,GADTs #-}
module Test10278 where

extremumNewton :: forall tag. forall tag1. tag -> tag1 -> Int
extremumNewton = undefined

extremumNewton1 :: (Eq a, Fractional a) =>
                  (forall tag. forall tag1.
                          Tower tag1 (Tower tag a)
                              -> Tower tag1 (Tower tag a))
                      -> a -> [a]
extremumNewton1 f x0 = zeroNewton (diffUU f) x0

data MaybeDefault v where
    SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
    SetTo2:: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
    SetTo3 :: (Eq a) => forall v . ( Eq v, Show v ) => !v -> a -> MaybeDefault v
    {-
    SetTo4 :: forall v . (( Eq v, Show v ) => v -> MaybeDefault v -> a -> [a])
    -}


{-# LANGUAGE TupleSections #-}
module Test10280 where

foo2 = atomicModifyIORef ciTokens ((,()) . f)


{-# LANGUAGE TypeFamilies #-}
module Test10307 where

class Foldable t where
  type FoldableConstraint t x :: *
  type FoldableConstraint t x = ()


{-# LANGUAGE GADTs #-}
module Test10309 where

data H1 a b where
  C3 :: (Num a) => { field :: a -- ^ hello docs
                   } -> H1 Int Int


{-# LANGUAGE ParallelListComp,
             TransformListComp,
             RecordWildCards #-}
module Test10312 where
-- From
-- https://ocharles.org.uk/blog/guest-posts/2014-12-07-list-comprehensions.html

import GHC.Exts
import qualified Data.Map as M
import Data.Ord (comparing)
import Data.List (sortBy)

-- Letâ€™s look at a simple, normal list comprehension to start:

regularListComp :: [Int]
regularListComp = [ x + y * z
                  | x <- [0..10]
                  , y <- [10..20]
                  , z <- [20..30]
                  ]

parallelListComp :: [Int]
parallelListComp = [ x + y * z
                   | x <- [0..10]
                   | y <- [10..20]
                   | z <- [20..30]
                   ]

-- fibs :: [Int]
-- fibs = 0 : 1 : zipWith (+) fibs (tail fibs)

fibs :: [Int]
fibs = 0 : 1 : [ x + y
               | x <- fibs
               | y <- tail fibs
               ]

fiblikes :: [Int]
fiblikes = 0 : 1 : [ x + y + z
                   | x <- fibs
                   | y <- tail fibs
                   | z <- tail (tail fibs)
                   ]

-- TransformListComp
data Character = Character
  { firstName :: String
  , lastName :: String
  , birthYear :: Int
  } deriving (Show, Eq)

friends :: [Character]
friends = [ Character "Phoebe" "Buffay" 1963
          , Character "Chandler" "Bing" 1969
          , Character "Rachel" "Green" 1969
          , Character "Joey" "Tribbiani" 1967
          , Character "Monica" "Geller" 1964
          , Character "Ross" "Geller" 1966
          ]

oldest :: Int -> [Character] -> [String]
oldest k tbl = [ firstName ++ " " ++ lastName
               | Character{..} <- tbl
               , then sortWith by birthYear
               , then take k
               ]

groupByLargest :: Ord b => (a -> b) -> [a] -> [[a]]
groupByLargest f = sortBy (comparing (negate . length)) . groupWith f

bestBirthYears :: [Character] -> [(Int, [String])]
bestBirthYears tbl = [ (the birthYear, firstName)
                     | Character{..} <- tbl
                     , then group by birthYear using groupByLargest
                     ]

uniq_fs = [ (n, the p, the d') | (n, Fixity p d) <- fs
                                   , let d' = ppDir d
                                   , then group by Down (p,d') using groupWith ]


{-# LANGUAGE PackageImports #-}
{-# LANGUAGE MagicHash, UnliftedFFITypes #-}
{-# LANGUAGE ForeignFunctionInterface #-}

module Test10313 where

import "b\x61se" Data.List

{-# WARNING Logic
          , solverCheckAndGetModel
          "New Z3 API support is still incomplete and fragile: \
          \you may experience segmentation faults!"
  #-}

{-# Deprecated Logic
          , solverCheckAndGetModel
          "Deprecation: \
          \you may experience segmentation faults!"
  #-}

data {-# Ctype "foo\x63" "b\x61r" #-} Logic = Logic

-- Should warn
foo1 x = x
{-# RULES "foo1\x67" [ 1] forall x. foo1 x = x #-}

foreign import prim unsafe "a\x62" a :: IO Int

{-# INLINE strictStream #-}
strictStream (Bitstream l v)
    = {-# CORE "Strict Bitstream stre\x61m" #-}
      S.concatMap stream (GV.stream v)
      `S.sized`
      Exact l

b = {-# SCC "foo\x64"   #-} 006

c = {-# GENERATED "foob\x61r" 1 : 2  -  3 :   4 #-} 0.00


{-# LANGUAGE PartialTypeSignatures #-}
module Test10354 where

f :: ((Eq a, _)) => a -> a -> Bool
f x y = x == y

bar :: (   ) => a-> Bool
bar = undefined

baz :: _ => a -> String
baz = undefined

foo :: ForceError
foo = undefined


{-# LANGUAGE ParallelListComp #-}
module Test10357 where

legendres = one : x :
    [ multPoly
        (poly LE [recip (n' + 1)])
        (addPoly (poly LE [0, 2 * n' + 1] `multPoly` p_n)
                 (poly LE           [-n'] `multPoly` p_nm1)
        )
    | n     <- [1..], let n' = fromInteger n
    | p_n   <- tail legendres
    | p_nm1 <- legendres
    ]


{-# LANGUAGE BangPatterns #-}
module Test10358 where

mtGamma x v d =
  let !x_2 = x*x; !x_4 = x_2*x_2
      v3 = v*v*v
      dv = d * v3
  in 5


{-# LANGUAGE ScopedTypeVariables #-}
module Test10396 where

errors :: IO ()
errors= do
  let ls :: Int = undefined
  return ()


{-# LANGUAGE ImplicitParams #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
module Test10399 where

type MPI = ?mpi_secret :: MPISecret

mkPoli = mkBila . map ((,,(),,()) <$> P.base <*> P.pos <*> P.form)

data MaybeDefault v where
    SetTo :: forall v . ( Eq v, Show v ) => !v -> MaybeDefault v
    SetTo4 :: forall v a. (( Eq v, Show v ) => v -> MaybeDefault v
                                            -> a -> MaybeDefault [a])
    TestParens :: (forall v . (Eq v) -> MaybeDefault v)

[t| Map.Map T.Text $tc |]

bar $( [p| x |] ) = x


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE StandaloneDeriving #-}
module Test10598 where

class C a where
  c :: proxy a -> Int
  c _ = 42

instance C Int where
  c _ = 27

newtype Foo = MkFoo Int
  deriving          Eq
  deriving stock    Ord
  deriving anyclass C
deriving newtype instance Show Foo


{-# LANGUAGE TypeOperators
           , DataKinds
           , PolyKinds
           , TypeFamilies
           , GADTs
           , UndecidableInstances
           , RankNTypes
           , ScopedTypeVariables
  #-}
module Test11321 where

data instance Sing (z :: [a])
  = z ~ '[] =>
    SNil
  | forall (m :: a)
           (n :: [a]). z ~ (:) m n =>
    SCons (Sing m) (Sing n)


{-# LANGUAGE PatternSynonyms #-}

module Test11332 ( A(.., NoA), Q(F,..), G(T,..,U)) where

data A = A | B

pattern NoA = B

data Q a = Q a

pattern F a = Q a

data G = G | H

pattern T = G

pattern U = H


module Test11430 where

infixl 0x1 `f`

x `f` y = x

{-# SPECIALISE [~ 001] x ::
        Integer -> Integer -> Integer,
        Integer -> Int -> Integer,
        Int -> Int -> Int #-}
{-# INLINABLE [1] x #-}
x :: (Num a, Integral b) => a -> b -> a
x = undefined

{-# SPECIALISE INLINE [0x999] y ::
        Integer -> Integer -> Integer,
        Integer -> Int -> Integer,
        Int -> Int -> Int #-}
{-# INLINABLE [1] y #-}
y :: (Num a, Integral b) => a -> b -> a
y = undefined

c = {-# GENERATED "foob\x61r" 0x1 : 0x2  -  0x3 :   0x4 #-} 0.00


{-# LANGUAGE UnboxedSums, MagicHash #-}

module Test12417 where

import GHC.Prim
import GHC.Types

import System.Mem (performMajorGC)

type Either1 a b = (# a | b #)

showEither1 :: (Show a, Show b) => Either1 a b -> String
showEither1 (# left | #)  = "Left " ++ show left
showEither1 (# | right #) = "Right " ++ show right

type T = (# Int | Bool | String | Char | Either Int Bool | Int# | Float# #)

showEither4 :: T -> String
showEither4 (# | b | | | | | #) = "Alt1: " ++ show b


{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ExplicitNamespaces #-}
module T13163
  ( Record(..)
  , type (?)(..)
  , f, type (+), pattern Single
  ) where

import Data.Promotion.Prelude (type (:+$), type (:*$), type (:^$), type (:-$))
import Options.Generic (Generic, ParseRecord, type (<?>)(..))
import GHC.TypeLits

pattern Single x = [x]

f = undefined


{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE TypeOperators          #-}

(~#) :: Comonad w => CascadeW w (t ': ts) -> w t -> Last (t ': ts)
(~#) = cascadeW
infixr 0 ~#


module Test16212 where

class LiftingMonad  (trans :: MTrans) where
  proof :: Monad m :- Monad (trans m)

class LiftingMonad2  ((trans :: MTrans)) where
  proof :: Monad m :- Monad (trans m)

data Nat (t :: NatKind) where
    ZeroNat :: Nat Zero
    SuccNat :: Nat t -> Nat (Succ t)

data Foo (a) b = Foo { av :: a, bv :: b }


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DataKinds #-}
module MoreExplicitForalls where

import Data.Proxy

data family F1 a
data instance forall (x :: Bool). F1 (Proxy x) = MkF

class C a where
  type F2 a b

instance forall a. C [a] where
  type forall b. F2 [a] b = Int

type family G a b where
  forall x y. G [x] (Proxy y) = Double
  forall z.   G z   z         = Bool


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

module DumpParsedAst where
import Data.Kind

data Peano = Zero | Succ Peano

type family Length (as :: [k]) :: Peano where
  Length (a : as) = Succ (Length as)
  Length '[]      = Zero

-- vis kind app
data T f (a :: k) = MkT (f a)

type family F1 (a :: k) (f :: k -> Type) :: Type where
  F1 @Peano a f = T @Peano f a

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


{-# LANGUAGE AlternativeLayoutRule #-}
{-# LANGUAGE LambdaCase            #-}
-- duplicate of T13087.hs

isOne :: Int -> Bool
isOne = \case 1 -> True
              _ -> False

main = return ()


module TestBoolFormula where

class ManyOps a where
    aOp :: a -> a -> Bool
    aOp = undefined
    bOp :: a -> a -> Bool
    bOp = undefined
    cOp :: a -> a -> Bool
    cOp = undefined
    dOp :: a -> a -> Bool
    dOp = undefined
    eOp :: a -> a -> Bool
    eOp = undefined
    fOp :: a -> a -> Bool
    fOp = undefined
    {-# MINIMAL  ( aOp)
               | ( bOp   , cOp)
               | ((dOp  |  eOp) , fOp)
      #-}

class Foo a where
    bar :: a -> a -> Bool
    foo :: a -> a -> Bool
    baq :: a -> a -> Bool
    baq = undefined
    baz :: a -> a -> Bool
    baz = undefined
    quux :: a -> a -> Bool
    quux = undefined
    {-# MINIMAL bar, (foo, baq | foo, quux) #-}

instance Foo Int where
    bar = undefined
    baz = undefined
    quux = undefined
    foo = undefined


-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

-- import Data.Generics
import Data.Data
import Data.List
import System.IO
import GHC
import DynFlags
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir] <- getArgs
        testOneFile libdir "LiteralsTest"

testOneFile libdir fileName = do
    t <- runGhc (Just libdir) $ do
        dflags <- getSessionDynFlags
        setSessionDynFlags dflags
        let mn =mkModuleName fileName
        addTarget Target { targetId = TargetModule mn
                         , targetAllowObjCode = True
                         , targetContents = Nothing }
        load LoadAllTargets
        modSum <- getModSummary mn
        toks <- getRichTokenStream (ms_mod modSum)
        return toks

    putStrLn (intercalate "\n" [showToks t])

showToks ts = intercalate ",\n\n"
            $ map (\((L p t),s) ->
                         "(" ++ pp p ++ "," ++ show t ++ ",[" ++ s ++ "])") ts

pp a = showPpr unsafeGlobalDynFlags a


{-# LANGUAGE MagicHash #-}
module LiteralsTest where

x,y :: Int
x = 0003
y = 0x04

s :: String
s = "\x20"

c :: Char
c = '\x20'

d :: Double
d = 0.00

blah = x
  where
    charH = '\x41'#
    intH = 0004#
    wordH = 005##
    floatH = 3.20#
    doubleH = 04.16##
    x = 1


{-# LANGUAGE MagicHash #-}
module LiteralsTest2 where

x,y :: Int
x = 0003
y = 0x04

s :: String
s = "\x20"

c :: Char
c = '\x20'

d :: Double
d = 0.00

blah = x
  where
    charH = '\x41'#
    intH = 0004#
    wordH = 005##
    floatH = 3.20#
    doubleH = 04.16##
    x = 1


{-# LANGUAGE RankNTypes #-}
-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

import BasicTypes
import Data.Data
import Data.List
import System.IO
import GHC
import DynFlags
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )
import qualified Data.Map as Map
import Data.Dynamic ( fromDynamic,Dynamic )

main::IO()
main = do
        [libdir] <- getArgs
        testOneFile libdir "LiteralsTest2"

testOneFile libdir fileName = do
    p <- runGhc (Just libdir) $ do
        dflags <- getSessionDynFlags
        setSessionDynFlags dflags
        let mn =mkModuleName fileName
        addTarget Target { targetId = TargetModule mn
                         , targetAllowObjCode = True
                         , targetContents = Nothing }
        load LoadAllTargets
        modSum <- getModSummary mn
        p <- GHC.parseModule modSum
        return p

    let res = gq (pm_parsed_source p)
    putStrLn (intercalate "\n" res)

    where
     gq ast = everything (++) ([] `mkQ` doHsLit `extQ` doOverLit) ast

     doHsLit :: HsLit GhcPs -> [String]
     doHsLit (HsChar       (SourceText src) c)
       = ["HsChar [" ++ src ++ "] " ++ show c]
     doHsLit (HsCharPrim   (SourceText src) c)
       = ["HsCharPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsString     (SourceText src) c)
       = ["HsString [" ++ src ++ "] " ++ show c]
     doHsLit (HsStringPrim (SourceText src) c)
       = ["HsStringPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsInt  _     (IL (SourceText src) _ c))
       = ["HsInt [" ++ src ++ "] " ++ show c]
     doHsLit (HsIntPrim (SourceText src) c)
       = ["HsIntPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsWordPrim   (SourceText src) c)
       = ["HsWordPrim [" ++ src ++ "] " ++ show c]
     doHsLit (HsInt64Prim  (SourceText src) c)
       = ["HsInt64Prim [" ++ src ++ "] " ++ show c]
     doHsLit (HsWord64Prim (SourceText src) c)
       = ["HsWord64Prim [" ++ src ++ "] " ++ show c]
     doHsLit (HsInteger  (SourceText src) c _)
       = ["HsInteger [" ++ src ++ "] " ++ show c]
     doHsLit _ = []

     doOverLit :: OverLitVal -> [String]
     doOverLit (HsIntegral  (IL (SourceText src) _ c))
       = ["HsIntegral [" ++ src ++ "] " ++ show c]
     doOverLit (HsIsString  (SourceText src) c)
       = ["HsIsString [" ++ src ++ "] " ++ show c]
     doOverLit _ = []

pp a = showPpr unsafeGlobalDynFlags a

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

-- Copied from syb for the test

-- | Generic queries of type \"r\",
--   i.e., take any \"a\" and return an \"r\"
--
type GenericQ r = forall a. Data a => a -> r

-- | Make a generic query;
--   start from a type-specific case;
--   return a constant otherwise
--
mkQ :: ( Typeable a
       , Typeable b
       )
    => r
    -> (b -> r)
    -> a
    -> r
(r `mkQ` br) a = case cast a of
                        Just b  -> br b
                        Nothing -> r

-- | Extend a generic query by a type-specific case
extQ :: ( Typeable a
        , Typeable b
        )
     => (a -> q)
     -> (b -> q)
     -> a
     -> q
extQ f g a = maybe (f a) g (cast a)

-- | Summarise all nodes in top-down, left-to-right order
everything :: (r -> r -> r) -> GenericQ r -> GenericQ r

-- Apply f to x to summarise top-level node;
-- use gmapQ to recurse into immediate subterms;
-- use ordinary foldl to reduce list of intermediate results

everything k f x = foldl k (f x) (gmapQ (everything k f) x)


{-# OPTIONS_GHC -Wall #-}
module A where

import B
import System.IO

main = do
    print answer_to_live_the_universe_and_everything
    hFlush stdout


{-# OPTIONS_GHC -Wall #-}
module B where

answer_to_live_the_universe_and_everything =
    length [1..23*2] - 4


-- 1. Load a set of modules with "nothing" target
-- 2. Load it again with "interpreted" target
-- 3. Execute some code
--    a. If the recompilation checker is buggy this will die due to missing
--       code
--    b. If it's correct, it will recompile because the target has changed.
--
-- This program must be called with GHC's libdir as the single command line
-- argument.
module Main where

import GHC
import DynFlags
import MonadUtils ( MonadIO(..) )
import BasicTypes ( failed )
import Bag        ( bagToList )
import System.Environment
import Control.Monad
import System.IO

main = do
  libdir : args <- getArgs
  runGhc (Just libdir) $ do
    dflags0 <- getSessionDynFlags
    (dflags, _, _) <- parseDynamicFlags dflags0
      (map (mkGeneralLocated "on the commandline") args)
    setSessionDynFlags $ dflags { hscTarget = HscNothing
                                , ghcLink  = LinkInMemory
                                , verbosity = 0 -- silence please
                                }
    root_mod <- guessTarget "A.hs" Nothing
    setTargets [root_mod]
    ok <- load LoadAllTargets
    when (failed ok) $ error "Couldn't load A.hs in nothing mode"
    prn "target nothing: ok"

    dflags <- getSessionDynFlags
    setSessionDynFlags $ dflags { hscTarget = HscInterpreted }
    ok <- load LoadAllTargets
    when (failed ok) $ error "Couldn't load A.hs in interpreted mode"
    prn "target interpreted: ok"

    -- set context to module "A"
    mg <- getModuleGraph
    let [mod] = [ ms_mod_name m
                | m <- mgModSummaries mg
                , moduleNameString (ms_mod_name m) == "A" ]
    setContext [IIModule mod]
    liftIO $ hFlush stdout  -- make sure things above are printed before
                            -- interactive output
    r <- execStmt "main" execOptions
    case r of
      ExecComplete { execResult = Right _ } -> prn "ok"
      ExecComplete { execResult = Left _ } -> prn "exception"
      ExecBreak{} -> prn "breakpoint"
    liftIO $ hFlush stdout
    return ()

prn :: MonadIO m => String -> m ()
prn = liftIO . putStrLn


module Main where

import GHC
import MonadUtils

import System.Environment

main :: IO ()
main = do [libdir] <- getArgs
          runGhc (Just libdir) doit

doit :: Ghc ()
doit = do
  getSessionDynFlags >>= setSessionDynFlags
  dyn <- dynCompileExpr "()"
  liftIO $ print dyn


module Main where

import Data.Data
import System.IO
import GHC
import FastString
import SrcLoc
import MonadUtils
import Outputable
import Bag (filterBag,isEmptyBag)
import System.Directory (removeFile)
import System.Environment( getArgs )

main::IO()
main = do
  let
    loc1 = mkSrcLoc (mkFastString "filename") 1 3
    loc2 = mkSrcLoc (mkFastString "filename") 1 5
    loc3 = mkSrcLoc (mkFastString "filename") 10 1
    badLoc = mkGeneralSrcLoc (mkFastString "bad loc")

    pointSpan = mkSrcSpan loc1 loc1
    lineSpan  = mkSrcSpan loc1 loc2
    multiSpan = mkSrcSpan loc2 loc3
    badSpan  = mkGeneralSrcSpan (mkFastString "bad span")

  print $ show loc1
  print $ show loc2
  print $ show badLoc
  print $ show pointSpan
  print $ show lineSpan
  print $ show multiSpan
  print $ show badSpan


main = let (x :: String) = "hello" in putStrLn x


{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -Wall #-}
module Main where

import System.Environment
import GHC

main :: IO ()
main = do
    flags <- getArgs
    runGhc' flags $ do
      setTargets [Target (TargetFile "T10052-input.hs" Nothing) True Nothing]
      _success <- load LoadAllTargets
      return ()

runGhc' :: [String] -> Ghc a -> IO a
runGhc' args act = do
    let libdir = head args
        flags  = map noLoc (tail args)
    runGhc (Just libdir) $ do
      dflags0 <- getSessionDynFlags
      (dflags1, _leftover, _warns) <- parseDynamicFlags dflags0 flags
      let dflags2 = dflags1 {
              hscTarget = HscInterpreted
            , ghcLink   = LinkInMemory
            , verbosity = 1
            }
      _newPkgs <- setSessionDynFlags dflags2
      act