{-# OPTIONS_NO_SUCH_PRAGMA --no-such-flag #-}

-- We should parse the above as an unrecognised pragma, not as an OPTIONS
-- pragma containing "_NO_SUCH_PRAGMA -wibble". Trac #2847.

module Test where


{-# OPTIONS_HUGS --some-hugs-flag #-}

-- We should ignore the above pragma, as we recognise that it is
-- hugs-specific. We shouldn't even warn about it.

module Test where


-- Test for trac #3079 - parsing fails if a LANGUAGE pragma straddles
-- a 1024 byte boundary.
-- xxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
-- xxxxxxxxxxxxxxxxxxxxxxx
-- xxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
--
--xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx

{-# LANGUAGE NoImplicitPrelude #-}

import Prelude

main :: IO ()
main = return ()


{-# LANGUAGE RelaxedLayout #-}

module ShouldFail where

f x = case x of
         False -> do
    { return x; }


-- Trac #1821

module Par where

f x = x
  where
-- ######### x86_64 machine code:
    g y = y
    h y = y


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

module T10188 where

data Peano = Zero | Succ Peano

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

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


module T10196 where

data X = Xáµ¦ | Xáµ¤ | Xáµ© | Xáµ¢ | Xáµª | Xáµ£

f :: Int
f =
  let xáµ¦ = 1
      xáµ¤ = xáµ¦
      xáµ© = xáµ¤
      xáµ¢ = xáµ©
      xáµª = xáµ¢
      xáµ£ = xáµª
  in xáµ£

-- Modifier letters are also allowed in the middle of an identifier.
-- This should not be lexed as 2 separate identifiers.
xáµ¦x :: Int
xáµ¦x = 1


{-# LANGUAGE KindSignatures, GADTs, DataKinds #-}
{-# OPTIONS -Wno-star-is-type #-}
module Foo where

data Foo1 :: [*] -> * where

-- ghc <= 7.10 reported (before "Add kind equalities to GHC"):
--
--     T10379.hs:9:16: parse error on input â€˜]â€™
data Foo2 :: ([] *) -> * where


{-# LANGUAGE Arrows #-}

module T10582 where

(|:) :: Int -> Int -> Int
(|:) = (+)


module T10855 where

bool :: Int
bool = - case 3 > 5 of False -> 0; True -> (-1)
main = print (- do 4)


{-# LANGUAGE TypeFamilies #-}
module T11622 where

import Data.Kind (Type)

type family F a where
  F _ = Int :: Type


{-# Language DataKinds             #-}
{-# Language TypeApplications         #-}
{-# Language PolyKinds             #-}

module T12045e where

import Data.Kind

data Nat = Zero | Succ Nat
data T (n :: k) = MkT
data D1 n = T @Nat n :! ()
data D2 n = () :!! T @Nat n
data D3 n = T @Nat n :!!! T @Nat n


{-# LANGUAGE AlternativeLayoutRule #-}
{-# LANGUAGE LambdaCase            #-}

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

main = return ()


module T13600a where

f ! x = f !! x

x = [1,2,3] ! 1
  where
    f ! x = f !! x


module T13600b where

f !(Just x) = f !! x
f !y = head f

x = [1,2,3] ! Just 1
  where
    f !(Just x) = f !! x
    f !y = head f


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE GADTs #-}

module T13747 where

import Data.Kind (Type)

class C a where
  type family TC a :: Type

class D a where
  data family TD a :: Type

instance C Int where
  type instance TC Int = Int

instance D Double where
  data instance TD Double = TDDouble

instance D Int where
  newtype instance TD Int = TDInt Int

instance D Char where
    data instance TD Char where
        C1 :: TD Char
        C2 :: TD Char


module T14189
  (
  MyType (f,NT)
  ) where

data MyType = MT Int | NT | F { f :: Int }


{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE TypeOperators #-}
module T15139 where

import Data.Type.Equality

can'tHappen :: Int :~: Bool
can'tHappen = undefined

f1, f2, g :: Bool -> Bool
f1 True = case can'tHappen of {}
f2 True = case can'tHappen of
g  True = case () of () -> True


{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -ddump-parsed-ast #-}
module T15279 where

foo :: Char -> Char
#include "T15279.hs-incl"
foo _ = 'a'


{-# LANGUAGE GADTs      #-}
{-# LANGUAGE RankNTypes #-}
module T15323 where

data MaybeDefault v where
    TestParens  :: (forall v . (Eq v) => MaybeDefault v)


{-# LANGUAGE TypeOperators #-}
module T15457 where

import Data.Type.Equality

data a ! b; infix 0 !
data a + b; infix 9 +

fixityProof :: (Int ! Int + Int) :~: (Int ! (Int + Int))
fixityProof = Refl

data Foo a b = MkFoo (a ! b) !Int !(Bool ! Bool)


{-# LANGUAGE TypeOperators, MultiParamTypeClasses, ExistentialQuantification #-}

module T15675 where

class a + b

data D1 = forall a b. (a + b) => D1 a b
data D2 = forall a b.  a + b  => D2 a b

class a ! b

data D3 = forall a b. (a ! b) => D3 !a !b
data D4 = forall a b.  a ! b  => D4 !a !b


{-# LANGUAGE KindSignatures #-}
module T15781 where

import Data.Kind

type F = Int :: Type


{-# LANGUAGE ExplicitNamespaces, TypeOperators, RoleAnnotations #-}
{-# OPTIONS -Wno-duplicate-exports #-}

module T16339
  (
    type (!),
    type (!)(Bang),
    type (!)(..),
    type (.),
    type (.)(Dot),
    type (.)(..),
  ) where

data a ! b = Bang
data f . g = Dot

type role (!) phantom phantom
type role (.) phantom phantom


default (T)

data T = T deriving (Eq, Ord, Read, Show)
instance Num T
instance Fractional T

main = interact $ show . (< 1e400) . read


module T3303 where

import T3303A

bar :: Int
bar = foo

bar2 :: Int
bar2 = foo2


module T3303A where

{-# DEPRECATED foo
         ["This is a multi-line",
          "deprecation message",
          "for foo"] #-}
foo :: Int
foo = 4

-- Empty list should work too (#11044).
{-# DEPRECATED foo2 [] #-}

foo2 :: Int
foo2 = 4


{-# LANGUAGE DataKinds, PolyKinds, DeriveDataTypeable, StandaloneDeriving, TypeOperators #-}

module T5682 where

import Data.Typeable

data a :+: b = Mk a b
data Foo = Bool :+: Bool

type X = True ':+: False

deriving instance Typeable '(:+:)


main :: IO (){-# LINE 8 "" #-}
main = print "Hi"


module T7776 where

f :: Int -> Int -> Int
f x y = let a ~# b = a + b
        in x ~# y


{-# LANGUAGE GADTs #-}

module T8258 where

data T where


{-# LANGUAGE KindSignatures #-}
module T808 where

import Data.Kind (Type)

foo :: (Int, Int :: Type)
foo = undefined


{-# OPTIONS -fwarn-tabs #-}

-- Check we get a warning for a single tab

module ShouldCompile where

tab1	= 'a'


{-# OPTIONS -fwarn-tabs #-}

-- Check we get a warning for multiple tabs, with the correct number of tabs
-- mentioned

module ShouldCompile where

-- tab in middle of line
tab1	= 'a'
-- tab at end of line
tab2 = 'b'
-- two tabs in middle of line
tab3		= 'c'

tab4 = if True
-- tab at start of line
	then 'd'
-- tab at start of line
	else 'e'

	-- tab before a comment starts


{-# LANGUAGE TypeApplications, RankNTypes, DataKinds, PolyKinds #-}

module VtaParse where

import Data.Proxy

data Foo = Foo { first :: Int, second :: Bool} deriving Show

f :: a -> b -> (a,b)
f u v = (u, v)

g :: Int -> Int -> (Int, Int)
g u v = f @(Int) @Int u v

dblTuple :: (a, b) -> ((a, b), b)
dblTuple e@(_,y) = (e, y)

-- interesting note:
-- listpair :: forall a. [a] -> ([a], [a])
-- therefore when explicitly applying, you do NOT put the type in "[ ]"

listpair :: [a] -> ([a], [a])
listpair [] = ([], [])
listpair b@(_:_) = (b, b)

-- suggested two cases by R. Eisenberg
newtype N = MkN { unMkN :: forall a. Show a => a -> String }
n = MkN show
foo :: Bool -> String
foo = unMkN n @Bool   -- Fails without parens! Not anymore!

(&&) :: Bool -> Bool -> Bool
(b@True) && True = True
_ && _ = False

(*@&) :: a -> a -> (a, a)
x *@& y = (x, y)

(@&) :: a -> a -> (a, a)
x @& y = (x, y)

main :: IO ()
main = do
         print $ g 5 12
         print $ ((id @String (concat ["hello ", "world ", []])):"Hamidhasan":[])
         print $ dblTuple @(Foo) @String ((Foo 5 True), "hello")
         print $ listpair @(Maybe Int) [Just 12, Nothing]
         print $ listpair @(Maybe Bool) $ (Just True) : (Just False) : (Nothing @Bool) : []
         print $ dblTuple @Foo @[Maybe Int] ((Foo 7 False), ([Just 5, Nothing]))
         print $ 12 @& 5

pro :: Proxy a -> ()
pro _ = ()

x = pro @'True

(@@) :: Int -> Int -> Int
(@@) = (+)

five = 3 @@ 2

silly = pro {- hi! -}@Int


import Control.Applicative
main = (pure 1 >>= print) <**> pure show


module ExportCommaComma (id, reverse,,) where


main = do
  f $ do
    a <- return 3
      c <- do
      return 5


module NoBlockArgumentsFail where

import Control.Monad

foo :: IO ()
foo = when True do
  return ()


module NoBlockArgumentsFail2 where

import Control.Monad

foo :: IO ()
foo = forM [1 .. 10] \x -> print x


{-# LANGUAGE LambdaCase #-}
module NoBlockArgumentsFail3 where

import Control.Monad

foo :: IO ()
foo = forM [1 .. 10] \case
  Just 3 -> print x


{-# LANGUAGE NoDoAndIfThenElse #-}

module NoDoAndIfThenElse where

foo :: IO ()
foo = do if True
         then return ()
         else return ()


{-# LANGUAGE NoNondecreasingIndentation #-}

module ShouldCompile where

f :: IO ()
f = do if True then f else do
       f
       if True then f else do
       f


{-# LANGUAGE NoNumericUnderscores #-}

-- Test for NumericUnderscores extension.
-- See Trac #14473
-- This is a testcase for integer literal
-- in NO NumericUnderscores extension.

module NoNumericUnderscores0 where

f :: Int -> ()
f 1_000 = ()
f _   = ()


{-# LANGUAGE NoNumericUnderscores #-}

-- Test for NumericUnderscores extension.
-- See Trac #14473
-- This is a testcase for floating literal
-- in NO NumericUnderscores extension.

module NoNumericUnderscores1 where

f :: Float -> ()
f 1_000.0_1 = ()
f _   = ()


module NoPatternSynonyms where

pattern P :: G Int


{-# LANGUAGE NumericUnderscores #-}

-- Test for NumericUnderscores extension.
-- See Trac #14473
-- This is a testcase for invalid case of NumericUnderscores.

main :: IO ()
main = do
    print [
            -- integer
            1000000_,
            _1000000
          ]


{-# LANGUAGE NumericUnderscores #-}

-- Test for NumericUnderscores extension.
-- See Trac #14473
-- This is a testcase for invalid case of NumericUnderscores.

main :: IO ()
main = do
    print [
            -- float
            0_.0001,
            _0.0001,
            0.0001_,
            0._0001,

            -- float with exponent
            1e_+23,
            1e+23_,
            1e+_23
          ]


module ParserNoBinaryLiterals1 where

f :: Int -> ()
f 0b0 = ()
f _   = ()


{-# LANGUAGE MagicHash #-}

module ParserNoBinaryLiterals2 where

import GHC.Types

f :: Word -> ()
f (W# 0b0##) = ()
f _          = ()


{-# LANGUAGE MagicHash #-}

module ParserNoBinaryLiterals3 where

import GHC.Types

f :: Int -> ()
f (I# 0b0#) = ()
f _         = ()


{-# LANGUAGE UnicodeSyntax #-}

module ParserNoForallUnicode where

id' :: âˆ€ a . a â†’ a
id' a = a


module ParserNoLambdaCase where

f = \case "1" -> 1


module ParserNoMultiWayIf where

x = 123
y = if | x < 0     -> -1
       | x == 0    -> 0
       | otherwise -> 1


module T where

-- We should get a parse error on column 33
-- Indented with spaces:
foo = 123456                    module


module T where

-- We should get a parse error on column 33
-- Indented with tabs:
foo = 123456			module


-- !!! this module supposedly includes one of each Haskell construct

-- HsImpExp stuff

module OneOfEverything (
        fixn,
        FooData,
        FooDataB(..),
        FooDataC( .. ),
        Tree(Leaf, Branch),
        EqClass(..),
        OrdClass(orda, ordb),
        module OneC ,
        module OneOfEverything
    ) where

import Prelude
import System.IO ( putStr )
import System.Environment hiding ( getArgs )
import Control.Monad

-- HsDecls stuff

infix   6 `fixn`
infixl  7 +#
infixr  8 `fixr`

fixn x y = x
fixl x y = x
fixr x y = x

type Pair a b = (a, b)

data FooData = FooCon Int

data FooDataB = FooConB Double

data Tree a = Leaf a | Branch (Leaf a) (Leaf a)

class (Eq a) => EqClass a where
    eqc :: a -> Char
    eqc x = '?'

class (Ord a) => OrdClass a where
    orda :: a -> Char
    ordb :: a -> Char
    ordc :: a -> Char

instance (Eq a) => EqClass (Tree a) where
    eqc x = 'a'

default (Integer, Rational)

-- HsBinds stuff

singlebind x = x

bindwith :: (OrdClass a, OrdClass b) => a -> b -> b
bindwith a b = b

reca a = recb a
recb a = reca a

(~(a,b,c)) | nullity b  = a
           | nullity c  = a
           | otherwise  = a
           where
            nullity = null

-- HsMatches stuff

mat a b c d | foof a b = d
            | foof a c = d
            | foof b c = d
            where
                foof a b = a == b

-- HsExpr stuff
expr a b c d
  = a
  + (:) a b
  + (a : b)
  + (1 - 'c' - "abc" - 1.293)
  + ( \ x y z -> x ) 42
  + (9 *)
  + (* 8)
  + (case x of
        [] | null x     -> 99
           | otherwise  -> 98
           | True       -> 97
           where
             null x = False
    )
  + [ z | z <- c, isSpace z ]
  + let y = foo
    in  y
  + [1,2,3,4]
  + (4,3,2,1)
  + (4 :: Num a => a)
  + (if 42 == 42.0 then 1 else 4)
  + [1..]
  + [2,4..]
  + [3..5]
  + [4,8..999]

-- HsPat stuff
f _ x 1 1.93 'c' "dog" ~y z@(Foo a b) (c `Bar` d) [1,2] (3,4) = y

-- HsLit stuff -- done above

-- HsTypes stuff
g :: (Num a, Eq b) => Foo a -> [b] -> (a,a,a) -> b
g x y z = head y


module ShouldFail where

-- !!! newlines in strings aren't allowed

f = "
"


-- !!! Irrefutable patterns + guards
module Read003 where
import GHC.List; import Prelude hiding (null)
~(a,b,c) | nullity b    = a
         | nullity c    = a
         | otherwise    = a
         where
            nullity = null


-- !!! string gaps
-- !!!
module Main(main) where

-----------

main = putStr "\

\Some girls give me money\n\

\Some girls buy me clothes\n\

\..."

-----------

main2 = putStr "\
\ \
..."

-----------

main3 = putStr "\

\Some girls give me money\n\
-- and here is a comment
\Some girls buy me clothes\n\

\..."

-----------

main3 = putStr "\
{-
    and here is a nested {- comment -}
-}
\Some girls give me money\n\

\Some girls buy me clothes\n\

\..."


module Tests where

-- this char is forbidden
c = '\&'


-- !!! Using pattern syntax on RHS
module ShouldFail where

f :: Int -> Int
f x = _

g :: Int -> Int
g x = 2 + 2@_


-- !!! Expressions as patterns inside do stmt blocks
module ShouldFail where

f :: Int -> IO Int
f x = do
  (2+2) <- 2
  return x


module ShouldFail where

-- strictness annotations on the argument to a newtype constructor
-- are not allowed.
newtype N a = T ![a]


module ShouldFail where

-- !!! Test for parse error in do/let expression

foo = do let foo = True
             return ()

-- Note the let binding at the end!
-- This gave a pattern-match failure in tcStmts in ghc-4.04proto

h x = x


-- !!! Test line numbers in presence of string gaps.

main = print "a\
             \b\
             \c"

wibble = = -- this is a parse error on line 7


-- !!! test parse errors due to tokens inserted by layout

-- used to report "Parse error on input `'" in 4.04pl0.

main = let
        f = (a,
        g = 1
        in f


module ReadFail013 where

-- !!! unterminated ``
a = ``s``


module Test where

-- should fail; doesn't with happy 1.8.
f = f where b = f
            c = (b


-- !!! Infix decls w/ infix data constructors

module ShouldFail where

infix 6 |-

ps  |-  q:qs   = undefined


module ShouldFail where

-- GHC < 5.01 used to get the line number wrong.
f (f f) = f

g = g


-- !!! test the error message for an unterminated nested comment

{-  <-- this one is unterminated (line 3)

{-
-}

-- EOF


-- !!! cannot close an explicit layout context with a parse error
module ShouldFail where
f = let { x = 42 in x


-- !!! cannot close a layout context with an explicit close brace
module ShouldFail where
f = let x = 42 } in x


module ShouldFail where

-- !!! a parenthesised lhs must have at least one parameter
(a # b) = a


module ShouldFail where

-- !!! Section precedences

-- check that we're not translating out negative literals too early:
-- the following should be an illegal section because prefix '-' has
-- precedence 6:

k = (-3 **)
  where
        (**) = const
        infixl 7 **


module ShouldFail where

-- !!! this is not legal Haskell 98, but GHC parses it
f = f where g = g where
 h = h


module M where

-- This one actually compiled right the way up to GHC 5.04.3

data T String = T String


module ShouldFail where
data T = T{a::Int}
x = T{,a=42}


{-# LANGUAGE NoRelaxedLayout #-}

module ShouldFail where

-- Erroneously allowed by GHC 6.2.x
f x = case x of
         False -> do
    { return x; }
-- this line should close the 'case' context and cause the 'do' to be empty.

-- Update: arguably this should be allowed.  The fix to the Haskell
-- layout rule to allow it is simple: in Section 9.3 in the rules that
-- govern the introduction of the <n> and {n} pseudo-tokens, we need
-- to prevent <n> being inserted before {.  This could be a simple
-- side-condition on the rule that introduces <n>.


module ShouldFail where

-- !!! do must end in an expression
main = do x <- return ()


{-# LANGUAGE ExtensibleRecords, RestrictedTypeSynonyms, HereDocuments, NamedFieldPuns #-}


module ShouldFail where

class Foo o where
  (:+) :: o -> o -> o


-- Test for trac #314

{-
/*
  This
  uses
  up
  some
  lines
  The
  following
  pragmas
  should
  not
  be
  parsed
 */
# 23
#pragma

-}

module ShouldFail where

type_error = "Type error on line 25":"Type error on line 25"


-- TAB character in a string literal is disallowed:
x = "	"


{-# LANGUAGE Haskell98 #-}

module Foo where

data Foo


module Foo where

import Data.Kind (Type)

data Foo (a :: Type) = Foo a


module Foo where

foo = [ ()
      | () <- foo
      | () <- foo
      ]


module Foo where

class C a
instance C Int

newtype Foo = Foo Int
    deriving C


module Foo where

import Control.Monad.Fix

z :: Maybe [Int]
z = mdo x <- return (1:x)
        return (take 4 x)


{-# OPTIONS_GHC -XMultiParamTypeClasses #-}

module Foo where

class Foo a b | a -> b


-- Check error message for transforms if we don't have the right extension turned on

module Foo where

import Data.List
import GHC.Exts

foo = [ ()
      | x <- [1..10]
      , then take 5
      , then sortWith by x
      ]


-- Check error message for groups if we don't have the right extension turned on

module Foo where

import Data.List
import GHC.Exts

foo = [ ()
      | x <- [1..10]
      , then group by x using groupWith
      , then group by x using groupWith
      , then group using inits
      ]


-- We should get an error message, including a location, for these flags:
{-# OPTIONS_GHC -this-flag-does-not-exist -nor-does-this-one #-}

module Foo where

foo :: ()
foo = ()


{-# LANGUAGE ExistientialQuantification #-}
-- tests for mis-spelled LANGUAGE pragma error message

module ShouldFail where


module ShouldFail where

foo = let
    x = (1, 2
    y = 3
  in
  fst x + y


-- Test for trac #314

{-|
/*
  This
  uses
  up
  some
  lines
  The
  following
  pragmas
  should
  not
  be
  parsed
 */
# 23
#pragma

-}

module ShouldFail where

type_error = "Type error on line 25":"Type error on line 25"


{-# LANGUAGE NoTraditionalRecordSyntax #-}

module ReadFailTraditionalRecords1 where

data Foo = Foo { i :: Int }


{-# LANGUAGE NoTraditionalRecordSyntax #-}

module ReadFailTraditionalRecords2 where

f (Foo { i = j }) = j


{-# LANGUAGE NoTraditionalRecordSyntax #-}

module ReadFailTraditionalRecords3 where

f x = x { i = 3 }


type T = MkT { a :: Int + {-# UNPACK #-} }


module T10196Fail1 where

-- Constructors are not allowed to start with a modifier letter.
data Foo = áµ¦foo


module T10196Fail2 where

-- Variables are not allowed to start with a modifier letter.
áµ¦ = 1


{-# LANGUAGE LambdaCase #-}
module T10498a where

-- ghc-7.10 would show the unhelpful error message:
--
-- T10498a.hs:10:5:
--     parse error in if statement: missing required else clause

foo =
    if True
    then
        \case ->
            1 -> 2
    else id


module T10498b where

-- ghc-7.10 would show the unhelpful error message:
--
-- T10498b.hs:7:5: parse error in if statement: naked if statement

f = if module then True else False


{-# Language DataKinds             #-}
{-# Language TypeApplications         #-}
{-# Language PolyKinds             #-}

module Bug where

import Data.Kind

data Nat = Zero | Succ Nat

data D n = MkD @Nat Bool


module X where
  import Data.Text (pattern Y)
  x = 3


{-# OPTIONS -fwarn-tabs #-}
module T12610 where

p = let  x = 4
	y = 5
    in 12


{-# LANGUAGE RankNTypes #-}
module Bug where

foo :: foral a. a -> a
foo x = x


{-# LANGUAGE MagicHash #-}

module T13260 where

  g y = case y of
    "a"# -> True
    _    -> False


#!/usr/bin/env runhaskell
> module T13414 where
> main = invalid_ident_


module T13450 where

example = foo
  where foo = ''


{-# LANGUAGE TemplateHaskell #-}

module T13450TH where

example = foo
  where foo = ''


module T14588 where

main = print (let !x = 1 + 2 in x)


{-# LANGUAGE UnboxedTuples #-}

module T14740 where

x :: ((##)) => ()
x = ()


{-# LANGUAGE GADTs, TypeOperators #-}
module T15209 where

import GHC.Prim

foo :: a ~# Int -> ()
foo = ()


module T15233 where

-- ghc-8.6 would accept (but silently ignore) both of the following:
infixl 7 :
{-# DEPRECATED (:) "Deprecting cons" #-}

-- this was never accepted by ghc-8.6, but now that GHC.Prim emits a fixity
-- declaration for `(->)`, we need to make sure it is disallowed elsewhere.
infixr 4 ->


module T15849 where

main = return ()
 foo = return ()


{-# LANGUAGE NoTraditionalRecordSyntax, NoDoAndIfThenElse, NoMultiWayIf, NoLambdaCase, NoNumericUnderscores, MagicHash #-}
{-# OPTIONS -Werror=missing-space-after-bang #-}

module T16270 where

c = do
	if c then
		False
	else
		True

f = id do { 1 }
g = id \x -> x

data Num a => D a

data Pair a b = Pair { fst :: a, snd :: b }
t = p { fst = 1, snd = True }

z :: forall a. ()
z = if True; then (); else ();

data G a where

multiWayIf !i = (a, b)
  where
    a = if | i -> True
           | otherwise -> False
    b = if | i -> False
           | otherwise -> True

w = \case _ : _ -> True
          _     -> False

n = 123_456

s = "hello Ï‰orld"#   -- note the omega

-- a fatal error.
k = let

-- not reported, as the previous one was fatal.
k = let


-- We can't test module header parsing errors using the same file as other
-- parsing errors (in ../T16270.hs) because HeaderInfo.getImports fails fast
-- on parsing imports:
--
--      if errorsFound dflags ms
--        then throwIO $ mkSrcErr errs
--
module T16270h (type G) where

import "pkg?" M
import "pkg!" M

data G a


{-# LANGUAGE KindSignatures #-}
-- Trac #3095
module T3095 where

import Data.Kind (Type)

class Bla (forall x . x :: Type) where


module T3811 where

f x :: Char
f x = 'c'


module T3811c where

data D = D

instance !Show D


module T3811d where

data D a = D a

class C b (D Char) b


{-# LANGUAGE NoDatatypeContexts #-}

module T3811e where

data (Show a, Read a) => D a = D a


module T3811g where

f :: IO ()
f = do _ <- return ()
       _ <- return ()


-- load into ghci

"Î»a: (Type[0] â†’ (Type[0] â†’ Type[0])).\
 Î»b: (Type[0] â†’ Type[0]). Î»c: Type[0].\
   ((a c)(b c))"


module T7848 where

data A = (:&&) Int Int | A Int Int

x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h) = y
  where infixl 3 `y`
        y _ = (&)
        {-# INLINE (&) #-}
        {-# SPECIALIZE (&) :: a #-}
        (&) = 'c'


This should not compile:

\end{code}

> module T8430 where
> main = putStr "a"


module Test where

foo :: IO ()
foo = do
  rec str <- return "foo"
  putStrLn str

-- Should fail
-- foo' :: IO ()
-- foo' = do
--   rec {str <- return "foo" ;
--   putStrLn str}
--   return ()

-- Should fail
-- foo'' :: IO ()
-- foo'' = do
--   rec putStrLn "test"
--   str <- return "foo"
--   putStrLn str
--   return ()

-- Should compile
-- foo'''' :: IO ()
-- foo'''' = do
--   rec <- return "foo"
--   putStrLn "test"


module Test where

bar :: IO ()
bar = mdo
    str <- return "bar"
    putStrLn str

-- Should fail
-- bar' :: IO ()
-- bar' = mdo {str <- return "bar" ; putStrLn str}


module Test where

baz :: IO ()
baz = mdo
    putStrLn "baz"

-- Should fail
-- baz' :: IO ()
-- baz' = mdo
--     putStrLn "baz"
--     str <- return "test"

-- Should fail (and needs better error)
-- baz' :: IO ()
-- baz' = mdo {putStrLn "baz"}


module T8506 where

class Shapable Int where


module T9225 where
-- Should be a parse error:
-- version numbers not allowed in package qualified imports
import "some-package-0.1.2.3" Some.Module


module T984 where

f _ = do
        x <- computation
        case () of
                _ ->
                        result <- computation
                        case () of () -> undefined


{-# LANGUAGE TypeOperators #-}

module UnpackBeforeOperator where

data a + b
data T = T { t :: {-# UNPACK #-} + Int }


module UnpackEmptyType where

data T = T { t :: {-# UNPACK #-} }


module UnpackInsideType where

data T = T { t :: Maybe {-# UNPACK #-} Int }


-- | Anti-Test for GHC 7.10+'s @BinaryLiterals@ extensions (see GHC #9224)
--
-- NB: This code won't compile with -XBinaryLiterals enabled

{-# LANGUAGE NegativeLiterals #-}

module Main where

main :: IO ()
main = print lst
  where
    -- "0b0" is to be parsed as "0 b0"
    lst = [ (,) 0b0, (,) 0b1, (,) 0b10, (,) 0b11
          , (,) -0b0, (,) -0b1, (,) -0b10, (,) -0b11
          ] :: [(Int,Int)]
    b0 = 60
    b1 = 61
    b11 = 611
    b10 = 610


{-# Language HexFloatLiterals #-}

import Numeric(showHFloat)

main :: IO ()
main =
  do print [ 0xF.0
           , 0xF.1, 0xF.01
           , 0xF1p-4, 0xF01p-8
           , 0x0.F1p4, 0x0.00F01p12
           ]

     mapM_ putStrLn [ showHFloat (212.21 :: Double) ""
                    , showHFloat (-12.76 :: Float) ""
                    , showHFloat (-0 :: Double) ""
                    ]


-- | Test for @NegativeLiterals@ extension (see GHC #13211)

{-# LANGUAGE NegativeLiterals #-}

floatZero0 = 0 :: Float
floatZero1 = 0.0 :: Float

floatNegZero0 = -0 :: Float
floatNegZero1 = -0.0 :: Float

doubleZero0 = 0 :: Double
doubleZero1 = 0.0 :: Double

doubleNegZero0 = -0 :: Double
doubleNegZero1 = -0.0 :: Double

main = do
    print (isNegativeZero floatZero0)
    print (isNegativeZero floatZero1)
    print (isNegativeZero floatNegZero0)
    print (isNegativeZero floatNegZero1)
    print (isNegativeZero doubleZero0)
    print (isNegativeZero doubleZero1)
    print (isNegativeZero doubleNegZero0)
    print (isNegativeZero doubleNegZero1)


module Main where

data Hash = Hash { (#) :: Int }
  deriving (Show,Read)

main = do
  let h = Hash 3
      s = show h
      x = read s :: Hash
      y = show x
  print h
  putStrLn s
  print x
  putStrLn y
  let h' = Hash { (#) = 3 }
      s' = show h'
      x' = read s' :: Hash
      y' = show x'
  print h'
  putStrLn s'
  print x'
  putStrLn y'


{-# LANGUAGE MultiWayIf #-}

module Main where

x  = 10
x1 = if | x < 10 -> "< 10" | otherwise -> ""
x2 = if | x < 10 -> "< 10"
        | otherwise -> ""
x3 = if | x < 10 -> "< 10"
        | otherwise -> ""
x4 = if | True -> "yes"
x5 = if | True -> if | False -> 1 | True -> 2

x6 = if | x < 10 -> if | True -> "yes"
                       | False -> "no"
        | otherwise -> "maybe"

x7 = (if | True -> 0)

main = print $ x5 == 2 && x6 == "maybe" && x7 == 0


-- !!! Haskell-98 prefix negate operator

-- Make sure the parsing is actually the correct
-- one by running this after it's compiled.

negatedExpression = - (3 + 4)

negatedTightlyBinding = -3^4

negatedNonSection = (- 3)

negatedNonSectionWithHighPrecedenceOp =
  let { f = (+); infix 9 `f` } in ( -3 `f` 4 )

negatedNonSectionWithLowPrecedenceOp =
  let { f = (+); infix 1 `f` } in ( -3 `f` 4 )

negatedRightHandSide =
-- This is actually not legal syntax:  3 * - 4
-- However, lower-precedence binary ops work.
-- (see H98 syntax for exp, or imagine it's because it
--  would parse differently as 3 * 0 - 4)
  let { f = (+); infix 1 `f` } in ( 3 `f` - 4 )

subtractionNotNegation = 3 -4

negativePattern =
    case -3 of { (- 3) ->
    case -4 of { - 4 ->
    True } }
-- not legal H98 syntax:  case -4 of { _x @ -4 ->
-- (parentheses needed)    case -5 of { ~ -5 ->

subtractionNotNegationPattern =
    -- defines infix '-' (shadowing Prelude definition)
    let { 3 -4 = True } in (3 - 4)

precedenceOfNegationCantBeChanged =
    let { (-) = undefined; infix 9 - } in (- 3 * 4)

negationCantBeQualified =
    (Prelude.-3) 4

main = do
  print negatedExpression
  print negatedTightlyBinding
  print negatedNonSection
  print negatedNonSectionWithHighPrecedenceOp
  print negatedNonSectionWithLowPrecedenceOp
  print negatedRightHandSide
  print subtractionNotNegation
  print negativePattern
  print subtractionNotNegationPattern
  print precedenceOfNegationCantBeChanged
  print negationCantBeQualified


{-# LANGUAGE MagicHash #-}
-- !!! Negative unboxed literals, part 1
-- They don't have to be as standards-compliant
-- or follow so many weird cases as the normal
-- boxed version.  In particular, normal unboxed
-- subtraction is -#, `minusFloat#`, -##, `minusInteger#`
-- and unboxed negation is negate{Int,Float,Double}#
-- .  (-) and negate are kind errors.  So we will
-- assume that we don't need to parse infix (-) nicely
-- when unboxed numbers are involved (even though someone
-- "could" hide the Prelude's version and define (-) themself).
-- Also we won't care here whether having a space (- 3#) works.

-- Make sure the parsing is actually the correct
-- one by running this after it's compiled.

import GHC.Exts

--is floating-point consistently safe to test like this,
--if we stick to integral values?
main = do
  --These work with any ghc
  print (I# (negateInt# (-3# -# -4#)))
  print (F# (negateFloat# (-3.0# `minusFloat#` -4.0#)))
  print (D# (negateDouble# (-3.0## -## -4.0##)))
  print (I# (-3# ^# 4#)) --different from (boxed) Haskell98 (-3 ^ 4)
  print ( case -1# of { -1# -> True } )
  print ( case 1# of { -1# -> True; _ -> False } )
  print ( case -0# of { 0# -> True } )

infixr 8  ^#  --just like ^, binds tighter than - (which is infixl 6)
( ^# ) :: Int# -> Int# -> Int#
base ^# 0# = 1#
base ^# exponent = base *# (base ^# ( exponent -# 1# ))


{-# LANGUAGE MagicHash #-}
-- !!! Negative unboxed literals, part 2

import GHC.Exts

main = do
  --Newly implemented: don't parse this as subtraction (Prelude.-):
  print (I# (negateInt# -3#))
  print (F# (negateFloat# -3.0#))
  print (D# (negateDouble# -3.0##))
  --nor this as  let (-) f 1# = ...
  print (let { f -1# = True } in f (-1#))


{-# LANGUAGE UnboxedTuples, MagicHash #-}

-- should_run to make sure linking succeeds
-- (curried unboxed tuples with both boxed
--  and unboxed components).
-- See Trac #1509; also Note [Primop wrappers] in Id.lhs

import GHC.Exts

main = do
  case curried 9.0## 't'# of
    (# i#, u@(), d1#, c1#, f#, w#, d2#, c2# #)
       -> print ( I# i#, u, D# d1#, C# c1#, F# f#, W# w#, D# d2#, C# c2# )
  print $ map_ ((#,#) True) ['a','b','c']

-- try NOINLINE to make sure the currying isn't eliminated
-- too soon, but also test the other one without NOINLINE
-- for variety of testing
{-# NOINLINE curried #-}
curried :: Double# -> Char# ->
   (# Int#, (), Double#, Char#, Float#, Word#, Double#, Char# #)
curried = (#,,,,,,,#) 3# () 4.0## 'f'# 5.0# 32##

map_ :: (a -> (# b, c #)) -> [a] -> [(b,c)]
map_ f [] = []
map_ f (a:as) = case f a of
   (# b, c #) -> (b, c) : map_ f as


{-# LANGUAGE MultiWayIf #-}

module Main where

-- This is how we had to use multi-way if previously. Not indenting lines after
-- `|` was causing a parse error.
f1 x = if | even x
           , x /= 0
           -> True
          | otherwise
           -> False

-- This was previously causing a parse error, but actually it should work.
f2 x = if | even x
          , x /= 0
          -> True
          | otherwise
          -> False

-- If we don't generate {} in MultiWayIf we get a shift/reduce conflict here:
-- It's not clear which guards belong to `case` and which ones belong to `if`.
--
-- This test is to make sure we parse it correctly.
--
-- - If we shift, we get a non-exhaustive pattern error when argument is odd.
-- - If we reduce, we run the unreachable code when argument is odd.
f3 x = case x of
         x' | even x'   -> if | even x' -> 1 | otherwise -> error "should be unreachable"
            | otherwise -> 3

-- Testing line breaks
f4 x = case x of
         x' | even x'   -> if
             | even x' -> 1
             | otherwise -> error "should be unreachable"
            | otherwise -> 3

main :: IO ()
main = do
  print (f3 1)
  print (f3 2)
  print (f4 1)
  print (f4 2)


-- Just new test.  This would work without the bug being fixed.

a = '\x10ffff'
b = "Hello\x000000002c\32World\o00000000000000000000000000000000041"
c = "â™¯\00\&00\0"

main = do print a
          putStrLn b
          print c


{-# LANGUAGE Arrows          #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnicodeSyntax   #-}

-- See Trac #10162 and #11743 for details

module ShouldCompile where

import Control.Arrow
import Language.Haskell.TH

handle :: ArrowPlus a => a (b,s) c -> a (b,(String,s)) c -> a (b,s) c
handle f h = proc (b,s) -> (f -< (b,s)) <+> (h -< (b,("FAIL",s)))

f :: ArrowPlus a => a (Int,Int) String
f = proc (x,y) ->
  â¦‡handle
    (returnA -< show y)
    (\s -> returnA -< s ++ show x)
  â¦ˆ

g :: ArrowPlus a => a (Int,Int) String
g = proc (x,y) ->
  â¦‡handle
    (\msg -> returnA -< msg ++ show y)
    (\s msg -> returnA -< s ++ show x)
  â¦ˆ ("hello " ++ show x)

h :: ArrowPlus a => a (Int,Int) Int
h = proc (x,y) ->
  (
    (\z -> returnA -< x + z)
    <+>
    (\z -> returnA -< y + z)
  ) (x*y)

matches :: PatQ -> ExpQ
matches pat = âŸ¦\x ->
  case x of
    $pat -> True
    _    -> False
  âŸ§


module ShouldCompile where

test = let vâ‚‚ = (+) in vâ‚‚ 1 3


module Main where

import Control.Exception
import Data.Char
import System.IO

import StringBuffer

twoBOMs = "T6016-twoBOMs"

ignoreFirstBOM = do
  -- StringBuffer should not contain initial byte-order mark.
  --
  -- Just skipping over it, but leaving it in the Stringbuffer, is not
  -- sufficient. The Lexer calls prevChar when a regular expression
  -- starts with '^' (which is a shorthand for '\n^'). It would never
  -- match on the first line, since instead of '\n', prevChar would
  -- still return '\xfeff'.
  s <- hGetStringBuffer twoBOMs
  assert (prevChar s '\n' == '\n') return ()

dontIgnoreSecondBOM = do
  -- U+FEFF is considered a BOM only if it appears as the first
  -- character of a file.
  h <- openBinaryFile twoBOMs ReadMode
  hSeek h AbsoluteSeek 3
  s <- hGetStringBufferBlock h 3
  hClose h
  assert (currentChar s == '\xfeff') return ()

main = do
  writeFile twoBOMs "\xfeff\xfeff"
  ignoreFirstBOM
  dontIgnoreSecondBOM


main = print spÄ±nÌˆalTap
    where spÄ±nÌˆalTap = 11

-- nÌˆ is a combining character sequence. We now allow it to be used in
-- identifiers (#7650).
--
-- > map generalCategory "nÌˆ"
-- [LowercaseLetter,NonSpacingMark]
--
-- > map show "nÌˆ"
-- ["'n'","'\776'"]


{-#Â LANGUAGE EmptyDataDecls #-}
-- ^ a U+00A0 no-break space
module Foo where

v = 5 +Â  3
--     ^ a U+00A0 no-break space


-- 0x80 is an invalid character
bad = '€'


-- 0xbf is an invalid character
bad = '¿'


-- A start sequence byte (0xC0) followed by an invalid continuation:
bad = "À."


-- A start sequence byte (0xE0) followed by an invalid continuation:
bad = "à."


-- A start sequence byte (0xE0) followed by an invalid continuation:
bad = "ð."


-- some incomplete sequences concatenated
bad = "Àà€ð€€ø€€€"


{-# LANGUAGE PartialTypeSignatures #-}
module AddAndOr1 where

addAndOr1 :: _
addAndOr1 (a, b) (c, d) = (a `plus` d, b || c)
  where plus :: Int -> Int -> Int
        x `plus` y = x + y


{-# LANGUAGE PartialTypeSignatures #-}
module AddAndOr2 where

addAndOr2 :: _ -> _
addAndOr2 (a, b) (c, d) = (a `plus` d, b || c)
  where plus :: Int -> Int -> Int
        x `plus` y = x + y


{-# LANGUAGE PartialTypeSignatures #-}
module AddAndOr3 where

addAndOr3 :: _ -> _ -> _
addAndOr3 (a, b) (c, d) = (a `plus` d, b || c)
  where plus :: Int -> Int -> Int
        x `plus` y = x + y


{-# LANGUAGE PartialTypeSignatures #-}
module AddAndOr4 where

addAndOr4 :: (_ _ _) -> (_ _ _) -> (_ _ _)
addAndOr4 (a, b) (c, d) = (a `plus` d, b || c)
  where plus :: Int -> Int -> Int
        x `plus` y = x + y


{-# LANGUAGE PartialTypeSignatures #-}
module AddAndOr5 where

addAndOr5 :: (_, _) -> (_, _) -> (_, _)
addAndOr5 (a, b) (c, d) = (a `plus` d, b || c)
  where plus :: Int -> Int -> Int
        x `plus` y = x + y


{-# LANGUAGE PartialTypeSignatures #-}
module AddAndOr6 where

addAndOr6 :: (Int, _) -> (Bool, _) -> (_ Int Bool)
addAndOr6 (a, b) (c, d) = (a `plus` d, b || c)
  where plus :: Int -> Int -> Int
        x `plus` y = x + y


{-# LANGUAGE PartialTypeSignatures #-}
module ADT where

data Foo x y z = Foo x y z

bar :: Int -> _ Int
bar x = Foo True () x


{-# LANGUAGE PartialTypeSignatures #-}
module BoolToBool where

bar :: _ -> _
bar x = not x


{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds #-}
module DataFamilyInstanceLHS where
-- Test case from #10586
data MyKind = A | B

data family Sing (a :: k)

data instance Sing (_ :: MyKind) where
    SingA :: Sing A
    SingB :: Sing B

foo :: Sing A
foo = SingA


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE MonomorphismRestriction #-}
module Defaulting1MROn where

alpha :: _
alpha = 3


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Defaulting2MROff where

bravo :: _ => _
bravo = 3


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE MonomorphismRestriction #-}
module Defaulting2MROn where

bravo :: _ => _
bravo = 3


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module Either where

barry :: _a -> (_b _a, _b _)
barry x = (Left "x", Right x)


{-# LANGUAGE PartialTypeSignatures, TypeFamilies #-}
module EqualityConstraint where

foo :: a ~ Bool => (a, _)
foo = (True, False)


{-# LANGUAGE PartialTypeSignatures #-}
module Every where

every :: _ -> _ -> Bool
every _ [] = True
every p (x:xs) = p x && every p xs


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module EveryNamed where

every :: (_a -> Bool) -> [_a] -> Bool
every _ [] = True
every p (x:xs) = p x && every p xs


{-# LANGUAGE PartialTypeSignatures #-}
module ExpressionSig where

bar :: Bool -> Bool
bar x = (x :: _)


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module ExpressionSigNamed where

bar :: _a -> _a
bar True  = (False :: _a)
bar False = (True :: _a)


{-# LANGUAGE PartialTypeSignatures, RankNTypes #-}

module ExprSigLocal where

-- We expect this to compile fine,
-- reporting that '_' stands 'a'

y :: forall b. b->b
y  = ((\x -> x) :: forall a. a -> _)

g :: forall a. a -> _
g x = x


{-# LANGUAGE PartialTypeSignatures #-}
module ExtraConstraints1 where

arbitCs1 :: _ => a -> String
arbitCs1 x = show (succ x) ++ show (x == x)

arbitCs2 :: (Show a, _) => a -> String
arbitCs2 x = arbitCs1 x

arbitCs3 :: (Show a, Enum a, _) => a -> String
arbitCs3 x = arbitCs1 x

arbitCs4 :: (Eq a, _) => a -> String
arbitCs4 x = arbitCs1 x

arbitCs5 :: (Eq a, Enum a, Show a, _) => a -> String
arbitCs5 x = arbitCs1 x


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE GADTs #-}
module ExtraConstraints2 where

foo :: _ => String
foo = "x"

-- No extra constraints


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module ExtraConstraints3 where

import qualified Prelude as P

import Prelude (Bool, Bounded, Char, Either, Enum, Eq, FilePath, Floating,
                Fractional, Functor, IO, IOError, Int, Integer, Integral,
                Maybe, Monad, Num, Ord, Ordering, Rational, Read, ReadS, Real,
                RealFloat, RealFrac, Show, ShowS, String)

-- Proof by enumeration! jk :p
-- All of Prelude typechecks given the dummy type signature `_ => _`,
-- which is the same as omitting the type signature entirely.

(!!) :: _ => _
(!!) = (P.!!)
($!) :: _ => _
($!) = (P.$!)
($) :: _ => _
($) = (P.$)
(&&) :: _ => _
(&&) = (P.&&)
(*) :: _ => _
(*) = (P.*)
(**) :: _ => _
(**) = (P.**)
(+) :: _ => _
(+) = (P.+)
(++) :: _ => _
(++) = (P.++)
(-) :: _ => _
(-) = (P.-)
(.) :: _ => _
(.) = (P..)
(/) :: _ => _
(/) = (P./)
(/=) :: _ => _
(/=) = (P./=)
(<) :: _ => _
(<) = (P.<)
(<=) :: _ => _
(<=) = (P.<=)
(=<<) :: _ => _
(=<<) = (P.=<<)
(==) :: _ => _
(==) = (P.==)
(>) :: _ => _
(>) = (P.>)
(>=) :: _ => _
(>=) = (P.>=)
(>>) :: _ => _
(>>) = (P.>>)
(>>=) :: _ => _
(>>=) = (P.>>=)
(^) :: _ => _
(^) = (P.^)
(^^) :: _ => _
(^^) = (P.^^)
(||) :: _ => _
(||) = (P.||)
abs :: _ => _
abs = P.abs
acos :: _ => _
acos = P.acos
acosh :: _ => _
acosh = P.acosh
all :: _ => _
all = P.all
and :: _ => _
and = P.and
any :: _ => _
any = P.any
appendFile :: _ => _
appendFile = P.appendFile
asTypeOf :: _ => _
asTypeOf = P.asTypeOf
asin :: _ => _
asin = P.asin
asinh :: _ => _
asinh = P.asinh
atan :: _ => _
atan = P.atan
atan2 :: _ => _
atan2 = P.atan2
atanh :: _ => _
atanh = P.atanh
break :: _ => _
break = P.break
ceiling :: _ => _
ceiling = P.ceiling
compare :: _ => _
compare = P.compare
concat :: _ => _
concat = P.concat
concatMap :: _ => _
concatMap = P.concatMap
const :: _ => _
const = P.const
cos :: _ => _
cos = P.cos
cosh :: _ => _
cosh = P.cosh
curry :: _ => _
curry = P.curry
cycle :: _ => _
cycle = P.cycle
decodeFloat :: _ => _
decodeFloat = P.decodeFloat
div :: _ => _
div = P.div
divMod :: _ => _
divMod = P.divMod
drop :: _ => _
drop = P.drop
dropWhile :: _ => _
dropWhile = P.dropWhile
either :: _ => _
either = P.either
elem :: _ => _
elem = P.elem
encodeFloat :: _ => _
encodeFloat = P.encodeFloat
enumFrom :: _ => _
enumFrom = P.enumFrom
enumFromThen :: _ => _
enumFromThen = P.enumFromThen
enumFromThenTo :: _ => _
enumFromThenTo = P.enumFromThenTo
enumFromTo :: _ => _
enumFromTo = P.enumFromTo
error :: _ => _
error = P.error
even :: _ => _
even = P.even
exp :: _ => _
exp = P.exp
exponent :: _ => _
exponent = P.exponent
fail :: _ => _
fail = P.fail
filter :: _ => _
filter = P.filter
flip :: _ => _
flip = P.flip
floatDigits :: _ => _
floatDigits = P.floatDigits
floatRadix :: _ => _
floatRadix = P.floatRadix
floatRange :: _ => _
floatRange = P.floatRange
floor :: _ => _
floor = P.floor
fmap :: _ => _
fmap = P.fmap
foldl :: _ => _
foldl = P.foldl
foldl1 :: _ => _
foldl1 = P.foldl1
foldr :: _ => _
foldr = P.foldr
foldr1 :: _ => _
foldr1 = P.foldr1
fromEnum :: _ => _
fromEnum = P.fromEnum
fromInteger :: _ => _
fromInteger = P.fromInteger
fromIntegral :: _ => _
fromIntegral = P.fromIntegral
fromRational :: _ => _
fromRational = P.fromRational
fst :: _ => _
fst = P.fst
gcd :: _ => _
gcd = P.gcd
getChar :: _ => _
getChar = P.getChar
getContents :: _ => _
getContents = P.getContents
getLine :: _ => _
getLine = P.getLine
head :: _ => _
head = P.head
id :: _ => _
id = P.id
init :: _ => _
init = P.init
interact :: _ => _
interact = P.interact
ioError :: _ => _
ioError = P.ioError
isDenormalized :: _ => _
isDenormalized = P.isDenormalized
isIEEE :: _ => _
isIEEE = P.isIEEE
isInfinite :: _ => _
isInfinite = P.isInfinite
isNaN :: _ => _
isNaN = P.isNaN
isNegativeZero :: _ => _
isNegativeZero = P.isNegativeZero
iterate :: _ => _
iterate = P.iterate
last :: _ => _
last = P.last
lcm :: _ => _
lcm = P.lcm
length :: _ => _
length = P.length
lex :: _ => _
lex = P.lex
lines :: _ => _
lines = P.lines
log :: _ => _
log = P.log
logBase :: _ => _
logBase = P.logBase
lookup :: _ => _
lookup = P.lookup
map :: _ => _
map = P.map
mapM :: _ => _
mapM = P.mapM
mapM_ :: _ => _
mapM_ = P.mapM_
max :: _ => _
max = P.max
maxBound :: _ => _
maxBound = P.maxBound
maximum :: _ => _
maximum = P.maximum
maybe :: _ => _
maybe = P.maybe
min :: _ => _
min = P.min
minBound :: _ => _
minBound = P.minBound
minimum :: _ => _
minimum = P.minimum
mod :: _ => _
mod = P.mod
negate :: _ => _
negate = P.negate
not :: _ => _
not = P.not
notElem :: _ => _
notElem = P.notElem
null :: _ => _
null = P.null
odd :: _ => _
odd = P.odd
or :: _ => _
or = P.or
otherwise :: _ => _
otherwise = P.otherwise
pi :: _ => _
pi = P.pi
pred :: _ => _
pred = P.pred
print :: _ => _
print = P.print
product :: _ => _
product = P.product
properFraction :: _ => _
properFraction = P.properFraction
putChar :: _ => _
putChar = P.putChar
putStr :: _ => _
putStr = P.putStr
putStrLn :: _ => _
putStrLn = P.putStrLn
quot :: _ => _
quot = P.quot
quotRem :: _ => _
quotRem = P.quotRem
read :: _ => _
read = P.read
readFile :: _ => _
readFile = P.readFile
readIO :: _ => _
readIO = P.readIO
readList :: _ => _
readList = P.readList
readLn :: _ => _
readLn = P.readLn
readParen :: _ => _
readParen = P.readParen
reads :: _ => _
reads = P.reads
readsPrec :: _ => _
readsPrec = P.readsPrec
realToFrac :: _ => _
realToFrac = P.realToFrac
recip :: _ => _
recip = P.recip
rem :: _ => _
rem = P.rem
repeat :: _ => _
repeat = P.repeat
replicate :: _ => _
replicate = P.replicate
return :: _ => _
return = P.return
reverse :: _ => _
reverse = P.reverse
round :: _ => _
round = P.round
scaleFloat :: _ => _
scaleFloat = P.scaleFloat
scanl :: _ => _
scanl = P.scanl
scanl1 :: _ => _
scanl1 = P.scanl1
scanr :: _ => _
scanr = P.scanr
scanr1 :: _ => _
scanr1 = P.scanr1
seq :: _ => _
seq = P.seq
sequence :: _ => _
sequence = P.sequence
sequence_ :: _ => _
sequence_ = P.sequence_
show :: _ => _
show = P.show
showChar :: _ => _
showChar = P.showChar
showList :: _ => _
showList = P.showList
showParen :: _ => _
showParen = P.showParen
showString :: _ => _
showString = P.showString
shows :: _ => _
shows = P.shows
showsPrec :: _ => _
showsPrec = P.showsPrec
significand :: _ => _
significand = P.significand
signum :: _ => _
signum = P.signum
sin :: _ => _
sin = P.sin
sinh :: _ => _
sinh = P.sinh
snd :: _ => _
snd = P.snd
span :: _ => _
span = P.span
splitAt :: _ => _
splitAt = P.splitAt
sqrt :: _ => _
sqrt = P.sqrt
subtract :: _ => _
subtract = P.subtract
succ :: _ => _
succ = P.succ
sum :: _ => _
sum = P.sum
tail :: _ => _
tail = P.tail
take :: _ => _
take = P.take
takeWhile :: _ => _
takeWhile = P.takeWhile
tan :: _ => _
tan = P.tan
tanh :: _ => _
tanh = P.tanh
toEnum :: _ => _
toEnum = P.toEnum
toInteger :: _ => _
toInteger = P.toInteger
toRational :: _ => _
toRational = P.toRational
truncate :: _ => _
truncate = P.truncate
uncurry :: _ => _
uncurry = P.uncurry
undefined :: _ => _
undefined = P.undefined
unlines :: _ => _
unlines = P.unlines
until :: _ => _
until = P.until
unwords :: _ => _
unwords = P.unwords
unzip :: _ => _
unzip = P.unzip
unzip3 :: _ => _
unzip3 = P.unzip3
userError :: _ => _
userError = P.userError
words :: _ => _
words = P.words
writeFile :: _ => _
writeFile = P.writeFile
zip :: _ => _
zip = P.zip
zip3 :: _ => _
zip3 = P.zip3
zipWith :: _ => _
zipWith = P.zipWith
zipWith3 :: _ => _
zipWith3 = P.zipWith3


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module ExtraNumAMROff where

foo :: _ => a
foo = 3


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE MonomorphismRestriction #-}
module ExtraNumAMROn where

foo :: _ => a
foo = 3


{-# LANGUAGE PartialTypeSignatures, ScopedTypeVariables #-}
module Forall1 where

fall :: forall a. _ -> a
fall v = v


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module GenNamed where

bar :: _a -> _a
bar x = not x


{-# LANGUAGE PartialTypeSignatures, RankNTypes #-}
module HigherRank1 where

foo :: (forall a. [a] -> [a]) -> _
foo x = (x [True, False], x ['a', 'b'])


{-# LANGUAGE PartialTypeSignatures, RankNTypes #-}
module HigherRank2 where

foo :: (forall a. [a] -> [a]) -> (_, _ _)
foo x = (x [True, False], x ['a', 'b'])


{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PartialTypeSignatures #-}
module LocalDefinitionBug where

monoLoc :: forall a. a -> ((a, String), (a, _))
monoLoc x = (g True , g False)
  where
    g :: t -> (a, String)
    g _ = (x, "foo")

-- Test case for (fixed) bug that previously generated the following error message:

-- LocalDefinitionBug.hs:9:16:
--     GHC internal error: â€˜aâ€™ is not in scope during type checking, but it passed the renamer
--     tcl_env of environment: [alA :-> Type variable â€˜_â€™ = _,
--                              alC :-> Identifier[x::a, <NotTopLevel>],
--                              alE :-> Type variable â€˜tâ€™ = t,
--                              rjF :-> Identifier[monoLoc::a
--                                                          -> ((a, String), (a, _)), <NotTopLevel>]]
--     In the type signature for â€˜gâ€™: g :: t -> (a, String)
--     In an equation for â€˜monoLocâ€™:
--         monoLoc x
--           = (g True, g False)
--           where
--               g :: t -> (a, String)
--               g _ = (x, "foo")

-- Fixed by using tcExtendTyVarEnv2 instead of tcExtendTyVarEnv


{-# LANGUAGE PartialTypeSignatures, ScopedTypeVariables, NamedWildCards #-}
module Meltdown where

import Control.Applicative

data NukeMonad a b c

instance Functor (NukeMonad a b) where
  fmap = undefined

instance Applicative (NukeMonad a b) where
  pure = undefined
  (<*>) = undefined

instance Monad (NukeMonad a b) where
  return = undefined
  (>>=) = undefined

isMeltdown :: NukeMonad param1 param2 Bool
isMeltdown = undefined

unlessMeltdown :: _nm () ->  _nm ()
unlessMeltdown c = do m <- isMeltdown
                      if m then return () else c


{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PartialTypeSignatures #-}

module MonoLocalBinds where

monoLoc :: forall a. a -> ((a, String), (a, String))
monoLoc x = (g True , g 'v')
  where
    -- g :: b -> (a, String) -- #1
    g :: b -> (a, _) -- #2
    g y = (x, "foo")

-- For #2, we should infer the same type as in #1.


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module NamedTyVar where

foo :: (_a, b) -> (a, _b)
foo (x, y) = (x, y)


{-# LANGUAGE TypeFamilies, GADTs, DataKinds, PolyKinds, NamedWildCards #-}
module NamedWildcardInDataFamilyInstanceLHS where

data MyKind = A | B

data family Sing (a :: k)

data instance Sing (_a :: MyKind) where
    SingA :: Sing A
    SingB :: Sing B


{-# LANGUAGE TypeFamilies, NamedWildCards #-}
module NamedWildcardInTypeFamilyInstanceLHS where

type family F a where
  F _t = Int


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

-- All declarations below are accepted when the NamedWildCards extension is not
-- enabled and the identifiers starting with _ are parsed as type variables.
-- They should remain valid when the extension is on.
--
-- See Trac #11098 and comments in #10982

module NamedWildcardsAsTyVars where

type Synonym _a = _a -> _a

data A a _b = ACon a a Int

data B _a b = BCon _a (_a, Bool)

type family C a b where
  C _a _b = _a -> _a

type family D a b where
  D _a b = _a -> (_a, Int)

data family E a b
data instance E a _b = ECon a (a, Int)

data family F a b
data instance F _a b = FCon _a _a Bool

class G _a where
    gfoo :: _a -> _a

instance G Int where
    gfoo = (*2)

type family H a b where
  H _a _a = Int
  H _a _b = Bool

hfoo :: H String String
hfoo = 10

hbar :: H String Int
hbar = False

type family I (_a :: k) where
    I _t = Int


{-# LANGUAGE PartialTypeSignatures #-}
module ParensAroundContext where

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


{-# LANGUAGE PartialTypeSignatures #-}
module PatBind where

foo :: _
Just foo = Just id


{-# LANGUAGE PartialTypeSignatures #-}
module PatBind2 where

foo :: Bool -> _
Just foo = Just id


{-# LANGUAGE PartialTypeSignatures, ScopedTypeVariables #-}
module PatternSig where

bar :: Bool -> Bool
bar (x :: _) = True


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
module PatternSplice where

foo $( [p| (x :: _) |] ) = x


{-# LANGUAGE PartialTypeSignatures #-}
module Recursive where

orr :: a -> a -> a
orr = undefined

g :: _
g = f `orr` True

f :: _
f = g


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}

module ScopedNamedWildcards where

test3 :: _
test3 x = const (let x :: _b
                     x = True in False) $
          const (let x :: _b
                     x = 'a' in True) $
          not x


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}

module ScopedNamedWildcardsGood where

-- The named wildcards aren't scoped as the ScopedTypeVariables extension
-- isn't enabled, of which the behaviour is copied. Thus, the _a annotation of
-- x, which must be Bool, isn't the same as the _a in g, which is now
-- generalised over.
foo :: _a -> _
foo x = let v = not x
            g :: _a -> _a
            g x = x
        in (g 'x')


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module ShowNamed where

showTwo :: Show _a => _a -> String
showTwo x = show x


{-# LANGUAGE PartialTypeSignatures #-}
module SimpleGen where

bar :: _ -> Bool
bar _ = True


{-# LANGUAGE PartialTypeSignatures #-}
module SkipMany where

data GenParser tok st a = GenParser tok st a

skipMany' :: GenParser tok st a -> GenParser tok st ()
skipMany' = undefined

skipMany :: _ -> _ ()
skipMany = skipMany'


{-# LANGUAGE FlexibleContexts, PartialTypeSignatures, NamedWildCards #-}
module SomethingShowable where

somethingShowable :: Show _x => _x -> _
somethingShowable x = show (not x)
-- Inferred type: Bool -> String


{-# LANGUAGE TemplateHaskell, NamedWildCards #-}

module Splices where

import Language.Haskell.TH
import Language.Haskell.TH.Lib (wildCardT)

metaType1 :: TypeQ
metaType1 = wildCardT

metaType2 :: TypeQ
metaType2 = [t| _ |]

metaType3 :: TypeQ
metaType3 = [t| _ -> _ -> _ |]

metaDec1 :: Q [Dec]
metaDec1 = [d| foo :: _ => _
               foo x y = x == y |]

metaDec2 :: Q [Dec]
metaDec2 = [d| bar :: _a -> _b -> (_a, _b)
               bar x y = (not x, y) |]

-- An expression with a partial type annotation
metaExp1 :: ExpQ
metaExp1 = [| Just True :: Maybe _ |]

metaExp2 :: ExpQ
metaExp2 = [| id :: _a -> _a |]


{-# LANGUAGE TemplateHaskell, PartialTypeSignatures, NamedWildCards #-}

module SplicesUsed where

import Splices

maybeBool :: $(metaType1)
maybeBool = $(metaExp2) $(metaExp1)

charA :: a -> $(metaType2)
charA x = ('x', x)

filter' :: $(metaType3)
filter' = filter

$(metaDec1)

$(metaDec2)


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module SuperCls where

f :: (Ord a, _) => a -> Bool
-- We'd like to see that the wildcard _ unifies with ()
f x = x == x


{-# LANGUAGE PartialTypeSignatures #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module T10403 where

data I a = I a
instance Functor I where
    fmap f (I a) = I (f a)

newtype B t a = B a
instance Functor (B t) where
    fmap f (B a) = B (f a)

newtype H f = H (f ())

h1 :: _ => _
-- h :: Functor m => (a -> b) -> m a -> H m
h1 f b = (H . fmap (const ())) (fmap f b)

h2 :: _
-- MR applies
-- h2 :: Functor m => (a -> b) -> m a -> H m
h2 f b = (H . fmap (const ())) (fmap f b)

app1 :: H (B t)
app1 = h1 (H . I) (B ())

app2 :: H (B t)
app2 = h2 (H . I) (B ())


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE TypeFamilies #-}
module T10438 where

foo f = g
  where g r = x
          where x :: _
                x = r


{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-}

module T10463 where

f (x :: _) = x ++ ""


{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE PartialTypeSignatures #-}
module T10519 where

foo :: forall a. _ => a -> a -> Bool
foo x y = x == y


{-# LANGUAGE ImplicitParams, PartialTypeSignatures #-}

module T11016 where

f1 :: (?x :: Int, _) => Int
f1 = ?x

f2 :: (?x :: Int) => _
f2 = ?x


{-# LANGUAGE PartialTypeSignatures #-}

module T11192 where

fails :: a
fails =
   let go :: _
       go 0 a = a
   in go (0 :: Int) undefined

succeeds :: a
succeeds =
   let go :: _
       go _ a = a
   in go (0 :: Int) undefined


{-# LANGUAGE PartialTypeSignatures #-}

module T11399a where

bar :: _
(bar) = id


{-# LANGUAGE InstanceSigs, PartialTypeSignatures #-}

module T11670 where

import Foreign.C.Types
import Foreign.Storable
import Foreign.Ptr

peek :: Ptr a -> IO CLong
peek ptr = peekElemOff undefined 0 :: IO _

peek2 :: Ptr a -> IO CLong
peek2 ptr = peekElemOff undefined 0 :: _ => IO _

-- castPtr :: Ptr a -> Ptr b
-- peekElemOff :: Storable a => Ptr a -> Int -> IO a


{-# LANGUAGE TypeFamilies, PartialTypeSignatures #-}

-- In Trac #12033 this was called HsakellBug.hs

module T12033 where
tripleStoreToRuleSet :: v -> v
tripleStoreToRuleSet getAtom
 = makeTuple getAtom
 where
   makeRule v = makeExpression v
   makeTuple v = makeExpression v
   makeExpression :: _
   makeExpression v = makeTuple getAtom


{-# LANGUAGE MagicHash #-}

module T12531 where
import GHC.Exts

f x = I# (_ +# x)


{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module T12844 where

barWraper :: ('(r,r') ~ Head rngs, Foo rngs) => FooData rngs
barWraper = bar

bar :: (_) => FooData rngs
bar = foo

data FooData rngs

class Foo xs where foo :: (Head xs ~ '(r,r')) => FooData xs

type family Head (xs :: [k]) where Head (x ': xs) = x


{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

module T12845 where

import Data.Proxy

data Foo (m :: Bool)

type family Head (xs :: [(Bool, Bool)]) where Head (x ': xs) = x

type family Bar (x :: Bool) (y :: Bool) :: Bool

-- to trigger the bug, r and r' cannot *both* appear on the RHS
broken :: forall r r' rngs . ('(r,r') ~ Head rngs, Bar r r' ~ 'True, _)
  => Foo r -> Proxy rngs -> ()
broken x _ = let y = requireBar x :: Foo r' in ()

requireBar :: (Bar m m' ~ 'True) => Foo m -> Foo m'
requireBar = undefined


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
module T13324_compile where

data Option a = None | Some a

deriving instance _ => Show (Option a)


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE KindSignatures #-}

module T12382 where

import Data.Kind (Type)

minimal1_noksig :: forall m. ( _ ) => Int -> Bool
minimal1_noksig _ = (mempty :: m) == (mempty :: m)

minimal1 :: forall (m :: Type). _ => Bool
minimal1 = (mempty :: m) == (mempty :: m)

minimal2 :: forall m. (Eq m, _) => Bool
minimal2 = (mempty :: m) == (mempty :: m)

minimal3 :: forall m. (Monoid m, _) => Bool
minimal3 = (mempty :: m) == (mempty :: m)

minimal4 :: forall m. (Monoid m, Eq m) => Bool
minimal4 = (mempty :: m) == (mempty :: m)


{-# LANGUAGE PartialTypeSignatures #-}

module T14653 where

af, ag :: (Num a,_) => a -> a
-- It's important that one signature covers both

af y = ag y
ag x = af (x-1)


{-# LANGUAGE PartialTypeSignatures #-}

module T14653a where

af :: (Num a,_) => a -> a
af y = ag y

ag :: (Num a,_) => a -> a
ag x = af (x-1)


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
module T14715 (bench_mulPublic) where

data Cyc r
data CT zp r'q
class Reduce a b
type family LiftOf b

bench_mulPublic :: forall z zp zq . (z ~ LiftOf zq, _) => Cyc zp -> Cyc z -> IO (zp,zq)
bench_mulPublic pt sk = do
  ct :: CT zp (Cyc zq) <- encrypt sk pt
  undefined ct

encrypt :: forall z zp zq. Reduce z zq => Cyc z -> Cyc zp -> IO (CT zp (Cyc zq))
encrypt = undefined


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module T15039a where

import Data.Coerce
import Data.Kind
import Data.Type.Coercion
import Data.Type.Equality

data Dict :: Constraint -> Type where
  Dict :: c => Dict c

ex1 :: Dict ((a :: Type) ~ (b :: Type)) -> ()
ex1 (Dict :: _) = ()

ex2 :: Dict ((a :: Type) ~~ (b :: Type)) -> ()
ex2 (Dict :: _) = ()

ex3 :: Dict ((a :: Type) ~~ (b :: k)) -> ()
ex3 (Dict :: _) = ()

-- Don't know how to make GHC print an unlifted, nominal equality in an error
-- message.
--
-- ex4, ex5 :: ???

ex6 :: Dict (Coercible (a :: Type) (b :: Type)) -> ()
ex6 (Dict :: _) = ()

ex7 :: _ => Coercion (a :: Type) (b :: Type)
ex7 = Coercion

-- Don't know how to make GHC print an unlifted, heterogeneous,
-- representational equality in an error message.
--
-- ex8 :: ???


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module T15039b where

import Data.Coerce
import Data.Kind
import Data.Type.Coercion
import Data.Type.Equality

data Dict :: Constraint -> Type where
  Dict :: c => Dict c

ex1 :: Dict ((a :: Type) ~ (b :: Type)) -> ()
ex1 (Dict :: _) = ()

ex2 :: Dict ((a :: Type) ~~ (b :: Type)) -> ()
ex2 (Dict :: _) = ()

ex3 :: Dict ((a :: Type) ~~ (b :: k)) -> ()
ex3 (Dict :: _) = ()

-- Don't know how to make GHC print an unlifted, nominal equality in an error
-- message.
--
-- ex4, ex5 :: ???

ex6 :: Dict (Coercible (a :: Type) (b :: Type)) -> ()
ex6 (Dict :: _) = ()

ex7 :: _ => Coercion (a :: Type) (b :: Type)
ex7 = Coercion

-- Don't know how to make GHC print an unlifted, heterogeneous,
-- representational equality in an error message.
--
-- ex8 :: ???


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module T15039c where

import Data.Coerce
import Data.Kind
import Data.Type.Coercion
import Data.Type.Equality

data Dict :: Constraint -> Type where
  Dict :: c => Dict c

ex1 :: Dict ((a :: Type) ~ (b :: Type)) -> ()
ex1 (Dict :: _) = ()

ex2 :: Dict ((a :: Type) ~~ (b :: Type)) -> ()
ex2 (Dict :: _) = ()

ex3 :: Dict ((a :: Type) ~~ (b :: k)) -> ()
ex3 (Dict :: _) = ()

-- Don't know how to make GHC print an unlifted, nominal equality in an error
-- message.
--
-- ex4, ex5 :: ???

ex6 :: Dict (Coercible (a :: Type) (b :: Type)) -> ()
ex6 (Dict :: _) = ()

ex7 :: _ => Coercion (a :: Type) (b :: Type)
ex7 = Coercion

-- Don't know how to make GHC print an unlifted, heterogeneous,
-- representational equality in an error message.
--
-- ex8 :: ???


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module T15039d where

import Data.Coerce
import Data.Kind
import Data.Type.Coercion
import Data.Type.Equality

data Dict :: Constraint -> Type where
  Dict :: c => Dict c

ex1 :: Dict ((a :: Type) ~ (b :: Type)) -> ()
ex1 (Dict :: _) = ()

ex2 :: Dict ((a :: Type) ~~ (b :: Type)) -> ()
ex2 (Dict :: _) = ()

ex3 :: Dict ((a :: Type) ~~ (b :: k)) -> ()
ex3 (Dict :: _) = ()

-- Don't know how to make GHC print an unlifted, nominal equality in an error
-- message.
--
-- ex4, ex5 :: ???

ex6 :: Dict (Coercible (a :: Type) (b :: Type)) -> ()
ex6 (Dict :: _) = ()

ex7 :: _ => Coercion (a :: Type) (b :: Type)
ex7 = Coercion

-- Don't know how to make GHC print an unlifted, heterogeneous,
-- representational equality in an error message.
--
-- ex8 :: ???


{-# LANGUAGE NamedWildCards, PartialTypeSignatures, PolyKinds, NoStarIsType #-}

module T16334 where

k :: (Int :: _t)
k = 42


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NamedWildCards #-}
{-# LANGUAGE PartialTypeSignatures #-}
module TypedSplice where

import Language.Haskell.TH

metaExp :: Q (TExp (Bool -> Bool))
metaExp = [|| not :: _ -> _b ||]


{-# LANGUAGE TypeFamilies #-}
module TypeFamilyInstanceLHS where

import Data.Kind (Type)

type family F (a :: Type) (b :: Type) :: Type
type instance F Int  _ = Int
type instance F Bool _ = Bool

foo :: F Int Char -> Int
foo = id


{-# LANGUAGE PartialTypeSignatures #-}
module Uncurry where

unc :: (_ -> _ -> _) -> (_, _) -> _
unc = uncurry


{-# LANGUAGE PartialTypeSignatures, NamedWildCards #-}
module UncurryNamed where

unc :: (_a -> _b -> _c) -> (_a, _b) -> _c
unc = uncurry


{-# LANGUAGE PartialTypeSignatures, NamedWildCards, ScopedTypeVariables, RankNTypes #-}
module WildcardInstantiations where

foo :: (Show _a, _) => _a -> _
foo x = show (succ x)

bar :: _ -> _ -> _
bar x y = y x


{-# LANGUAGE PartialTypeSignatures #-}
module NamedWildcardsEnabled where

foo :: Eq a => a -> (a, _)
foo x = (x, x)

test = foo id

-- As id (forall a. a -> a) doesn't implement Eq, the we cannot apply
-- foo with it. This test checks that foo gets the annotated type,
-- including constraints, not just the inferred type.


{-# LANGUAGE PartialTypeSignatures #-}
module AnnotatedConstraintNotForgotten where

foo :: (Eq a, _) => a -> String
foo x = show x

data Foo = Foo deriving Show

-- Foo doesn't implement Eq, so `foo Foo` should fail. This is to
-- verify that the final type of foo didn't forget about the annotated
-- `Eq a` constraint.
test :: String
test = foo Foo


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
module Defaulting1MROff where

-- Even without the MR, this signature forces monomorphism,
-- because of the partial signature with no '=>'
alpha :: _
alpha = 3


{-# LANGUAGE PartialTypeSignatures #-}

module ExtraConstraintsWildcardInExpressionSignature where

foo x y = ((==) :: _ => _) x y


{-# LANGUAGE ScopedTypeVariables #-}
module ExtraConstraintsWildcardInPatternSignature where

foo (x :: _ => _) y = x == y


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

foo $( [p| (_ :: _) |] ) = ()


{-# LANGUAGE TemplateHaskell #-}
module ExtraConstraintsWildcardInTypeSplice where

import Language.Haskell.TH

metaType :: TypeQ
metaType = [t| _ => _ |]


{-# LANGUAGE TemplateHaskell, PartialTypeSignatures  #-}
module ExtraConstraintsWildcardInTypeSplice2 where

import Language.Haskell.TH.Lib (wildCardT)

show' :: $(wildCardT) => a -> String
show' x = show x


{-# LANGUAGE TemplateHaskell #-}
module ExtraConstraintsWildcardInTypeSpliceUsed where

import ExtraConstraintsWildcardInTypeSplice

-- An extra-constraints wild card is not supported in type splices
eq :: $(metaType)
eq x y = x == y


module ExtraConstraintsWildcardNotEnabled where

show' :: _ => a -> String
show' x = show x

-- with the PartialTypeSignatures extension enabled this would lead to the
-- type Show a => a -> String


{-# LANGUAGE PartialTypeSignatures #-}
module ExtraConstraintsWildcardNotLast where

foo :: (_, Eq a) => a -> a
foo = undefined


{-# LANGUAGE PartialTypeSignatures #-}
module ExtraConstraintsWildcardNotPresent where

show' :: a -> _
show' x = show x

-- With an extra-constraints wildcard present, this would lead to the
-- type Show a => a -> String.

-- This test makes sure that not merely having a partial type
-- signature is enough to generate extra constraints, an
-- extra-constraints wildcard is needed.


{-# LANGUAGE PartialTypeSignatures #-}
module ExtraConstraintsWildcardTwice where

foo :: ((_), _) => a -> a
foo = undefined


{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-}
module Forall1 where

fall :: forall a. _ -> a
fall v = v

-- The wildcard should unify with a
test :: Char
test = fall True


{-# LANGUAGE NamedWildCards #-}
module InstantiatedNamedWildcardsInConstraints where

foo :: (Enum _a, _) => _a -> (String, b)
foo x = (show (succ x), x)


{-# LANGUAGE ConstraintKinds, PartialTypeSignatures, NamedWildCards #-}
module NamedExtraConstraintsWildcard where

foo :: (Eq a, _a) => a -> a
foo = undefined


{-# LANGUAGE RankNTypes, NamedWildCards #-}

-- See Trac #11098

module NamedWildcardExplicitForall where

foo :: forall _a . _a -> _a                -- _a is a type variable
foo = not

bar :: _a -> _a                            -- _a is a named wildcard
bar = not

baz :: forall _a . _a -> _b -> (_a, _b)    -- _a is a variable, _b is a wildcard
baz x y = (not x, not y)

qux :: _a -> (forall _a . _a -> _a) -> _a  -- the _a bound by forall is a tyvar
qux x f = let _ = f 7 in not x             -- the other _a are wildcards


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE NamedWildCards #-}
module NamedWildcardInTypeSplice where

import Language.Haskell.TH

metaType :: TypeQ
metaType = [t| _a -> _a |]


{-# LANGUAGE NamedWildCards #-}
module NamedWildcardsEnabled where

foo :: _a -> _b
foo x = not x


module NamedWildcardsNotEnabled where

foo :: _a -> _b
foo x = not x

-- with the NamedWildcards extension enabled this would lead to the
-- type Bool -> Bool.


{-# LANGUAGE PartialTypeSignatures, TypeFamilies, NamedWildCards, ConstraintKinds #-}
module NamedWildcardsNotInMonotype where

foo :: (Show _a, Eq _c, Eq _b) => _a -> _b -> String
foo x y = show x ++ show (x == y)


{-# LANGUAGE RankNTypes, PartialTypeSignatures #-}
module NestedExtraConstraintsWildcard where

foo :: Bool -> (Eq a, _) => a
foo = undefined


{-# LANGUAGE RankNTypes, PartialTypeSignatures, NamedWildCards #-}
module NestedNamedExtraConstraintsWildcard where

foo :: Bool -> (Eq a, _a) => a
foo = undefined


{-# LANGUAGE PartialTypeSignatures #-}
module PartialClassMethodSignature where

class Foo a where
  foo :: a -> _


{-# LANGUAGE PartialTypeSignatures #-}
module PartialClassMethodSignature2 where

class Foo a where
  foo :: (Eq a, _) => a -> a


module PartialTypeSignaturesEnabled where

-- The PartialTypeSignatures extension should be enabled
foo :: _ -> _
foo x = not x


{-# LANGUAGE PartialTypeSignatures #-}
module PatBind3 where

-- Oddly GHC 8.0 accepted this, but it should obviously fail!
foo :: (Bool, _) -> Char
Just foo = Just id


{-# LANGUAGE PartialTypeSignatures, NamedWildCards, ScopedTypeVariables #-}

module ScopedNamedWildcardsBad where

-- If named wildcards are properly scoped, this should lead to
-- a constraint (Bool ~ Char)
foo :: _a -> _
foo x = let v = not x
            g :: _a -> _a
            g x = x
        in (g 'x')


module T10045 where

newtype Meta = Meta ()

foo (Meta ws1) =
     let copy :: _
         copy w from = copy w True
     in copy ws1 False


{-# LANGUAGE RankNTypes #-}
module T10615 where

f1 :: _ -> f
f1 = const

f2 :: _ -> _f
f2 = const


module T10999 where

import qualified Data.Set as Set

f :: _ => () -> _
f _ = Set.fromList undefined

g = map fst $ Set.toList $ f ()


{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE PartialTypeSignatures #-}

module T11122 where

data Parser a

instance Functor Parser where
  fmap = undefined

many p = undefined

digit = undefined

parseTest = undefined

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

parser :: Parser _
--parser :: Parser Int
parser = read <$> many digit

data Wrapper = Wrapper Int deriving Show

wrapperParser = Wrapper <$> parser

main :: IO ()
main = parseTest wrapperParser "0"


{-# LANGUAGE ConstraintKinds, TypeFamilies #-}

module T11515 where

type family ShowSyn a where ShowSyn a = Show a

foo :: (ShowSyn a, _) => a -> String
foo x = show x


{-# LANGUAGE PartialTypeSignatures, RankNTypes #-}

module T11976 where

type Lens s a = forall f. Functor f => (a -> f a) -> (s -> f s)

foo = undefined :: Lens _ _ _


{-# LANGUAGE PartialTypeSignatures #-}

module T12039 where

class Num _ => B a


{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}

module T12634 where

twacePowDec :: t m' r -> t m r
twacePowDec = undefined

data Bench a

bench :: (a -> b) -> a -> Bench params
bench f = undefined

bench_twacePow :: forall t m m' r . _ => t m' r -> Bench '(t,m,m',r)
bench_twacePow = bench (twacePowDec :: t m' r -> t m r)


module T12732 where

(a ... b) xs
  | a == x
  , (l, _:r) <- break (== x) xs
  = l ++ [x]


{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
module T13324_fail1 where

data Option a = None | Some a

deriving instance (Eq a, _) => Eq (Option a)
deriving instance (Show _) => Show (Option a)


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
module T13324_fail2 where

newtype Foo f a = Foo (f (f a))
deriving instance _ => Eq (Foo f a)

data T a where
    MkT :: T Int
deriving instance _ => Eq (T a)


{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds, PolyKinds #-}
module T14040a where

import Data.Kind

data family Sing (a :: k)

data WeirdList :: Type -> Type where
  WeirdNil  :: WeirdList a
  WeirdCons :: a -> WeirdList (WeirdList a) -> WeirdList a

data instance Sing (z :: WeirdList a) where
  SWeirdNil  :: Sing WeirdNil
  SWeirdCons :: Sing w -> Sing wws -> Sing (WeirdCons w wws)

elimWeirdList :: forall (a :: Type) (wl :: WeirdList a)
                        (p :: forall (x :: Type). x -> WeirdList x -> Type).
                 Sing wl
              -> (forall (y :: Type). p _ WeirdNil)
              -> (forall (z :: Type) (x :: z) (xs :: WeirdList (WeirdList z)).
                    Sing x -> Sing xs -> p _ xs
                  -> p _ (WeirdCons x xs))
              -> p _ wl
elimWeirdList SWeirdNil pWeirdNil _ = pWeirdNil
elimWeirdList (SWeirdCons (x :: Sing (x :: z))
                          (xs :: Sing (xs :: WeirdList (WeirdList z))))
              pWeirdNil pWeirdCons
  = pWeirdCons @z @x @xs x xs
      (elimWeirdList @(WeirdList z) @xs @p xs pWeirdNil pWeirdCons)


{-# LANGUAGE PartialTypeSignatures #-}

module T14449 where

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


{-# LANGUAGE ScopedTypeVariables, PartialTypeSignatures #-}

module T14479 where

foo :: Num a => a -> a
foo xxx = g xxx
  where
    g :: forall b. Num b => _ -> b
    g y = xxx + y


{-# OPTIONS_GHC -fdefer-type-errors #-}     -- Very important to this bug!
{-# Language PartialTypeSignatures #-}
{-# Language TypeFamilyDependencies, KindSignatures #-}
{-# Language PolyKinds #-}
{-# Language DataKinds #-}
{-# Language TypeFamilies #-}
{-# Language RankNTypes #-}
{-# Language NoImplicitPrelude #-}
{-# Language FlexibleContexts #-}
{-# Language MultiParamTypeClasses #-}
{-# Language GADTs #-}
{-# Language ConstraintKinds #-}
{-# Language FlexibleInstances #-}
{-# Language TypeOperators #-}
{-# Language ScopedTypeVariables #-}
{-# Language DefaultSignatures #-}
{-# Language FunctionalDependencies #-}
{-# Language UndecidableSuperClasses #-}
{-# Language UndecidableInstances #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language InstanceSigs, TypeApplications #-}

module T14584 where

import Data.Monoid
import Data.Kind

data family Sing (a::k)

class SingKind k where
  type Demote k = (res :: Type) | res -> k
  fromSing :: Sing (a::k) -> Demote k

class SingI (a::k) where
  sing :: Sing a

data ACT  :: Type -> Type -> Type
data MHOM :: Type -> Type -> Type

type m %%-  a  = ACT  m a  -> Type
type m %%-> m' = MHOM m m' -> Type

class Monoid m => Action (act :: m %%- a) where
  act :: m -> (a -> a)

class (Monoid m, Monoid m') => MonHom (mhom :: m %%-> m') where
  monHom :: m -> m'

data MonHom_Distributive m :: (m %%- a) -> (a %%-> a)

type Good k = (Demote k ~ k, SingKind k)

instance (Action act, Monoid a, Good m) => MonHom (MonHom_Distributive m act :: a %%-> a) where
  monHom :: a -> a
  monHom = act @_ @_ @act (fromSing @m (sing @m @a :: Sing _))


{-# OPTIONS_GHC -fdefer-type-errors #-}     -- Very important to this bug!
{-# Language PartialTypeSignatures #-}
{-# Language KindSignatures #-}
{-# Language PolyKinds #-}
{-# Language ScopedTypeVariables #-}
{-# Language AllowAmbiguousTypes #-}
{-# Language TypeApplications #-}

module T14584a where

f :: forall m. ()
f = id @m :: _

g :: forall m. ()
g = let h = id @m
    in h


module TidyClash where

-- Type variables originating from wildcards are normally given the name w_,
-- but in this case there is already a type variable called w_. Tidying the
-- types should result in w_1 and w_2 for the two new type variables
-- originating from the wildcards.

bar :: w_ -> (w_, _ -> _)
bar x = (x, \y -> undefined)


{-# LANGUAGE NamedWildCards, ScopedTypeVariables #-}
module TidyClash2 where

{-
The bug that TidyClash2 tries to tickle is the following: when GHC generalises
over wild cards it uses t, t1, t2, ... as type variables. When the user already
used the t type variable in the same signature, the tidier should respect this
and use t1, t2, ... for generalised wild cards. So _ -> -> t should result
in t1 -> t2 -> t. Before the bug fix, the actual output would have been
something like t -> t1 -> t2.
-}

barry :: forall t. _ -> _ -> t
barry (x :: _) (y :: _) = undefined :: _


{-# LANGUAGE PartialTypeSignatures #-}
module UnnamedConstraintWildcard1 where

foo :: Show _ => a -> String
foo x = show x


{-# LANGUAGE PartialTypeSignatures #-}
module UnnamedConstraintWildcard2 where

foo :: _ a => a -> String
foo x = show x


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInADT1 where

data Foo a = Foo (Either _ a)


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInADT2 where

data Foo a = Foo { get :: Either _ a }


{-# LANGUAGE PartialTypeSignatures, RankNTypes #-}
module WildcardInADT3 where

data Foo a = Foo { get :: _ => a }


{-# LANGUAGE PartialTypeSignatures, DatatypeContexts #-}
module WildcardInADTContext where

data (Eq a, _) => Foo a = Foo { getFoo :: a }


{-# LANGUAGE PartialTypeSignatures, NamedWildCards, DatatypeContexts #-}
module WildcardInADTContext2 where

data (Eq _a) => Foo a = Foo { getFoo :: a }


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInDefault where

default (_)


{-# LANGUAGE DefaultSignatures #-}
module WildcardInDefaultSignature where

class C a where
  f :: a
  default f :: _


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInDeriving where

data Foo a = Foo a
           deriving (_)


{-# LANGUAGE PartialTypeSignatures, ForeignFunctionInterface #-}
module WildcardInForeignExport where

import Foreign.C

foreign export ccall foo :: CInt -> _
foo = undefined


{-# LANGUAGE PartialTypeSignatures, ForeignFunctionInterface #-}
module WildcardInForeignImport where

import Foreign.C

foreign import ccall "sin" c_sin :: CDouble -> _


{-# LANGUAGE PartialTypeSignatures, GADTs #-}
module WildcardInGADT1 where

data Foo a where
  Foo :: Either a _ -> Foo a


{-# LANGUAGE PartialTypeSignatures, GADTs #-}
module WildcardInGADT2 where

data Foo a where
  Foo :: (Eq a, _) => Maybe a -> Foo a


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInInstanceHead where

class Foo k where
  bar :: k

instance Foo _ where
  bar = 3


{-# LANGUAGE InstanceSigs #-}
module WildcardInInstanceSig where

instance Num Bool where
  negate :: _
  negate = undefined


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInNewtype where

-- Currently handled by the same checks as for ADTs, but in case this
-- changes in the future, add at least one test.

newtype Foo a = Foo (Either _ a)


{-# LANGUAGE PatternSynonyms #-}
module WildcardInPatSynSig where

pattern Single :: () => (Show a) => _ -> [a]
pattern Single x = [x]


{-# LANGUAGE StandaloneDeriving #-}
module WildcardInStandaloneDeriving where

deriving instance _


{-# LANGUAGE NamedWildCards, ScopedTypeVariables, RankNTypes #-}
module WildcardInstantiations where

foo :: (Show _a, _) => _a -> _
foo x = show (succ x)

bar :: _ -> _ -> _
bar x y = y x


{-# LANGUAGE PartialTypeSignatures, TypeFamilies, InstanceSigs #-}
module WildcardInTypeFamilyInstanceRHS where

class Foo k where
  type Dual k :: *

instance Foo Int where
  type Dual Int = Maybe _


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInTypeSynonymLHS where

type Foo _ = Int


{-# LANGUAGE PartialTypeSignatures #-}
module WildcardInTypeSynonymRHS where

type Foo = Maybe _


{-# LANGUAGE NamedWildCards, ScopedTypeVariables #-}
module WildcardsInPatternAndExprSig where

bar (Just ([x :: _a] :: _) :: Maybe [_b]) (z :: _c) = [x, z] :: [_d]


-- Pattern synonyms

{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern Single x = [x]


module Bundle(A(..)) where

import BundleInternal (A(..))

foo = MkA 5
baz = NoA

qux (MkA x) = x
qux NoA = 0


module Associated1(A(..)) where

import BundleInternal1 (A(..))

foo = MkA 5
baz = NoA

qux (MkA x) = x
qux NoA = 0


{-# LANGUAGE PatternSynonyms #-}
module BundleInternal (A(NewA,MkA, NoA)) where

newtype A = NewA (Maybe Int)

pattern MkA n = NewA (Just n)

pattern NoA = NewA Nothing


{-# LANGUAGE PatternSynonyms #-}
module BundleInternal1 (A(NewA,MkA, NoA)) where

newtype A = NewA (Maybe Int)

pattern MkA n = NewA (Just n)

pattern NoA = NewA Nothing


-- Pattern synonyms

{-# LANGUAGE PatternSynonyms, GADTs #-}
module ShouldCompile where

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

pattern P x <- MkT 42 x


-- Pattern synonyms

{-# LANGUAGE PatternSynonyms, GADTs #-}
module ShouldCompile where

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

pattern P x y <- MkT x y

f :: T Bool -> Bool
f (P x y) = x && y == y


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-}

-- Pattern synonyms

module ShouldCompile where

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

f :: (Show a) => a -> Bool
f = undefined

pattern P x <- MkT (f -> True) x


-- Pattern synonyms
-- Existentially-quantified type variables

{-# LANGUAGE GADTs, PatternSynonyms #-}
module ShouldCompile where

data T where
    MkT :: b -> (b -> Bool) -> T

pattern P x f <- MkT x f

test :: T -> Bool
test (P x f) = f x


{-# LANGUAGE PatternSynonyms #-}

module Foo ( A(foo) ) where

data A a = A a

pattern P :: Int -> A Int
pattern P{foo} = A foo


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ViewPatterns #-}

module Foo ( A(P) ) where

class (f ~ A) => C f a where
  build :: a -> f a
  destruct :: f a -> a

data A a = A a

instance C A Int where
  build n = A n
  destruct (A n) = n

pattern P :: C f a => a -> f a
pattern P x <- (destruct -> x)
  where
        P x = build x


{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile (pattern Single) where

pattern Single x <- [x]


{-# LANGUAGE PatternSynonyms #-}

module ExportSyntax ( 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 ExportSyntaxImport where

import ExportSyntax

foo = NoA

baz = A


{-# LANGUAGE PatternSynonyms #-}
module ImpExp_Exp (pattern Single) where

pattern Single x <- [x]


module ShouldFail where

import ImpExp_Exp

single :: [a] -> Maybe a
single (Single x) = Just x
single _ = Nothing


-- Pattern synonyms
-- Generated code doesn't emit overlapping pattern warnings

{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern P <- Just True

test1 P = 2
test1 Nothing = 3
test1 (Just _) = 4


{-# LANGUAGE GADTs, PatternSynonyms #-}

-- Tests that for unidirectional pattern synonyms
-- the pattern synonym can be more existential
-- (i.e. lose information) wrt the original

module MoreEx where

pattern ExCons :: a -> [a] -> [b]
pattern ExCons x xs <- x : xs

data T where
  MkT1 :: ([a] -> Int) -> [a] -> T
  MkT2 :: (a -> Int) -> a -> T

pattern ExT1 :: b -> (b -> Int) -> T
pattern ExT1 x f <- MkT1 f x

pattern ExT2 :: b -> (c -> Int) -> T
pattern ExT2 x f <- MkT2 f x


{-# LANGUAGE PatternSynonyms #-}

module Foo (A(B, C)) where

data A a = A

pattern B :: A Int
pattern B = A

pattern C :: A String
pattern C = A


-- Pattern synonyms

{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern P = 42


-- Pattern synonyms
-- Generated code doesn't emit overlapping pattern warnings

{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern P = ()

test P = ()


{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module Foo (Foo(P)) where

data Foo a = Foo a

instance C Foo where
  build a = Foo a
  destruct (Foo a) = a

class C f where
  build :: a -> f a
  destruct :: f a -> a

pattern P :: C f => a -> f a
pattern P x <- (destruct -> x)
  where
        P x = build x


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}
module Foo (A(P,Q)) where

data A a = A a

pattern P :: Show a => a -> A a
pattern P a = A a

pattern Q :: (A ~ f) => a -> f a
pattern Q a = A a


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}

-- Testing polykindedness

module Foo ( A(P) ) where

data A a = A

pattern P = A


{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern Single{x} = [x]

-- Selector
selector :: Int
selector = x [5]

update :: [String]
update = ["String"] { x = "updated" }


{-# LANGUAGE PatternSynonyms #-}
module PolyPat where

-- Testing whether type changing updates work correctly.

pattern MyTuple :: a -> b -> (a, b)
pattern MyTuple{mfst, msnd} = (mfst, msnd)

expr1 :: (Int, String) -> (Int, Int)
expr1 a = a { msnd = 2}

expr3 a = a { msnd = 2}

expr2 :: (a, b) -> a
expr2 a = mfst a


{-# LANGUAGE PatternSynonyms, ViewPatterns, GADTs, RankNTypes,
 StandaloneDeriving, FlexibleInstances #-}
module ShouldCompile where

-- Testing that selectors work properly with prov and req thetas

data T a b where
  MkT :: (Show b) => a -> b -> T a b

deriving instance Show (T Int A)

data G a b = MkG { care :: a,  y :: (Show b => b) }

pattern ExNumPat :: (Eq b) => (Show b) => b -> T Int b
pattern ExNumPat{x} = MkT 42 x

data A = A | B deriving (Show, Eq)

f3 :: T Int A
f3 = (MkT 42 A) { x = B }

f5 :: T Int A
f5 = (ExNumPat A) { x = B }

f4 = (MkG 42 True) { y = False }


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE NoImplicitPrelude #-}
module Main where

import Prelude (Maybe(..), Show(..), String, Bool(..), print)

pattern ReqNoProv :: Show a => a -> Maybe a
pattern ReqNoProv{j} = Just j

p1 = ReqNoProv True

p7 (ReqNoProv _) = ReqNoProv False

p6 = p1 {j = False}

main = print p6


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE PatternSynonyms, GADTs, ViewPatterns #-}

-- Pattern synonyms

module ShouldCompile where

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

f :: (Show a) => a -> Bool
f = undefined

pattern P{x} <- MkT (f -> True) x


{-# LANGUAGE PatternSynonyms #-}

module T10747 where

pattern head `Cons` tail = head : tail


module T10897 where
import T10897a

Single y = True


{-# LANGUAGE PatternSynonyms #-}
module T10897a where
pattern Single :: a -> a
pattern Single x = x


module T10997 where

import T10997a

foo :: Exp a -> String
foo Tru = "True"


{-# LANGUAGE GADTs, PatternSynonyms #-}

module T10997a where

data Exp ty where
  LitB :: Bool -> Exp Bool

pattern Tru :: () => b ~ Bool => Exp b
pattern Tru = LitB True


module T10997_1 where

import T10997_1a

{- With ghc-7.10.2:

    The interface for â€˜T10997aâ€™
    Declaration for Just'
    Pattern synonym Just':
    Iface type variable out of scope:  k
    Cannot continue after interface file error
-}

bar :: (Showable a) => Maybe a -> Maybe a
bar (Just' a) = Just' a


{-# LANGUAGE PatternSynonyms, ViewPatterns, ConstraintKinds, TypeFamilies, PolyKinds, KindSignatures #-}
module T10997_1a where

import Data.Kind

type family Showable (a :: k) :: Constraint where
  Showable (a :: Type) = (Show a)
  Showable a           = ()

extractJust :: Maybe a -> (Bool, a)
extractJust (Just a) = (True, a)
extractJust _        = (False, undefined)

pattern Just' :: Showable a => a -> (Maybe a)
pattern Just' a <- (extractJust -> (True, a)) where
  Just' a = Just a


{-# LANGUAGE PatternSynonyms, GADTs #-}
{-# OPTIONS_GHC -fwarn-missing-pattern-synonym-signatures #-}

{-
Test the printing of pattern synonym types (pprPatSynType)
We test all valid combinations of:
    universal type variables      yes/no
    "required" context            yes/no
    existential type variables    yes/no
    "provided" context            yes/no
-}

module T11213 where

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

pattern P         <-  True
pattern Pe    x   <-  MkEx x
pattern Pu    x   <-  x
pattern Pue   x y <- (x, MkEx y)
pattern Pur   x   <-  [x, 1]
pattern Purp  x y <- ([x, 1], MkUnivProv y)
pattern Pure  x y <- ([x, 1], MkEx y)
pattern Purep x y <- ([x, 1], MkExProv y)
pattern Pep   x   <-  MkExProv x
pattern Pup   x   <-  MkUnivProv x
pattern Puep  x y <- (MkExProv x, y)


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

module T11224b where

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

-- Should be fine!
-- pattern P :: c -> d -> T d
pattern P :: forall d. forall c. c -> d -> T d
pattern P x y <- MkT x y


{-# LANGUAGE PatternSynonyms, RecordWildCards #-}
module T11283 where
data P = MkP Bool
pattern S{x} = MkP x
d = S{x = True}
e = S{..}
f S{x=x} = x


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ViewPatterns #-}

module Bug where

data AST s a
  where
    Sym  :: s a -> AST s a
    (:$) :: AST s (a -> b) -> AST s a -> AST s b

data A sig where A :: A (a -> a)
data B sig where B :: B (a -> a)

data AB a
  where
    AA :: A a -> AB a
    BB :: B a -> AB a

class Prj s where prj :: AB a -> Maybe (s a)

instance Prj A
  where
    prj (AA s) = Just s
    prj _      = Nothing

instance Prj B
  where
    prj (BB s) = Just s
    prj _      = Nothing

pattern SymP s <- Sym (prj -> Just s)

fun :: AST AB a -> AST AB a
fun (SymP A :$ _) = undefined
fun (SymP B :$ _) = undefined


{-# LANGUAGE PatternSynonyms, TypeApplications, ScopedTypeVariables, ViewPatterns,
             AllowAmbiguousTypes #-}

module T11351 where

import GHC.TypeLits
import Data.Proxy

symbol :: forall s. KnownSymbol s => String
symbol = symbolVal @s Proxy

-- Not in scope: type variable â€˜sâ€™
-- Not in scope: type variable â€˜sâ€™
pattern Symbol :: forall s. KnownSymbol s => String
pattern Symbol <- ((== symbol @s) -> True) where
         Symbol = symbol @s

-- â€¢ Could not deduce (KnownSymbol n0)
--     arising from a use of â€˜symbolValâ€™
--   from the context: KnownSymbol s
--     bound by the type signature for pattern synonym â€˜Symbolâ€™:
--                String
pattern Symbol2 :: forall s. KnownSymbol s => String
pattern Symbol2 <- ((== symbolVal (Proxy :: Proxy s)) -> True)


{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module T11367 where

pattern A :: Int -> String
pattern A n <- (read -> n) where
        A 0 = "hi"
        A 1 = "bye"


{-# LANGUAGE PatternSynonyms #-}

module T11633 where

data ARecord = ARecord {anInt :: Int, aString :: String}

-- This works...
pattern AGoodPat :: Int -> String -> ARecord
pattern AGoodPat n s = ARecord {anInt=n, aString=s}

pattern ABadPat :: Int -> String -> ARecord
pattern ABadPat n s = ARecord {aString=s, anInt=n}


{-# LANGUAGE PatternSynonyms #-}

module T11727 where

pattern A,B :: Int
pattern A = 5
pattern B = 5


{-# LANGUAGE PatternSynonyms #-}
module Main where

import T11959Lib (Vec2(..), pattern (:>))

main = return ()


{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module T11959Lib (Vec2(Nil,(:>)), pattern (:>)) where

newtype Vec2 a = Vec2 {unvec2 :: [a]}

pattern Nil :: Vec2 a
pattern Nil = Vec2 []

pattern (:>) x xs <- ((\ys -> (head $ unvec2 ys,Vec2 . tail $ unvec2 ys)) -> (x,xs))
  where
    (:>) x xs = Vec2 (x:unvec2 xs)


{-# LANGUAGE ViewPatterns, PatternSynonyms #-}

module T11977 where

-- A pattern synonym for a /function/

pattern F :: b -> Char -> b
pattern F a <- (($ 'a') -> a)


{-# LANGUAGE NamedFieldPuns, PatternSynonyms, RecordWildCards #-}
module T11987 where

import T11987a

-- works
namedFieldPuns :: (Int,Int)
namedFieldPuns = let { x = 1; y = 2 } in Point { x, y }

-- error: Pattern synonym â€˜Pointâ€™ used as a data constructor
recordWildCards :: (Int,Int)
recordWildCards = let { x = 1; y = 2 } in Point { .. }


{-# LANGUAGE NamedFieldPuns, PatternSynonyms, RecordWildCards #-}
module T11987a where

pattern Point :: Int -> Int -> (Int, Int)
pattern Point{x, y} = (x, y)

-- works
sameFile :: (Int,Int)
sameFile = let { x = 1; y = 2 } in Point { .. }


{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PatternSynonyms #-}
module T12094 where

import GHC.Exts (Int#)

pattern Zero :: Int# -- commenting out this line works
pattern Zero <- 0#


{-# LANGUAGE PatternSynonyms #-}

module T12108 where

type Endo a = a -> a

pattern Id :: Endo a
pattern Id x = x


{-# OPTIONS_GHC -Wmissing-pattern-synonym-signatures #-}
{-# LANGUAGE PatternSynonyms #-}

module T12484 where

pattern RP x = (x, True)


{-# LANGUAGE PatternSynonyms, ViewPatterns #-}

module T12489 where
pattern P :: a -> b
pattern P a <- (undefined -> a)


{-# LANGUAGE NoImplicitPrelude, PatternSynonyms #-}
{-# OPTIONS_GHC -Wall #-}
module Test where

x :: ()
x = ()

pattern Point2 :: () -> () -> ((), ())
pattern Point2 x y = (x, y)

pattern Point :: () -> () -> ((), ())
pattern Point{x1, y1} = (x1, y1)


{-# Language ViewPatterns, TypeOperators, KindSignatures, PolyKinds,
             StandaloneDeriving, GADTs, RebindableSyntax,
             RankNTypes, LambdaCase, PatternSynonyms, TypeApplications #-}

module T12698 where

import GHC.Types
import Prelude hiding ( fromInteger )
import Data.Type.Equality hiding ((:~~:)(..))
import Data.Kind
import qualified Prelude

class Ty (a :: k) where ty :: T a
instance Ty Int where ty = TI
instance Ty Bool where ty = TB
instance Ty a => Ty [a] where ty = TA TL ty
instance Ty [] where ty = TL
instance Ty (,) where ty = TP

data AppResult (t :: k) where
  App :: T a -> T b -> AppResult (a b)

data T :: forall k. k -> Type where
  TI :: T Int
  TB :: T Bool
  TL :: T []
  TP :: T (,)
  TA :: T f -> T x -> T (f x)
deriving instance Show (T a)

splitApp :: T a -> Maybe (AppResult a)
splitApp = \case
  TI -> Nothing
  TB -> Nothing
  TL -> Nothing
  TP -> Nothing
  TA f x -> Just (App f x)

data (a :: k1) :~~: (b :: k2) where
  HRefl :: a :~~: a

eqT :: T a -> T b -> Maybe (a :~~: b)
eqT a b =
  case (a, b) of
    (TI, TI) -> Just HRefl
    (TB, TB) -> Just HRefl
    (TL, TL) -> Just HRefl
    (TP, TP) -> Just HRefl

pattern List :: () => [] ~~ b => T b
pattern List <- (eqT (ty @(Type -> Type) @[]) -> Just HRefl)
  where List = ty

pattern Int :: () => Int ~~ b => T b
pattern Int <- (eqT (ty @Type @Int) -> Just HRefl)
  where Int = ty

pattern (:<->:) :: () => fx ~ f x => T f -> T x -> T fx
pattern f :<->: x <- (splitApp -> Just (App f x))
  where f :<->: x = TA f x

pattern Foo <- List :<->: Int


module T12746 where

import T12746A

foo a = case a of
        Foo -> True
        _ -> False


{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}
module T12746A where

pattern Foo :: Int
pattern Foo = 0x00000001


{-# LANGUAGE PolyKinds , GADTs, ScopedTypeVariables, PatternSynonyms,
      ViewPatterns #-}

module T12968 where

data TypeRep (a :: k)

data TRAppG (fun :: k2) where
  TRAppG :: forall k1 k2 (a :: k1 -> k2) (b :: k1) .
            TypeRep a -> TypeRep b -> TRAppG (a b)

pattern TRApp :: forall k2 (fun :: k2). ()
              => forall k1 (a :: k1 -> k2) (b :: k1). (fun ~ a b)
              => TypeRep a -> TypeRep b -> TypeRep fun
pattern TRApp a b <- ((undefined :: TypeRep fun -> TRAppG fun) -> TRAppG a b)


{-# LANGUAGE PatternSynonyms #-}

module T13349b where

pattern Nada = Nothing

-- Not orphan because it mentions the locally-defined Nada.
{-# COMPLETE Just, Nada #-}


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

module T13441 where

import Data.Functor.Identity

data FList f xs where
  FNil :: FList f '[]
  (:@) :: f x -> FList f xs -> FList f (x ': xs)

data Nat = Zero | Succ Nat

type family Length (xs :: [k]) :: Nat where
  Length '[]       = Zero
  Length (_ ': xs) = Succ (Length xs)

type family Replicate (n :: Nat) (x :: a) = (r :: [a]) where
  Replicate Zero     _ = '[]
  Replicate (Succ n) x = x ': Replicate n x

type Vec n a = FList Identity (Replicate n a)

-- Using explicitly-bidirectional pattern
pattern (:>) :: forall n a. n ~ Length (Replicate n a)
             => forall m. n ~ Succ m
             => a -> Vec m a -> Vec n a
pattern x :> xs <- Identity x :@ xs
  where
    x :> xs = Identity x :@ xs

-- Using implicitly-bidirectional pattern
pattern (:>>) :: forall n a. n ~ Length (Replicate n a)
             => forall m. n ~ Succ m
             => a -> Vec m a -> Vec n a
pattern x :>> xs = Identity x :@ xs


{-# LANGUAGE PatternSynonyms, GADTs #-}
module T13441a where

data S where
  MkS :: Eq a => [a] -> S

-- Unidirectional pattern binding;
-- the existential is more specific than needed
-- c.f. T13441b
pattern P :: () => Eq x => x -> S
pattern P x <- MkS x


{-# LANGUAGE PatternSynonyms, GADTs #-}
module T13441a where

data S where
  MkS :: Eq a => [a] -> S

-- Implicitly-bidirectional pattern binding;
-- the existential is more specific than needed,
-- and hence should be rejected
-- c.f. T13441a
pattern P :: () => Eq x => x -> S
pattern P x = MkS x


{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
module T13454 where

pattern MkOp :: Op -> Exp -> Exp -> Exp
pattern MkOp {(Â·), a, b} <- (splitOp -> Just ((Â·), a, b))
  where MkOp (Â·) a b      = a Â· b

data Exp = Val Int | Add Exp Exp | Mul Exp Exp deriving Show

type Op = Exp -> Exp -> Exp

splitOp :: Exp -> Maybe (Op, Exp, Exp)
splitOp (Add a b) = Just (Add, a, b)
splitOp (Mul a b) = Just (Mul, a, b)
splitOp _         = Nothing


{-# LANGUAGE TypeFamilies, ConstraintKinds, PatternSynonyms, RankNTypes #-}

module T13752 where

newtype Arrange = Arrange {getArrange :: [Int] -> [Int]}

pattern Heh :: (c ~ ((~) Int)) => (forall a. c a => [a] -> [a]) -> Arrange
-- pattern Heh :: (forall a. (Int ~ a) => [a] -> [a]) -> Arrange
pattern Heh f <- Arrange f


{-# LANGUAGE PatternSynonyms, RankNTypes #-}

module T13752a where

data T = MkT (forall a. a->a)

pattern P :: (Int -> Int) -> T
pattern P x <- MkT x


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module T13768 where

import Data.Kind (Type)

data NS (f :: k -> Type) (xs :: [k]) = NS Int

data IsNS (f :: k -> Type) (xs :: [k]) where
  IsZ :: f x -> IsNS f (x ': xs)
  IsS :: NS f xs -> IsNS f (x ': xs)

isNS :: NS f xs -> IsNS f xs
isNS = undefined

pattern Z :: () => (xs' ~ (x ': xs)) => f x -> NS f xs'
pattern Z x <- (isNS -> IsZ x)

pattern S :: () => (xs' ~ (x ': xs)) => NS f xs -> NS f xs'
pattern S p <- (isNS -> IsS p)

{-# COMPLETE Z, S #-}

data SList :: [k] -> Type where
  SNil  :: SList '[]
  SCons :: SList (x ': xs)

go :: SList ys -> NS f ys -> Int
go SCons (Z _) = 0
go SCons (S _) = 1
go SNil  _     = error "inaccessible"


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

import T14058a (Sing(..))

foo :: Sing ('[ '[] ] :: [[a]])
foo = SCons SNil SNil


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T14058a (Sing(.., SCons)) where

data family Sing (a :: k)

data instance Sing (z :: [a]) where
  SNil :: Sing '[]
  (:%) :: Sing x -> Sing xs -> Sing (x:xs)

pattern SCons :: forall a (z :: [a]). ()
              => forall (x :: a) (xs :: [a]). z ~ (x:xs)
              => Sing x -> Sing xs -> Sing z
pattern SCons x xs = (:%) x xs
{-# COMPLETE SNil, SCons #-}