{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ExplicitForAll #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module T14326 where

data E a b = L' a | R b
pattern L :: forall b a. a -> E a b
pattern L a = L' a
{-# COMPLETE L, R #-}

testMono :: E (E Int Int) Int -> Int
testMono x = case x of
  L (L _) -> 0
  L (R _) -> 1
  R _ -> 2

testPoly :: E (E a b) c -> Int
testPoly x = case x of
  L (L _) -> 0
  L (R _) -> 1
  R _ -> 2


{-# Language PatternSynonyms, ViewPatterns, GADTs, ConstraintKinds, RankNTypes, KindSignatures, PolyKinds, ScopedTypeVariables, DataKinds #-}

module T14498 where

import Type.Reflection
import Data.Kind

data Dict c where Dict :: c => Dict c

asTypeable :: TypeRep a -> Dict (Typeable a)
asTypeable rep =
  withTypeable rep
    Dict

pattern Typeable :: () => Typeable a => TypeRep a
pattern Typeable <- (asTypeable -> Dict)
  where Typeable = typeRep

data N = O | S N

type SN = (TypeRep :: N -> Type)

pattern SO = (Typeable :: TypeRep (O::N))

pattern SS ::
     forall k' (t :: k').
     ()
  => forall kk (a :: kk -> k') (n :: kk).
     (t ~ a n)
  =>
  TypeRep n -> TypeRep t
pattern SS n <- (App (Typeable :: TypeRep (a ::kk -> k')) n)


{-# Language RankNTypes, ViewPatterns, PatternSynonyms, TypeOperators, ScopedTypeVariables,
             KindSignatures, PolyKinds, DataKinds, TypeFamilies, GADTs #-}

module T14552 where

import Data.Kind
import Data.Proxy

data family Sing a

type a --> b = (a, b) -> Type

type family F (f::a --> b) (x::a) :: b

newtype Limit :: (k --> Type) -> Type where
  Limit :: (forall xx. Proxy xx -> F f xx) -> Limit f

data Exp :: [Type] -> Type -> Type where
  TLam :: (forall aa. Proxy aa -> Exp xs (F w aa))
        -> Exp xs (Limit w)

pattern FOO f <- TLam (($ Proxy) -> f)

{-
TLam :: forall (xs::[Type]) (b::Type).   -- Universal
         forall k (w :: k --> Type).      -- Existential
         (b ~ Limit w) =>
         => (forall (aa :: k). Proxy aa -> Exp xs (F w aa))
         -> Exp xs b

-}

{-
mfoo :: Exp xs b
     -> (forall k (w :: k --> Type).
         (b ~ Limit w)
         => Exp xs (F w aa)
         -> r)
     -> r
mfoo scrut k = case srcut of
                 TLam g -> k (g Proxy)
-}


{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern Single :: a -> [a]
pattern Single x = [x]


{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}
{-# LANGUAGE PatternSynonyms #-}

module ShouldCompile where

pattern Single :: Show a => a -> [a]
pattern Single x = [x]

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


{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern SinglePair :: (a, a) -> [(a, a)]
pattern SinglePair x = [x]

f :: (Show a) => [(a, a)] -> String
f (SinglePair x) = show x


{-# LANGUAGE PolyKinds, KindSignatures, PatternSynonyms, DataKinds, GADTs  #-}

module T8966 where

import Data.Kind (Type)

data NQ :: [k] -> Type where
   D :: NQ '[a]

pattern Q = D


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

import Data.Kind (Type)

data X :: (Type -> Type) -> Type -> Type where
  Y :: f a -> X f (Maybe a)

pattern C :: a -> X Maybe (Maybe a)
pattern C x = Y (Just x)


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

import Data.Kind (Type)

data X :: (Type -> Type) -> Type -> Type where
  Y :: (Show a) => f a -> X f (Maybe a)

pattern C :: (Show (a, Bool)) => a -> X Maybe (Maybe (a, Bool))
pattern C x = Y (Just (x, True))


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

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

pattern P :: T Bool b
pattern P <- MkT True

pattern D :: a -> T (Maybe a) Bool
pattern D x = MkT (Just x)


{-# LANGUAGE PatternSynonyms #-}

module T9023 where

pattern P a b = Just (a, b)
foo P{} = True


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

pattern P = 0#


{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Copyright   :  (C) 2014 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  experimental
-- Portability :  PatternSynonyms
--
-- Half-precision floating-point values. These arise commonly in GPU work
-- and it is useful to be able to compute them and compute with them on the
-- CPU as well.
----------------------------------------------------------------------------

module T9857
  ( Half(..)
  , isZero
  , fromHalf
  , toHalf
  , pattern POS_INF
  , pattern NEG_INF
  , pattern QNaN
  , pattern SNaN
  , pattern HALF_MIN
  , pattern HALF_NRM_MIN
  , pattern HALF_MAX
  , pattern HALF_EPSILON
  , pattern HALF_DIG
  , pattern HALF_MIN_10_EXP
  , pattern HALF_MAX_10_EXP
  ) where

import Data.Bits
import Data.Function (on)
import Data.Typeable
import Foreign.C.Types
import Foreign.Storable
import Text.Read

-- | Convert a 'Float' to a 'Half' with proper rounding, while preserving NaN and dealing appropriately with infinity
foreign import ccall unsafe "hs_floatToHalf" toHalf :: Float -> Half
{-# RULES "toHalf"  realToFrac = toHalf #-}

-- | Convert a 'Half' to a 'Float' while preserving NaN
foreign import ccall unsafe "hs_halfToFloat" fromHalf :: Half -> Float
{-# RULES "fromHalf" realToFrac = fromHalf #-}

newtype {-# CTYPE "unsigned short" #-} Half = Half { getHalf :: CUShort } deriving (Storable, Typeable)

instance Show Half where
  showsPrec d h = showsPrec d (fromHalf h)

instance Read Half where
  readPrec = fmap toHalf readPrec

instance Eq Half where
  (==) = (==) `on` fromHalf

instance Ord Half where
  compare = compare `on` fromHalf

instance Real Half where
  toRational = toRational . fromHalf

instance Fractional Half where
  fromRational = toHalf . fromRational
  recip = toHalf . recip . fromHalf
  a / b = toHalf $ fromHalf a / fromHalf b

instance RealFrac Half where
  properFraction a = case properFraction (fromHalf a) of
    (b, c) -> (b, toHalf c)
  truncate = truncate . fromHalf
  round = round . fromHalf
  ceiling = ceiling . fromHalf
  floor = floor . fromHalf

instance Floating Half where
  pi = toHalf pi
  exp = toHalf . exp . fromHalf
  sqrt = toHalf . sqrt . fromHalf
  log = toHalf . log . fromHalf
  a ** b = toHalf $ fromHalf a ** fromHalf b
  logBase a b = toHalf $ logBase (fromHalf a) (fromHalf b)
  sin = toHalf . sin . fromHalf
  tan = toHalf . tan . fromHalf
  cos = toHalf . cos . fromHalf
  asin = toHalf . asin . fromHalf
  atan = toHalf . atan . fromHalf
  acos = toHalf . acos . fromHalf
  sinh = toHalf . sinh . fromHalf
  tanh = toHalf . tanh . fromHalf
  cosh = toHalf . cosh . fromHalf
  asinh = toHalf . asinh . fromHalf
  atanh = toHalf . atanh . fromHalf
  acosh = toHalf . acosh . fromHalf

instance RealFloat Half where
  floatRadix  _ = 2
  floatDigits _ = 11
  decodeFloat = decodeFloat . fromHalf
  isInfinite (Half h) = unsafeShiftR h 10 .&. 0x1f >= 32
  isIEEE _ = isIEEE (undefined :: Float)
  atan2 a b = toHalf $ atan2 (fromHalf a) (fromHalf b)
  isDenormalized (Half h) = unsafeShiftR h 10 .&. 0x1f == 0 && h .&. 0x3ff /= 0
  isNaN (Half h) = unsafeShiftR h 10 .&. 0x1f == 0x1f && h .&. 0x3ff /= 0
  isNegativeZero (Half h) = h == 0x8000
  floatRange _ = (16,-13)
  encodeFloat i j = toHalf $ encodeFloat i j
  exponent = exponent . fromHalf
  significand = toHalf . significand . fromHalf
  scaleFloat n = toHalf . scaleFloat n . fromHalf

-- | Is this 'Half' equal to 0?
isZero :: Half -> Bool
isZero (Half h) = h .&. 0x7fff == 0

-- | Positive infinity
pattern POS_INF = Half 0x7c00

-- | Negative infinity
pattern NEG_INF = Half 0xfc00

-- | Quiet NaN
pattern QNaN    = Half 0x7fff

-- | Signalling NaN
pattern SNaN    = Half 0x7dff

-- | Smallest positive half
pattern HALF_MIN = 5.96046448e-08 :: Half

-- | Smallest positive normalized half
pattern HALF_NRM_MIN = 6.10351562e-05 :: Half

-- | Largest positive half
pattern HALF_MAX = 65504.0 :: Half

-- | Smallest positive e for which half (1.0 + e) != half (1.0)
pattern HALF_EPSILON = 0.00097656 :: Half

-- | Number of base 10 digits that can be represented without change
pattern HALF_DIG = 2

-- Minimum positive integer such that 10 raised to that power is a normalized half
pattern HALF_MIN_10_EXP = -4

-- Maximum positive integer such that 10 raised to that power is a normalized half
pattern HALF_MAX_10_EXP = 4

instance Num Half where
  a * b = toHalf (fromHalf a * fromHalf b)
  a - b = toHalf (fromHalf a - fromHalf b)
  a + b = toHalf (fromHalf a + fromHalf b)
  negate (Half a) = Half (xor 0x8000 a)
  abs = toHalf . abs . fromHalf
  signum = toHalf . signum . fromHalf
  fromInteger a = toHalf (fromInteger a)


{-# LANGUAGE PatternSynonyms, ScopedTypeVariables #-}

module T9867 where

pattern Nil = [] :: [a]


{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern Id x = x

Id x = True


{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternSynonyms #-}
module T9975a where

data Test = Test { x :: Int }
pattern Test wat = Test { x = wat }


{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE PatternSynonyms #-}
module T9975b where

data Test = Test { x :: Int }
pattern PTest wat = Test { x = wat }


module TransAssociated(A(..)) where

import Bundle (A(..))

foo = MkA 5
baz = NoA

qux (MkA x) = x
qux NoA = 0


{-# LANGUAGE PatternSynonyms, MagicHash, BangPatterns #-}
module ShouldCompile where

import GHC.Base

data Foo = MkFoo Int# Int#

pattern P x = MkFoo 0# x

f x = let !(P arg) = x in arg


-- Pattern synonyms
-- Universially-quantified type variables

{-# LANGUAGE PatternSynonyms #-}
module ShouldCompile where

pattern Single x <- [x]

singleTuple :: [a] -> [b] -> Maybe (a, b)
singleTuple (Single x) (Single y) = Just (x, y)
singleTuple _          _          = Nothing


{-# OPTIONS_GHC -Wincomplete-patterns #-}
module T13350 where

import Boolean

booleanToInt :: Boolean -> Int
booleanToInt F = 0
booleanToInt T = 1


{-# LANGUAGE PatternSynonyms #-}
module Boolean (Boolean, pattern F, pattern T) where

newtype Boolean = Boolean Int

pattern F, T :: Boolean
pattern F = Boolean 0
pattern T = Boolean 1
{-# COMPLETE F, T #-}


import Distribution.Simple
main = defaultMain


{-# LANGUAGE PatternSynonyms #-}
module ShouldFail where

-- This is now ok (following GHC proposal #94)
pattern P x y <- x@(Just y)


{-# LANGUAGE PatternSynonyms #-}

module Foo (MyClass(.., P)) where

pattern P = Nothing

class MyClass a where
  foo :: a -> Int


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

data Q = Q Int

data R = R

pattern P{x} = Q x


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

module Foo ( B(P) ) where

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

data A a = A a

data B a = B 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


module Foo(A(.., B)) where

data A = A | B


{-# LANGUAGE PatternSynonyms #-}

module Foo ( A(P) ) where

data A = A
data B = B

type C = B

pattern P :: C
pattern P = B


{-# LANGUAGE PatternSynonyms #-}

module Export (A(..,MyB), B(MyA), C(MyC)) where

data A = A

data B = B

pattern MyB = B

pattern MyA = A

data C a = C

pattern MyC = B


{-# LANGUAGE PatternSynonyms #-}
module Foo where

import ImportSyntax (A(.., B))


{-# LANGUAGE PatternSynonyms #-}
module ShouldFail where

varWithLocalPatSyn x = case x of
    P -> ()
  where
    pattern P = ()


{-# LANGUAGE PatternSynonyms #-}
module Foo where

pattern A { a } = Just a
pattern B { b } = Just b

foo :: Maybe a -> Maybe Bool
foo x = x { a = True, b = False }


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

pattern Single x = [(x :: Int)]

f :: [Bool] -> Bool
f (Single x) = x


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

data A = A

data B = B

pattern P :: () => (f ~ B) => f
pattern P = B


{-# LANGUAGE PatternSynonyms #-}
module Qux where

-- Make sure selectors aren't generated for normal synonyms

pattern Uni a = Just a

pattern a :+: b = (a, b)

qux = a (Just True)


{-# LANGUAGE PatternSynonyms, ExistentialQuantification #-}
module ExQuant where

data Showable = forall a . Show a => Showable a

pattern Nasty{a} = Showable a

qux = a (Showable True)

foo = (Showable ()) { a = True }


{-# LANGUAGE PatternSynonyms #-}

data MyRec = MyRec { foo :: Int, qux :: String }

pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}

updater,updater1, updater2 :: MyRec -> MyRec
updater a = a {f1 = 1 }

updater1 a = a {f1 = 1, qux = "two" }

updater2 a = a {f1 = 1, foo = 2 }


{-# LANGUAGE PatternSynonyms #-}
module RecordPats where

-- No updates
pattern Uni{a,b} <- (a, b)

foo = ("a","b") { a = "b" }


{-# LANGUAGE PatternSynonyms #-}
module RecordPats where

-- No updates
pattern Uni{a} <- Just a

qux = a (Just True)

qux2 (Uni b) = b

foo = Uni { a = "b" }


{-# LANGUAGE PatternSynonyms #-}
module Main where

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

data A = A deriving Show

p1 = Just True

p6 = p1 {j = A}

main = print p6


{-# LANGUAGE PatternSynonyms, ViewPatterns, EmptyCase #-}

pattern Id <- (id -> _) where


{-# LANGUAGE PatternSynonyms, GADTs #-}

module T10873 where

pattern Pat1 :: () => Show a => a -> Maybe a
pattern Pat1 x <- Just x

data T a where MkT :: (Ord a) => a -> T a
pattern Pat2 :: (Enum a) => Show a => a -> T a
pattern Pat2 x <- MkT x


{-# LANGUAGE PatternSynonyms, ExistentialQuantification, GADTSyntax, TypeFamilies #-}

module T11010 where

data Expr a where
  Fun :: String -> (a -> b) -> (Expr a -> Expr b)

pattern IntFun :: (a ~ Int) => String -> (a -> b) -> (Expr a -> Expr b)
pattern IntFun str f x = Fun str f x

-- Alternative syntax for pattern synonyms:
--   pattern
--     Suc :: () => (a ~ Int) => Expr a -> Expr Int
--     Suc n <- IntFun _     _     n where
--     Suc n =  IntFun "suc" (+ 1) n
pattern Suc :: (a ~ Int) => Expr a -> Expr Int
pattern Suc n <- IntFun _     _     n where
         Suc n =  IntFun "suc" (+ 1) n


{-# LANGUAGE PatternSynonyms, TypeFamilies #-}
module T11039 where

data A a = A a

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


{-# LANGUAGE PatternSynonyms, TypeFamilies #-}
module T11039a where

data A a = A a

-- This should succeed
pattern Q2 :: (A ~ f) => a -> f a
pattern Q2 a = A a


{-# LANGUAGE PatternSynonyms #-}
-- turn on with -fwarn-missing-pattern-synonym-signatures

module Foo where

-- Should warn because of missing signature
pattern T = True

pattern J a = Just a

pattern J1 a <- Just a

pattern J2{b} = Just b

pattern J3{c} <- Just c

pattern F :: Bool
pattern F = False


{-# LANGUAGE PatternSynonyms, DataKinds #-}

pattern A = True

class    F a
instance F A


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

{-
The following four pattern synonym declarations should give valid
error messages
-}

-- Check if we mention no explicit type signature (or the correct
-- signature "Eq a => Maybe a")
pattern Pat1 :: Eq a => Maybe a
pattern Pat1 <- Just 42

-- Check if we mention no explicit type signature (or the correct
-- signature "forall b. () => forall a. b ~ Bool => a -> b -> (b, T)")
data T where MkT :: a -> T
pattern Pat2 :: () => b ~ Bool => a -> b -> (b, T)
pattern Pat2 x y = (y, MkT x)

-- Check if we do not tell the user that we could not deduce (Show a)
-- from the "required" context. Also, check if we do not give the
-- possible fix that suggests to add (Show a) to the "required" context.
pattern Pat3 :: Eq a => Show a => a -> Maybe a
pattern Pat3 x <- Just x

-- Check if we return a valid error message concerning the missing
-- constraint (Num a) when the bidirectional pattern synonym is used
-- in an expression context
data S a where MkS :: (Num a, Show a) => a -> S a
pattern Pat4 :: (Eq a) => (Show a) => S a
pattern Pat4 = MkS 42


{-# LANGUAGE PatternSynonyms #-}
module ShouldFail where

pattern P :: a -> b -> Maybe (a,b)
pattern P :: foo => bar => blah -> urgh
pattern P x y = Just (x, y)


{-# LANGUAGE PatternSynonyms, ViewPatterns, TypeFamilies, KindSignatures #-}

module T12819 where

type family F a  -- F :: * -> *
data T :: (* -> *) -> *

pattern Q :: T F -> String
pattern Q x <- (undefined -> x)


{-# LANGUAGE PatternSynonyms #-}

module T13349 where

{-# COMPLETE False #-}


{-# Language PatternSynonyms #-}
module T13470 where

-- Used to suggest importing not
pattern XInstrProxy :: (Bool -> Bool) -> a
pattern XInstrProxy not <- _

-- Used to suggest 'tan' from another module
pattern P nan <- _

-- Should suggest the inscope similar variable
pattern P1 x12345 <- Just x123456

-- But not this one
x1234567 = True


{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
module T14112 where

pattern MyJust1 a = Just !a


{-# LANGUAGE PatternSynonyms #-}
module T14114 where

pattern Foo1 a <- (a,a)
pattern Foo2 a  = (a,a)
pattern Foo3 a <- (a,a) where
  Foo3 a = (a,a)


{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE PatternSynonyms #-}

module T14380 where

data Foo = Foo [Int]
pattern Bar :: Foo
pattern Bar = Foo []


{-# Language PatternSynonyms, ViewPatterns, GADTs, ConstraintKinds, RankNTypes,
             PolyKinds, ScopedTypeVariables, DataKinds, TypeOperators,
             TypeApplications, TypeFamilies, TypeFamilyDependencies #-}

module T14507 where

import Type.Reflection
import Data.Kind

foo :: TypeRep a -> (Bool :~~: k, TypeRep a)
foo rep = error "urk"

type family SING :: k -> Type where
  SING = (TypeRep :: Bool -> Type)

pattern RepN :: forall kk (a::kk). () => Bool~kk => SING a -> TypeRep (a::kk)
pattern RepN tr <- (foo -> ( HRefl :: Bool:~~:kk
                           , tr :: TypeRep (a::Bool)))

pattern SO x <- RepN (id -> x)


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Oops where

pattern What = True :: Maybe


{-# Language DataKinds, TypeOperators, PolyKinds, GADTs, PatternSynonyms #-}

module T15685 where

import Data.Kind

data NS f as where
 Here :: f a -> NS f (a:as)

data NP :: (k -> Type) -> ([k] -> Type) where
 Nil :: NP f '[]

pattern HereNil = Here Nil


{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# OPTIONS_GHC -fdefer-type-errors #-}
module T15692 where

data F x where
  FS :: F (f a) -> F a

pattern FS' = FS False


{-# Language RankNTypes, PatternSynonyms, TypeOperators, DataKinds, PolyKinds, KindSignatures, GADTs #-}

module T15694 where

import Data.Kind
import Data.Type.Equality

data Ctx :: Type -> Type where
 E     :: Ctx(Type)
 (:&:) :: a -> Ctx(as) -> Ctx(a -> as)

data ApplyT(kind::Type) :: kind ->  Ctx(kind) -> Type where
 AO :: a -> ApplyT(Type) a E
 AS :: ApplyT(ks)      (f a) ctx
    -> ApplyT(k -> ks) f     (a:&:ctx)

pattern ASSO :: () => forall ks k (f :: k -> ks) (a1 :: k) (ctx :: Ctx ks)
                             (ks1 :: Type) k1 (a2 :: k1) (ctx1 :: Ctx ks1) a3.
                     (kind ~ (k -> ks), a ~~ f, b ~~ (a1 :&: ctx),
                      ks ~ (k1 -> ks1), ctx ~~ (a2 :&: E),
                      ks1 ~ Type, f a1 a2 ~~ a3)
                   => a3 -> ApplyT kind a b

pattern ASSO a = AS (AS (AO a))


{-# Language RankNTypes, PatternSynonyms, DataKinds, PolyKinds, GADTs,
             TypeOperators, MultiParamTypeClasses, TypeFamilies,
             TypeSynonymInstances, FlexibleInstances, InstanceSigs, FlexibleContexts #-}

{-# Options_GHC -fdefer-type-errors #-}

module T15695 where

import Data.Kind
import Data.Type.Equality

data TyVar :: Type -> Type -> Type where
 VO :: TyVar (a -> as) a
 VS :: TyVar as a -> TyVar (b -> as) a

data NP :: (k -> Type) -> ([k] -> Type) where
 Nil :: NP f '[]
 (:*) :: f a -> NP f as -> NP f (a:as)

data NS :: (k -> Type) -> ([k] -> Type) where
 Here  :: f a     -> NS f (a:as)
 There :: NS f as -> NS f (a:as)

infixr 6 :&:
data Ctx :: Type -> Type where
 E     :: Ctx(Type)
 (:&:) :: a -> Ctx(as) -> Ctx(a -> as)

data NA a

type SOP(kind::Type) code = NS (NP NA) code

data ApplyT(kind::Type) :: kind ->  Ctx(kind) -> Type where
 AO :: a -> ApplyT(Type) a E
 AS :: ApplyT(ks)      (f a) ctx
    -> ApplyT(k -> ks) f     (a:&:ctx)

from' :: ApplyT(Type -> Type -> Type) Either ctx -> NS (NP NA) '[ '[VO] ]
from' (ASSO (Left  a)) = Here  (a :* Nil)
from' (ASSO (Right b)) = There (Here undefined)

pattern ASSO
  :: () =>
     forall (ks :: Type) k (f :: k -> ks) (a1 :: k) (ks1 :: Type) k1 (f1 :: k1 -> ks1) (a2 :: k1) a3.
     (kind ~ (k -> k1 -> Type), a ~~ f, b ~~ (a1 :&: a2 :&: E),
      f a1 ~~ f1, f1 a2 ~~ a3) =>
     a3 -> ApplyT kind a b
pattern ASSO a = AS (AS (AO a))


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DataKinds #-}

pattern PATTERN = ()

wrongLift :: PATTERN
wrongLift = undefined


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE DataKinds, KindSignatures, PolyKinds #-}

pattern PATTERN = ()

data Proxy (tag :: k) (a :: *)

wrongLift :: Proxy PATTERN ()
wrongLift = undefined


{-# LANGUAGE PatternSynonyms #-}
class C a where
    pattern P = ()


{-# LANGUAGE PatternSynonyms #-}
class C a where
    method :: a

instance C Int where
    pattern P = ()


{-# LANGUAGE PatternSynonyms, MagicHash #-}
{-# OPTIONS_GHC -Wunbanged-strict-patterns -Werror=unbanged-strict-patterns #-}
module ShouldFail where

import GHC.Base

data Foo = MkFoo Int# Int#

pattern P x = MkFoo 0# x

f x = let P arg = x in arg


{-# LANGUAGE PatternSynonyms, MagicHash #-}
module ShouldFail where

import GHC.Base

pattern P1 = 42#

x = P1


{-# LANGUAGE PatternSynonyms #-}
module ShouldFail where

pattern Head x = x:_


-- This is testing the printing of the builder really.
{-# LANGUAGE MagicHash, PatternSynonyms #-}
{-# OPTIONS_GHC -Werror -Wunbanged-strict-patterns #-}
module UnliftedPSBind where

import GHC.Exts

pattern P x = I# x

x = ()
  where P x = P 4#


{-# LANGUAGE PatternSynonyms #-}
module Main where

pattern First x <- x:_ where
  First x = foo [x, x, x]

foo :: [a] -> [a]
foo xs@(First x) = replicate (length xs + 1) x

main = mapM_ print $ First ()


{-# LANGUAGE PatternSynonyms #-}
module Main where

pattern First x <- x:_ where
  First x = [x]

main = mapM_ print $ First ()


{-# LANGUAGE PatternSynonyms #-}
module Main where

pattern P x y <- [x, y]

f (P True True) = True
f _             = False

g [True, True] = True
g _            = False

main = do
    mapM_ (print . f) tests
    putStrLn ""
    mapM_ (print . g) tests
  where
    tests = [ [True, True]
            , [True, False]
            , [True, True, True]
            -- , False:undefined
            ]


-- Pattern synonyms

{-# LANGUAGE PatternSynonyms, GADTs #-}
module Main 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

data Crazy = Crazy

instance Eq Crazy where
    _ == _ = False

main = do
    print (f $ MkT True True)
    print (f $ MkT True Crazy)


{-# LANGUAGE PatternSynonyms, MagicHash #-}
module Main where

import GHC.Base

pattern P1 <- 0#
pattern P2 <- 1#

f :: Int# -> Int#
f P1 = 42#
f P2 = 44#

g :: Int# -> Int
g P1 = 42
g P2 = 44

main = do
    print $ I# (f 0#)
    print $ I# (f 1#)
    print $ g 0#
    print $ g 1#


-- Pattern synonyms

{-# LANGUAGE PatternSynonyms #-}
module Main where

pattern Single x y = [(x,y)]

foo []                   = 0
foo [(True, True)]       = 1
foo (Single True True)   = 2
foo (Single False False) = 3
foo _                    = 4

main = mapM_ (print . foo) tests
  where
    tests = [ [(True, True)]
            , []
            , [(True, False)]
            , [(False, False)]
            , repeat (True, True)
            ]


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}

module Main where

pattern Bi{a, b} = (a, b)

foo = ("a","b")

pattern ReadP :: Read a => a -> String
pattern ReadP {readp} <- (read -> readp)

main = do
  print foo
  print (a foo)
  print (b foo)
  print (foo {a = "c"})
  print (foo {a = "fst", b = "snd"})

  print (readp @Int "5")


{-# LANGUAGE  PatternSynonyms, ViewPatterns #-}

module Main where

import Text.Read

pattern PRead :: Read a => () => a -> String
pattern PRead a <- (readMaybe -> Just a)

foo :: String -> Int
foo (PRead x)  = (x::Int)
foo (PRead xs) = sum (xs::[Int])
foo _ = 666

bar :: String -> Int
bar (readMaybe -> Just x)  = (x::Int)
bar (readMaybe -> Just xs) = sum (xs::[Int])
bar _ = 666

main :: IO ()
main = do
  print $ foo "1"       -- 1
  print $ foo "[1,2,3]" -- 666 -- ???
  print $ foo "xxx"     -- 666

  print $ bar "1"       -- 1
  print $ bar "[1,2,3]" -- 6
  print $ bar "xxx"     -- 666


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE QuasiQuotes #-}

import T13688Quasi

pattern A = [aQuoter|hello world|]

pattern B <- [aQuoter|hello world|]
  where B = [aQuoter|hello world|]

main :: IO ()
main = do
    print A
    case "hello world" of
      A -> putStrLn "good"
      _ -> putStrLn "bad"

    print B
    case "hello world" of
      B -> putStrLn "good"
      _ -> putStrLn "bad"


module T13688Quasi where

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

aQuoter :: QuasiQuoter
aQuoter =
    QuasiQuoter { quotePat  = return . LitP . StringL
                , quoteExp  = return . LitE . StringL
                , quoteType = undefined
                , quoteDec  = undefined
                }


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

type Maybe' t = (# t | () #)

pattern Just' :: a -> Maybe' a
pattern Just' x = (# x | #)

pattern Nothing' :: Maybe' a
pattern Nothing' = (# | () #)

foo x = case x of
  Nothing' -> putStrLn "nothing"
  Just' _ -> putStrLn "just"

main = do
  putStrLn "Nothing'"
  foo Nothing'

  putStrLn "Just'"
  foo (Just' "hello")


{-# LANGUAGE PatternSynonyms, MagicHash #-}
module Main where

import GHC.Base

pattern P1 <- 0
pattern P2 <- 1

f :: Int -> Int#
f P1 = 42#
f P2 = 44#

main = do
    print $ I# (f 0)
    print $ I# (f 1)


{-# LANGUAGE PatternSynonyms, MagicHash #-}
module Main where

import GHC.Base

pattern P1 = 42#

main = do
    print $ I# P1


-- This was added a general test of compiler performance.

-- Author: Austin Seipp

{-# OPTIONS_GHC -Wall #-}

{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveGeneric         #-}
{-# LANGUAGE DeriveTraversable     #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MagicHash             #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLists       #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}
module Naperian where

import qualified Prelude
import           Prelude hiding      ( lookup, length, replicate, zipWith )

import qualified Data.IntMap         as IntMap
import           Data.List           ( intercalate )
import           Data.Kind           ( Type, Constraint )
import           Control.Applicative ( liftA2 )
import qualified GHC.Exts            as L (IsList(..))
import           GHC.Prim
import           GHC.TypeLits

import qualified Data.Vector         as Vector

import           Data.Foldable       ( toList )

--------------------------------------------------------------------------------
-- Miscellaneous

-- | The finite set of type-bounded Naturals. A value of type @'Fin' n@ has
-- exactly @n@ inhabitants, the natural numbers from @[0..n-1]@.
data Finite :: Nat -> Type where
  Fin :: Int -> Finite n
  deriving (Eq, Show)

-- | Create a type-bounded finite number @'Fin' n@ from a runtime integer,
-- bounded to a statically known limit. If the input value @x > n@, then
-- @'Nothing'@ is returned. Otherwise, returns @'Just' (x :: 'Fin' n)@.
finite :: forall n. KnownNat n => Int -> Maybe (Finite n)
finite x = case (x > y) of
  True  -> Nothing
  False -> Just (Fin x)
  where y = fromIntegral (natVal' (proxy# :: Proxy# n))

-- | \"'Applicative' zipping\".
azipWith :: Applicative f => (a -> b -> c) -> f a -> f b -> f c
azipWith h xs ys = (pure h <*> xs) <*> ys

-- | Format a vector to make it look nice.
showVector :: [String] -> String
showVector xs = "<" ++ intercalate "," xs ++ ">"

--------------------------------------------------------------------------------
-- Pairs

-- | The cartesian product of @'a'@, equivalent to @(a, a)@.
data Pair a = Pair a a
  deriving (Show, Eq, Ord, Functor, Foldable, Traversable)

instance Applicative Pair where
  pure a = Pair a a
  Pair k g <*> Pair a b = Pair (k a) (g b)

--------------------------------------------------------------------------------
-- Vectors

newtype Vector (n :: Nat) a = Vector (Vector.Vector a)
  deriving (Eq, Ord, Functor, Foldable, Traversable)

instance Show a => Show (Vector n a) where
  show = showVector . map show . toList

instance KnownNat n => Applicative (Vector n) where
  pure  = replicate
  (<*>) = zipWith ($)

instance (KnownNat n, Traversable (Vector n)) => L.IsList (Vector n a) where
  type Item (Vector n a) = a
  toList = Data.Foldable.toList

  fromList xs = case fromList xs of
    Nothing -> error "Demanded vector of a list that wasn't the proper length"
    Just ys -> ys

tail :: Vector (n + 1) a -> Vector n a
tail (Vector v) = Vector (Vector.tail v)

fromList :: forall n a. KnownNat n => [a] -> Maybe (Vector n a)
fromList xs = case (Prelude.length xs == sz) of
  False -> Nothing
  True  -> Just (Vector $ Vector.fromList xs)
  where sz = fromIntegral (natVal' (proxy# :: Proxy# n)) :: Int

zipWith :: (a -> b -> c) -> Vector n a -> Vector n b -> Vector n c
zipWith f (Vector a) (Vector b) = Vector (Vector.zipWith f a b)

length :: forall n a. KnownNat n => Vector n a -> Int
length _ = fromIntegral $ natVal' (proxy# :: Proxy# n)

replicate :: forall n a. KnownNat n => a -> Vector n a
replicate v = Vector (Vector.replicate sz v) where
  sz = fromIntegral (natVal' (proxy# :: Proxy# n)) :: Int

index :: Vector n a -> Finite n -> a
index (Vector v) (Fin n) = (Vector.!) v n

viota :: forall n. KnownNat n => Vector n (Finite n)
viota = Vector (fmap Fin (Vector.enumFromN 0 sz)) where
  sz = fromIntegral (natVal' (proxy# :: Proxy# n)) :: Int

--------------------------------------------------------------------------------
-- Naperian functors

-- | Naperian functors.

-- A useful way of thinking about a Naperian functor is that if we have a value
-- of type @v :: f a@ for some @'Naperian' f@, then we can think of @f a@ as a
-- bag of objects, with the ability to pick out the @a@ values inside the bag,
-- for each and every @a@ inside @f@. For example, in order to look up a value
-- @a@ inside a list @[a]@, we could use a function @[a] -> Int -> a@, which is
-- exactly @'(Prelude.!!)'@
--
-- The lookup function acts like a logarithm of the @'Functor' f@. Intuitively,
-- a Haskell function @f :: a -> b@ acts like the exponential @b^a@ if we intuit
-- types as an algebraic quantity. The logarithm of some value @x = b^a@ is
-- defined as @log_b(x) = a@, so given @x@ and a base @b@, it finds the exponent
-- @a@. In Haskell terms, this would be like finding the input value @a@ to a
-- function @f :: a -> b@, given a @b@, so it is a reverse mapping from the
-- outputs of @f@ back to its inputs.
--
-- A @'Naperian'@ functor @f@ is precisely a functor @f@ such that for any value
-- of type @f a@, we have a way of finding every single @a@ inside.
class Functor f => Naperian f where
  {-# MINIMAL lookup, (tabulate | positions) #-}

  -- | The \"logarithm\" of @f@. This type represents the 'input' you use to
  -- look up values inside @f a@. For example, if you have a list @[a]@, and
  -- you want to look up a value, then you use an @'Int'@ to index into
  -- the list. In this case, @'Log' [a] = Int@. If you have a type-bounded
  -- Vector @'Vector' (n :: 'Nat') a@, then @'Log' ('Vector' n)@ is the
  -- range of integers @[0..n-1]@ (represented here as @'Finite' n@.)
  type Log f

  -- | Look up an element @a@ inside @f a@. If you read this function type in
  -- english, it says \"if you give me an @f a@, then I will give you a
  -- function, so you can look up the elements of @f a@ and get back an @a@\"
  lookup :: f a -> (Log f -> a)

  -- | Tabulate a @'Naperian'@. This creates @f a@ values by mapping the logarithm
  -- of @f@ onto every \"position\" inside @f a@
  tabulate :: (Log f -> a) -> f a
  tabulate h = fmap h positions

  -- | Find every position in the \"space\" of the @'Naperian' f@.
  positions :: f (Log f)
  positions = tabulate id

-- | The transposition of two @'Naperian'@ functors @f@ and @g@.
transpose :: (Naperian f, Naperian g) => f (g a) -> g (f a)
transpose = tabulate . fmap tabulate . flip . fmap lookup . lookup

instance Naperian Pair where
  type Log Pair = Bool
  lookup (Pair x y) b = if b then y else x

  positions = Pair False True

instance KnownNat n => Naperian (Vector n) where
  type Log (Vector n) = Finite n

  lookup    = index
  positions = viota

--------------------------------------------------------------------------------
-- Dimensions

class (Applicative f, Naperian f, Traversable f) => Dimension f where
  size :: f a -> Int
  size = Prelude.length . toList

instance               Dimension Pair       where size = const 2
instance KnownNat n => Dimension (Vector n) where size = length

inner :: (Num a, Dimension f) => f a -> f a -> a
inner xs ys = sum (liftA2 (*) xs ys)

matrix :: ( Num a
          , Dimension f
          , Dimension g
          , Dimension h
          ) => f (g a)
            -> g (h a)
            -> f (h a)
matrix xss yss = liftA2 (liftA2 inner) (fmap pure xss) (pure (transpose yss))

--------------------------------------------------------------------------------
-- Hyper-dimensional stuff

-- | Arbitrary-rank Hypercuboids, parameterized over their dimension.
data Hyper :: [Type -> Type] -> Type -> Type where
  Scalar :: a -> Hyper '[] a
  Prism  :: (Dimension f, Shapely fs) => Hyper fs (f a) -> Hyper (f : fs) a

point :: Hyper '[] a -> a
point (Scalar a) = a

crystal :: Hyper (f : fs) a -> Hyper fs (f a)
crystal (Prism x) = x

instance Show a => Show (Hyper fs a) where
  show = showHyper . fmap show where
    showHyper :: Hyper gs String -> String
    showHyper (Scalar s) = s
    showHyper (Prism x)  = showHyper (fmap (showVector . toList) x)

{--
class HyperLift f fs where
  hyper :: (Shapely fs, Dimension f) => f a -> Hyper (f : fs) a

instance HyperLift f '[] where
  hyper = Prism . Scalar

instance (Shapely fs, HyperLift f fs) => HyperLift f (f : fs) where
  hyper = Prism . (\x -> (hyper $ _ x))
--}

class Shapely fs where
  hreplicate :: a -> Hyper fs a
  hsize      :: Hyper fs a -> Int

instance Shapely '[] where
  hreplicate a = Scalar a
  hsize        = const 1

instance (Dimension f, Shapely fs) => Shapely (f : fs) where
  hreplicate a = Prism (hreplicate (pure a))
  hsize (Prism x) = size (first x) * hsize x

instance Functor (Hyper fs) where
  fmap f (Scalar a) = Scalar (f a)
  fmap f (Prism x)  = Prism (fmap (fmap f) x)

instance Shapely fs => Applicative (Hyper fs) where
  pure  = hreplicate
  (<*>) = hzipWith ($)

hzipWith :: (a -> b -> c) -> Hyper fs a -> Hyper fs b -> Hyper fs c
hzipWith f (Scalar a) (Scalar b) = Scalar (f a b)
hzipWith f (Prism x)  (Prism y)  = Prism (hzipWith (azipWith f) x y)

first :: Shapely fs => Hyper fs a -> a
first (Scalar a) = a
first (Prism x)  = head (toList (first x))

-- | Generalized transposition over arbitrary-rank hypercuboids.
transposeH :: Hyper (f : (g : fs)) a
           -> Hyper (g : (f : fs)) a
transposeH (Prism (Prism x)) = Prism (Prism (fmap transpose x))

-- | Fold over a single dimension of a Hypercuboid.
foldrH :: (a -> a -> a) -> a -> Hyper (f : fs) a -> Hyper fs a
foldrH f z (Prism x) = fmap (foldr f z) x

-- | Lift an unary function from values to hypercuboids of values.
unary :: Shapely fs => (a -> b) -> (Hyper fs a -> Hyper fs b)
unary = fmap

-- | Lift a binary function from values to two sets of hypercuboids, which can
-- be aligned properly.
binary :: ( Compatible fs gs
          , Max fs gs ~ hs
          , Alignable fs hs
          , Alignable gs hs
          ) => (a -> b -> c)
            -> Hyper fs a
            -> Hyper gs b
            -> Hyper hs c
binary f x y = hzipWith f (align x) (align y)

up :: (Shapely fs, Dimension f) => Hyper fs a -> Hyper (f : fs) a
up = Prism . fmap pure

-- | Generalized, rank-polymorphic inner product.
innerH :: ( Max fs gs ~  (f : hs)
          , Alignable fs (f : hs)
          , Alignable gs (f : hs)
          , Compatible fs gs
          , Num a
          ) => Hyper fs a
            -> Hyper gs a
            -> Hyper hs a
innerH xs ys = foldrH (+) 0 (binary (*) xs ys)

-- | Generalized, rank-polymorphic matrix product.
matrixH :: ( Num a
           , Dimension f
           , Dimension g
           , Dimension h
           ) => Hyper '[ g, f ] a
             -> Hyper '[ h, g ] a
             -> Hyper '[ h, f ] a
matrixH x y = case (crystal x, transposeH y) of
  (xs, Prism (Prism ys)) -> hzipWith inner (up xs) (Prism (up ys))

--------------------------------------------------------------------------------
-- Alignment

class (Shapely fs, Shapely gs) => Alignable fs gs where
  align :: Hyper fs a -> Hyper gs a

instance Alignable '[] '[] where
  align = id

instance (Dimension f, Alignable fs gs) => Alignable (f : fs) (f : gs) where
  align (Prism x) = Prism (align x)

instance (Dimension f, Shapely fs) => Alignable '[] (f : fs) where
  align (Scalar a) = hreplicate a

type family Max (fs :: [Type -> Type]) (gs :: [Type -> Type]) :: [Type -> Type] where
  Max '[]      '[]      = '[]
  Max '[]      (f : gs) = f : gs
  Max (f : fs) '[]      = f : fs
  Max (f : fs) (f : gs) = f : Max fs gs

type family Compatible (fs :: [Type -> Type]) (gs :: [Type -> Type]) :: Constraint where
  Compatible '[] '[]           = ()
  Compatible '[] (f : gs)      = ()
  Compatible (f : fs) '[]      = ()
  Compatible (f : fs) (f : gs) = Compatible fs gs
  Compatible a b               = TypeError (
         'Text "Mismatched dimensions!"
   ':$$: 'Text "The dimension " ':<>: 'ShowType a ':<>: 'Text " can't be aligned with"
   ':$$: 'Text "the dimension " ':<>: 'ShowType b)

--------------------------------------------------------------------------------
-- Flattened, sparse Hypercuboids

elements :: Shapely fs => Hyper fs a -> [a]
elements (Scalar a) = [a]
elements (Prism a)  = concat (map toList (elements a))

data Flat fs a where
  Flat :: Shapely fs => Vector.Vector a -> Flat fs a

instance Functor (Flat fs) where
  fmap f (Flat v) = Flat (fmap f v)

instance Show a => Show (Flat fs a) where
  show = showHyper . fmap show where
    showHyper :: Flat gs String -> String
    showHyper (Flat v) = showVector (toList v)

flatten :: Shapely fs => Hyper fs a -> Flat fs a
flatten hs = Flat (Vector.fromList (elements hs))

data Sparse fs a where
  Sparse :: Shapely fs => a -> IntMap.IntMap a -> Sparse fs a

unsparse :: forall fs a. Shapely fs => Sparse fs a -> Flat fs a
unsparse (Sparse e xs) = Flat (Vector.unsafeAccum (flip const) vs as)
  where
    as     = IntMap.assocs xs
    vs     = Vector.replicate l e
    l      = hsize (hreplicate () :: Hyper fs ())

--------------------------------------------------------------------------------
-- Examples

type Matrix n m v = Vector n (Vector m v)

example1 :: Int
example1 = inner v1 v2 where
  v1 = [ 1, 2, 3 ] :: Vector 3 Int
  v2 = [ 4, 5, 6 ] :: Vector 3 Int

example2 :: Matrix 2 2 Int
example2 = matrix m1 m2 where
  m1 = [ [ 1, 2, 3 ]
       , [ 4, 5, 6 ]
       ] :: Matrix 2 3 Int

  m2 = [ [ 9, 8 ]
       , [ 6, 5 ]
       , [ 3, 2 ]
       ] :: Matrix 3 2 Int

example3 :: Hyper '[] Int
example3 = innerH v1 v2 where
  v1 = Prism (Scalar [1, 2, 3]) :: Hyper '[Vector 3] Int
  v2 = Prism (Scalar [4, 5, 6]) :: Hyper '[Vector 3] Int

example4 :: Hyper '[Vector 2, Vector 2] Int
example4 = matrixH v1 v2 where
  x = [ [ 1, 2, 3 ]
      , [ 4, 5, 6 ]
      ] :: Matrix 2 3 Int

  y = [ [ 9, 8 ]
      , [ 6, 5 ]
      , [ 3, 2 ]
      ] :: Matrix 3 2 Int

  v1 = Prism (Prism (Scalar x)) :: Hyper '[Vector 3, Vector 2] Int
  v2 = Prism (Prism (Scalar y)) :: Hyper '[Vector 2, Vector 3] Int