{-# LANGUAGE MagicHash #-}
module Main where

import Control.Concurrent
import Control.Exception
import Foreign
import Foreign.C
import GHC.Conc
import GHC.Prim

-- Sample code demonstrating proper use of hs_try_putmvar()

main = do
   makeExternalCall >>= print
   threadDelay 100000

makeExternalCall :: IO CInt
makeExternalCall = mask_ $ do
  mvar <- newEmptyMVar
  sp <- newStablePtrPrimMVar mvar -- freed by hs_try_takemvar()
  fp <- mallocForeignPtr
  withForeignPtr fp $ \presult -> do
    (cap,_) <- threadCapability =<< myThreadId
    scheduleCallback sp cap presult
    takeMVar mvar `onException` forkIO (do takeMVar mvar; touchForeignPtr fp)
      -- the C callback will still run if takeMVar is interrupted, so the
      -- exception handler keeps the result memory alive long enough.
    peek presult

foreign import ccall "scheduleCallback"
  scheduleCallback :: StablePtr PrimMVar
                   -> Int
                   -> Ptr CInt
                   -> IO ()


{-# LANGUAGE MagicHash #-}
module Main where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Foreign hiding (void)
import Foreign.C
import GHC.Conc
import GHC.Prim
import System.Environment

-- Measure raw throughput, for M threads that each do N calls to C
-- that call back to hs_try_putmvar() or the foreign export equivalent

main = do
   args <- getArgs
   case args of
     ["1",n,m] -> experiment2 (read m) (experiment1 (read n))
     ["2",n,m] -> experiment2 (read m) (experiment1FE (read n))

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

experiment1 :: Int -> IO ()
experiment1 n = mask_ $ do
  mvar <- newEmptyMVar
  (cap,_) <- threadCapability =<< myThreadId
  replicateM_ n $ do
    sp <- newStablePtrPrimMVar mvar
    externalPutMVar sp cap
    takeMVar mvar

foreign import ccall "externalPutMVar"
  externalPutMVar :: StablePtr PrimMVar
                  -> Int
                  -> IO ()

experiment1FE :: Int -> IO ()
experiment1FE n = do
  mvar <- newEmptyMVar
  (cap,_) <- threadCapability =<< myThreadId
  bracket (newStablePtr mvar) freeStablePtr $ \sp -> do
    replicateM_ n $ do externalPutMVarFE sp cap; takeMVar mvar

foreign import ccall "externalPutMVarFE"
  externalPutMVarFE :: StablePtr (MVar ())
                    -> Int
                   -> IO ()

callbackPutMVar :: StablePtr (MVar ()) -> IO ()
callbackPutMVar sp = do
  mvar <- deRefStablePtr sp
  void $ tryPutMVar mvar ()

foreign export ccall callbackPutMVar :: StablePtr (MVar ()) -> IO ()

-- -----------------------------------------------------------------------------
-- Perform M copies of experiment1 concurrently

experiment2 :: Int -> IO () -> IO ()
experiment2 m exp = do
  mvars <- replicateM m $ do
    m <- newEmptyMVar
    forkFinally exp (\_ -> putMVar m ())
    return m
  mapM_ takeMVar mvars


{-# LANGUAGE MagicHash #-}
module Main where

import Control.Concurrent
import Control.Exception
import Control.Monad
import Foreign hiding (void)
import Foreign.C
import GHC.Conc
import GHC.MVar (MVar(..))
import GHC.Prim
import System.Environment
import System.Exit

-- Measure C to Haskell callback throughput under a workload with
-- several dimensions:
--
--  * X callback queues (each managed by an OS thread in C)
--  * each queue has Y Haskell threads, each making Z requests
--
-- And we can run the whole thing in two ways:
--  * With the callbacks calling into a foreign export
--  * With the callbacks using hs_try_putmvar()
--
-- Example results (using WAY=threaded2)
--
--  hs_try_putmvar003 1 64 16 500 +RTS -s -N4    1.10s
--  hs_try_putmvar003 2 64 16 500 +RTS -s -N4    9.88s
--
-- hs_try_putmvar() is 9x faster with these parameters.

main = do
   when (not rtsSupportsBoundThreads) $
     die "This test requires -threaded"
   args <- getArgs
   case args of
     ["1",x,y,z] -> experiment False (read x) (read y) (read z)
     ["2",x,y,z] -> experiment True (read x) (read y) (read z)

makeExternalCall :: Ptr CallbackQueue -> IO CInt
makeExternalCall q = mask_ $ do
  mvar <- newEmptyMVar
  sp <- newStablePtrPrimMVar mvar
  fp <- mallocForeignPtr
  (cap,_) <- threadCapability =<< myThreadId
  withForeignPtr fp $ \presult -> do
    scheduleCallback q sp cap presult
    takeMVar mvar `onException` forkIO (do takeMVar mvar; touchForeignPtr fp)
    peek presult

data CallbackQueue

foreign import ccall "mkCallbackQueue"
  mkCallbackQueue :: Int -> Int -> IO (Ptr CallbackQueue)

foreign import ccall "destroyCallbackQueue"
  destroyCallbackQueue :: Ptr CallbackQueue -> IO ()

foreign import ccall "scheduleCallback"
  scheduleCallback :: Ptr CallbackQueue
                   -> StablePtr PrimMVar
                   -> Int
                   -> Ptr CInt
                   -> IO ()

callbackPutMVar :: StablePtr PrimMVar -> IO ()
callbackPutMVar sp = do
  mvar <- deRefStablePtr sp
  void $ tryPutMVar (MVar (unsafeCoerce# mvar)) ()

foreign export ccall callbackPutMVar :: StablePtr PrimMVar -> IO ()

-- Make
--   * x callback queues, each with
--   * y threads, doing
--   * z requests each
experiment :: Bool -> Int -> Int -> Int -> IO ()
experiment use_foreign_export x y z = do
  mvars <- replicateM x $ async $ do
    bracket (mkCallbackQueue (fromEnum use_foreign_export) (z*y))
            destroyCallbackQueue $ \q -> do
      mvars <- replicateM y $ async $
        replicateM_ z $ void $ makeExternalCall q
      mapM_ takeMVar mvars
  mapM_ takeMVar mvars

async :: IO () -> IO (MVar ())
async io = do
  m <- newEmptyMVar
  forkFinally io (\_ -> putMVar m ())
  return m


import Control.Exception
import Text.Printf

-- Test all the various combinations of nesting mask/uninterruptibleMask

main = do
  stat 1 Unmasked
  mask_ $ stat 2 MaskedInterruptible
  mask $ \restore -> do
    stat 3 MaskedInterruptible
    restore $ stat 4 Unmasked
    restore $ restore $ stat 5 Unmasked
    stat 6 MaskedInterruptible
    uninterruptibleMask $ \restore -> do
      stat 7 MaskedUninterruptible
      restore $ stat 8 MaskedInterruptible
      restore $ restore $ stat 9 MaskedInterruptible
      stat 10 MaskedUninterruptible
      mask $ \restore -> do
        stat 11 MaskedUninterruptible
        restore $ stat 12 MaskedUninterruptible
        restore $ restore $ stat 13 MaskedUninterruptible
        stat 14 MaskedUninterruptible
      stat 15 MaskedUninterruptible
    stat 16 MaskedInterruptible
  stat 17 Unmasked

  uninterruptibleMask $ \restore -> do
    stat 20 MaskedUninterruptible
    restore $ stat 21 Unmasked
    restore $ restore $ stat 22 Unmasked
    stat 23 MaskedUninterruptible
    mask $ \restore -> do
      stat 24 MaskedUninterruptible
      restore $ stat 25 MaskedUninterruptible
      restore $ restore $ stat 26 MaskedUninterruptible
      stat 27 MaskedUninterruptible
      uninterruptibleMask $ \restore -> do
        stat 28 MaskedUninterruptible
        restore $ stat 29 MaskedUninterruptible
        restore $ restore $ stat 30 MaskedUninterruptible
        stat 31 MaskedUninterruptible
      stat 32 MaskedUninterruptible
    stat 33 MaskedUninterruptible
  stat 34 Unmasked

  -- it is possible to call a restore from a mask that is not the
  -- innermost enclosing one, although this is not a recommended use
  -- of the API.
  mask $ \restore0 -> do
    stat 41 MaskedInterruptible
    -- it is possible to call a restore from a mask that is not the
    uninterruptibleMask $ \restore1 -> do
      stat 42 MaskedUninterruptible
      restore0 $ stat 43 Unmasked
      restore0 $ restore0 $ stat 44 Unmasked
      restore1 $ stat 45 MaskedInterruptible
      restore1 $ restore1 $ stat 46 MaskedInterruptible
      restore0 $ restore1 $ stat 47 MaskedInterruptible
      restore1 $ restore0 $ stat 48 Unmasked
      stat 49 MaskedUninterruptible
    stat 50 MaskedInterruptible
  stat 51 Unmasked

stat :: Int -> MaskingState -> IO ()
stat n m = do
 s <- getMaskingState
 if (s /= m)
    then error (printf "%2d: %s\n" n (show s))
    else return ()


import Control.Exception
import Control.Concurrent
import Text.Printf

-- Test combinations of nesting mask/uninterruptibleMask with
-- forkIO/forkIOWithUnmask

main = do
  m <- newEmptyMVar
  t1 <- mask_ $ forkIO $ do
          takeMVar m `catch` \e -> do stat 1 MaskedInterruptible
                                      print (e::SomeException)
                                      throwIO e
  killThread t1
  t2 <- uninterruptibleMask_ $ forkIO $ do
          takeMVar m `catch` \e -> do stat 2 MaskedUninterruptible
                                      print (e::SomeException)
                                      throwIO e
  killThread t2
  t3 <- mask_ $ forkIOWithUnmask $ \unmask ->
            unmask $ do stat 3 Unmasked; putMVar m ()
  takeMVar m
  t4 <- uninterruptibleMask_ $ forkIOWithUnmask $ \unmask ->
            unmask $ do stat 4 Unmasked; putMVar m ()
  takeMVar m

stat :: Int -> MaskingState -> IO ()
stat n m = do
 s <- getMaskingState
 if (s /= m)
    then error (printf "%2d: %s\n" n (show s))
    else return ()


import GHC.Conc

main = do
  let x = length [1..100]
  numSparks >>= print
  x `par` numSparks >>= print
  x `par` numSparks >>= print
  x `par` numSparks >>= print
  x `par` numSparks >>= print


module Main (main) where

-- Test for #10545

import System.Environment
import Control.Concurrent
import Control.Exception
import Control.Monad
import System.Random
import System.Mem
import qualified Data.Set as Set

main = do
  [n] <- getArgs
  forkIO $ doSomeWork
  forM [1..read n] $ \n -> do print n; threadDelay 1000; performMinorGC

doSomeWork :: IO ()
doSomeWork = forever $ do
  ns <- replicateM 10000 randomIO :: IO [Int]
  ms <- replicateM 1000 randomIO
  let set = Set.fromList ns
      elems = filter (`Set.member` set) ms
  evaluate $ sum elems


module Main where

import Control.Concurrent

main = do
    let i = 1000000
    m <- newMVar (0 :: Int)
    let readloop 0 = return ()
        readloop i = do
            readMVar m
            readloop (i-1)
        writeloop 0 = return ()
        writeloop i = do
            readMVar m
            writeloop (i-1)
    forkIO $ readloop i
    writeloop i


module Main where

import Control.Concurrent

main = do
    m <- newEmptyMVar
    sync <- newEmptyMVar
    let f = readMVar m
    t1 <- forkIO (f >> error "FAILURE")
    t2 <- forkIO (f >> putMVar sync ())
    killThread t1
    putMVar m (0 :: Int)
    readMVar sync


module Main where

import Control.Concurrent

-- example from
-- http://www.haskell.org/pipermail/glasgow-haskell-users/2008-November/015878.html

main = do
    m <- newMVar (0 :: Int)
    forkIO $ putMVar m 1
    yield
    r1 <- readMVar m
    r2 <- takeMVar m
    r3 <- takeMVar m
    return ()


{-# LANGUAGE MagicHash, UnboxedTuples #-}

import GHC.Conc
import GHC.Prim
import System.Environment
import System.IO
import Control.Monad
import Text.Printf
import Data.Time.Clock
import Control.DeepSeq

main = do
  [n,q,t] <- fmap (fmap read) getArgs
  t <- forkIO $ do
    forM_ (cycle ([n,n-1..1] ++ [2..n-1])) $ \m -> do
      setNumCapabilities m
      threadDelay t
  printf "%d\n" (nqueens q)
  killThread t
      -- If we don't kill the child thread, it might be about to
      -- call setNumCapabilities() in C when the main thread exits,
      -- and chaos can ensue.  See #12038

nqueens :: Int -> Int
nqueens nq = length (pargen 0 [])
 where
    safe :: Int -> Int -> [Int] -> Bool
    safe x d []    = True
    safe x d (q:l) = x /= q && x /= q+d && x /= q-d && safe x (d+1) l

    gen :: [[Int]] -> [[Int]]
    gen bs = [ (q:b) | b <- bs, q <- [1..nq], safe q 1 b ]

    pargen :: Int -> [Int] -> [[Int]]
    pargen n b
       | n >= threshold = iterate gen [b] !! (nq - n)
       | otherwise      = concat bs
       where bs = map (pargen (n+1)) (gen [b]) `using` parList rdeepseq

    threshold = 3

using :: a -> Strategy a -> a
x `using` strat = runEval (strat x)

type Strategy a = a -> Eval a

newtype Eval a = Eval (State# RealWorld -> (# State# RealWorld, a #))

runEval :: Eval a -> a
runEval (Eval x) = case x realWorld# of (# _, a #) -> a

instance Functor Eval where
  fmap = liftM

instance Applicative Eval where
  pure x = Eval $ \s -> (# s, x #)
  (<*>)  = ap

instance Monad Eval where
  return = pure
  Eval x >>= k = Eval $ \s -> case x s of
                                (# s', a #) -> case k a of
                                                      Eval f -> f s'

parList :: Strategy a -> Strategy [a]
parList strat = traverse (rparWith strat)

rpar :: Strategy a
rpar  x = Eval $ \s -> spark# x s

rseq :: Strategy a
rseq x = Eval $ \s -> seq# x s

rparWith :: Strategy a -> Strategy a
rparWith s a = do l <- rpar r; return (case l of Lift x -> x)
  where r = case s a of
              Eval f -> case f realWorld# of
                          (# _, a' #) -> Lift a'

data Lift a = Lift a

rdeepseq :: NFData a => Strategy a
rdeepseq x = do rseq (rnf x); return x


module Main where
import Control.Concurrent
import Control.Exception

main = forkIO (error "Successful exception") >> threadDelay 100000


module Main where

import Data.IORef
import System.IO.Unsafe
import Control.Concurrent.STM
import Control.Concurrent.Async
import Control.Concurrent
import System.IO
import System.Directory
import System.FilePath
import T13916_Bracket

type Thing = MVar Bool

main :: IO ()
main = do
    withEnvCache limit spawner $ \cache ->
        forConcurrently_ [1..1000 :: Int] $ \n -> withEnv cache (\handle -> put handle n)
    where
        limit :: Limit
        limit = Hard 1

        put handle n = return ()

spawner :: Spawner Thing
spawner = Spawner
    { maker  = mkhandle
    , killer = \thing -> takeMVar thing >> putMVar thing True
    , isDead = \thing -> readMVar thing
    }

mkhandle :: IO Thing
mkhandle = newMVar False


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{- |
Module      : Bracket
Description : Handling multiple environments with bracket-like apis
Maintainer  : robertkennedy@clearwateranalytics.com
Stability   : stable

This module is meant for ie Sql or mongo connections, where you may wish for some number of easy to grab
environments. In particular, this assumes your connection has some initialization/release functions

This module creates bugs with any optimizations enabled. The bugs do not occur if the program is in the same
module.
-}
module T13916_Bracket (
    -- * Data Types
    Spawner(..), Limit(..), Cache,
    -- * Usage
    withEnvCache, withEnv
    ) where

import Control.Concurrent.STM
import Control.Concurrent.STM.TSem
import Control.Exception hiding (handle)
import Control.Monad
import Data.Vector (Vector)
import qualified Data.Vector as Vector

-- * Data Types
-- | Tells the program how many environments it is allowed to spawn.
-- A `Lax` limit will spawn extra connections if the `Cache` is empty,
-- while a `Hard` limit will not spawn any more than the given number of connections simultaneously.
--
-- @since 0.3.7
data Limit = Hard {getLimit :: {-# unpack #-} !Int}

data Spawner env = Spawner
    { maker  :: IO env
    , killer :: env -> IO ()
    , isDead :: env -> IO Bool
    }

type VCache env = Vector (TMVar env)
data Cache env = Unlimited { spawner :: Spawner env
                           , vcache :: !(VCache env)
                           }
               | Limited   { spawner :: Spawner env
                           , vcache :: !(VCache env)
                           , envsem :: TSem
                           }

-- ** Initialization
withEnvCache :: Limit -> Spawner env -> (Cache env -> IO a) -> IO a
withEnvCache limit spawner = bracket starter releaseCache
    where starter = case limit of
            Hard n -> Limited spawner <$> initializeEmptyCache n <*> atomically (newTSem n)

-- ** Using a single value
withEnv :: Cache env -> (env -> IO a) -> IO a
withEnv cache = case cache of
    Unlimited{..} -> withEnvUnlimited spawner vcache
    Limited{..}   -> withEnvLimited   spawner vcache envsem

-- *** Unlimited
-- | Takes an env and returns it on completion of the function.
-- If all envs are already taken or closed, this will spin up a new env.
-- When the function finishes, this will attempt to put the env into the cache. If it cannot,
-- it will kill the env. Note this can lead to many concurrent connections.
--
-- @since 0.3.5
withEnvUnlimited :: Spawner env -> VCache env -> (env -> IO a) -> IO a
withEnvUnlimited Spawner{..} cache = bracket taker putter
  where
    taker = do
        mpipe <- atomically $ tryTakeEnv cache
        case mpipe of
            Nothing  -> maker
            Just env -> isDead env >>= \b -> if not b then return env else killer env >> maker

    putter env = do
        accepted <- atomically $ tryPutEnv cache env
        unless accepted $ killer env

-- *** Limited
-- | Takes an env and returns it on completion of the function.
-- If all envs are already taken, this will wait. This should have a constant number of environments
--
-- @since 0.3.6
withEnvLimited :: Spawner env -> VCache env -> TSem -> (env -> IO a) -> IO a
withEnvLimited spawner vcache envsem = bracket taker putter
  where
    taker = limitMakeEnv spawner vcache envsem
    putter env = atomically $ putEnv vcache env

limitMakeEnv :: Spawner env -> VCache env -> TSem -> IO env
limitMakeEnv Spawner{..} vcache envsem = go
  where
    go = do
        eenvpermission <- atomically $ ( Left  <$> takeEnv  vcache )
                              `orElse` ( Right <$> waitTSem envsem )
        case eenvpermission of
            Right () -> maker
            Left env -> do
                -- Given our env, we check if it's dead. If it's not, we are done and return it.
                -- If it is dead, we release it, signal that a new env can be created, and then recurse
                isdead <- isDead env
                if not isdead then return env
                    else do
                         killer env
                         atomically $ signalTSem envsem
                         go

-- * Low level
initializeEmptyCache :: Int -> IO (VCache env)
initializeEmptyCache n | n < 1     = return mempty
                       | otherwise = Vector.replicateM n newEmptyTMVarIO

takeEnv :: VCache env -> STM env
takeEnv = Vector.foldl folding retry
    where folding m stmenv = m `orElse` takeTMVar stmenv

tryTakeEnv :: VCache env -> STM (Maybe env)
tryTakeEnv cache = (Just <$> takeEnv cache) `orElse` pure Nothing

putEnv :: VCache env -> env -> STM ()
putEnv cache env = Vector.foldl folding retry cache
    where folding m stmenv = m `orElse` putTMVar stmenv env

tryPutEnv :: VCache env -> env -> STM Bool
tryPutEnv cache env = (putEnv cache env *> return True) `orElse` pure False

releaseCache :: Cache env -> IO ()
releaseCache cache = Vector.mapM_ qkRelease (vcache cache)
    where qkRelease tenv = atomically (tryTakeTMVar tenv)
                       >>= maybe (return ()) (killer $ spawner cache)


import Control.Exception
import Control.Concurrent

main = do
  thr <- myThreadId
  evaluate $ increase_stack 1000
  throwTo thr ThreadKilled
        `Control.Exception.catch` (\e -> case e of
                         ThreadKilled -> return ()
                         _ -> throw e)
 where
  increase_stack 0 = 1
  increase_stack n = increase_stack (n-1) + n


import Control.Exception
import GHC.Conc

main = do
    t1 <- mask $ \_ -> forkIO yield
    t2 <- forkIO $ killThread t1
    threadDelay 100000
    threadStatus t1 >>= print
    threadStatus t2 >>= print


import Control.Exception
import GHC.Conc

main = do
    t1 <- mask_ $ forkIO yield
    t2 <- forkIO $ killThread t1
    threadDelay 100000
    threadStatus t1 >>= print
    threadStatus t2 >>= print


-- test for #3279

import System.IO.Unsafe
import GHC.Conc
import Control.Exception
import GHC.IO (unsafeUnmask)

f :: Int
f = (1 +) . unsafePerformIO $ do
        throwIO (ErrorCall "foo") `catch` \(SomeException e) -> do
            myThreadId >>= flip throwTo e
            -- point X
            unsafeUnmask $ return 1

main :: IO ()
main = do
    evaluate f `catch` \(SomeException e) -> return 0
    -- the evaluation of 'x' is now suspended at point X
    tid <- mask_ $ forkIO (evaluate f >> return ())
    killThread tid
    -- now execute the 'unblock' above with a pending exception
    yield
    -- should print 1 + 1 = 2
    print f


import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Exception
import System.IO

main :: IO ()
main = do hSetBuffering stdout NoBuffering
          replicateM_ 1000 doit

doit :: IO ()
doit = do v <- newMVar ()
          t <- forkIO (foo v)
          threadDelay 1000
          killThread t
          takeMVar v
          putChar '.'

foo :: MVar () -> IO ()
foo v = do let loop = do withMVar v $ \x -> evaluate x
                         loop
           loop


{-# LANGUAGE MagicHash #-}

import Control.Concurrent
import qualified Data.Vector as U

main = do
    t <- forkIO (U.sum (U.enumFromTo 1 (1000000000 :: Int)) `seq` return ())
    threadDelay 10
    killThread t
    putStrLn "Done"


{-# LANGUAGE MagicHash #-}

-- Should be compiled with -O0

import Control.Concurrent
import GHC.Conc
import GHC.Prim
import GHC.Exts

main = do
    t <- forkIO (f 0 `seq` return ())
    threadDelay 10
    killThread t
    putStrLn "Done"

-- Non-allocating let-no-escape infinite loop in fail
{-# NOINLINE f #-}
f :: Int -> Bool
f i@(I# j) = let fail :: Int# -> Bool
                 fail i = fail (i +# 1#)
      in if (case i of
            0 -> True
            _ -> False) then fail j else False


module Main where

import Control.Concurrent
import Control.Exception

main :: IO ()
main = do tid <- mask $ \_ -> forkIO $ let x = x in x
          killThread tid


{-# LANGUAGE ForeignFunctionInterface #-}
module Main where

-- Tests that superfluous worker threads are discarded rather than
-- being kept around by the RTS.

import Control.Concurrent
import Control.Monad
import Foreign.C.Types
import System.Mem
import System.Posix.Process
import System.Directory
import Control.Concurrent.QSem

foreign import ccall safe sleep :: CUInt -> IO ()

main = do
    let amount = 200
    qsem <- newQSem 0
    replicateM_ amount . forkIO $ (sleep 2 >> signalQSem qsem)
    replicateM_ amount $ waitQSem qsem
    -- POSIX only: check thread usage manually
    pid <- getProcessID
    let dir = "/proc/" ++ show pid ++ "/task"
    contents <- getDirectoryContents dir
    let status = length contents - 2 -- . and ..
    print status


import Control.Concurrent
import Control.Monad

-- tests for a bug where throwTo targets a thread just created by
-- forkOn, which is still in the process of migrating to another CPU (#4811)

main = do
  m <- newEmptyMVar
  forkOn 0 $ do
     replicateM_ 1000 $ do
       t <- forkOn 1 $ return ()
       killThread t
     putMVar m ()
  takeMVar m


import Control.Concurrent
import Control.Monad
import Control.Exception
import System.Mem

-- caused an assertion failure with -debug in 7.0.1 (#4813)

main = do
   m <- newEmptyMVar
   ts <- replicateM 100 $ mask_ $ forkIO $ threadDelay 100000; putMVar m ()
   mapM_ killThread (reverse (init ts))
   takeMVar m


import Control.Concurrent
import Control.Monad.Fix

data Client = Client
        { clientLock :: MVar ()
        }

main = do
        mvar <- newMVar ()

        client <- mfix $ \client -> do
                _ <- forkIO (mainLoop client)
                threadDelay 200000
                return (Client mvar)
        return ()

mainLoop client = withMVar (clientLock client) (\_ -> return ())


import Control.Concurrent
import Control.Exception
import Control.Monad
import System.IO.Unsafe

main :: IO ()
main = do
     -- evaluate lock -- adding this line fixes the problem

     fin1 <- newEmptyMVar
     fin2 <- newEmptyMVar

     forkIO $ ping >>= putMVar fin1
     forkIO $ ping >>= putMVar fin2

     takeMVar fin1
     takeMVar fin2

{-# NOINLINE lock #-}
lock :: MVar ()
lock = unsafePerformIO $ newMVar ()

ping = do
     () <- takeMVar lock
     putMVar lock ()


{-# LANGUAGE CPP,ForeignFunctionInterface #-}

import Control.Concurrent
import Foreign.C
import System.IO

#ifdef mingw32_HOST_OS
sleep n = sleepBlock (n*1000)
foreign import stdcall unsafe "Sleep" sleepBlock :: Int -> IO ()
#else
sleep n = sleepBlock n
foreign import ccall unsafe "sleep" sleepBlock :: Int -> IO ()
#endif

main :: IO ()
main = do
     hSetBuffering stdout LineBuffering

     tid <- forkIO $ do
         putStrLn "child: Sleeping"
         _ <- sleep 1

         -- The following lines should not happen after the killThread from the
         -- parent thread completes.  However, they do...
         -- putStrLn "child: Done sleeping"
         threadDelay 100000
         putStrLn "child: Done waiting"

     threadDelay 100000
     -- putStrLn $ "parent: Throwing exception to thread " ++ show tid
     throwTo tid $ userError "Exception delivered successfully"
     putStrLn "parent: Done throwing exception"

     threadDelay 200000


import GHC.Conc
import Control.Exception
import System.IO.Unsafe
import System.Timeout

main :: IO ()
main = do
    x <- unsafeInterleaveIO $ atomically retry
    _ <- timeout 500000 $ evaluate x
    evaluate x


import Control.Exception as E
import Data.IORef
import System.Mem.Weak
import Control.Concurrent

main :: IO ()
main = do
    ref <- newIORef 'x'
    weak <- mkWeakIORef ref $ putStrLn "IORef finalized"
    let check = deRefWeak weak >>= \m -> case m of
            Nothing -> putStrLn "IORef was GCed"
            Just ref' -> do
                x <- readIORef ref'
                putStrLn $ "IORef still alive, and contains " ++ show x
    m <- newEmptyMVar
    check
    takeMVar m `catch` \ex -> do
        putStrLn $ "caught exception: " ++ show (ex :: SomeException)
        check
    readIORef ref >>= print


import Control.Exception
import Control.Concurrent
import GHC.Conc
import Foreign.StablePtr

main :: IO ()
main = do
  tv <- atomically $ newTVar True
  _ <- newStablePtr tv
  t <- mask_ $ forkIO (blockSTM tv)
  killThread t

check b = if b then return () else retry

blockSTM :: TVar Bool -> IO ()
blockSTM tv = do
  atomically $ do
    v <- readTVar tv
    check $ not v


-- test for threadstatus, checking (mvar read, mvar block reasons)
-- created together with fixing GHC ticket #9333

module Main where

import Control.Concurrent
import GHC.Conc
import GHC.Conc.Sync

main = do
  -- create MVars to block on
  v1 <- newMVar "full"
  v2 <- newEmptyMVar
  -- create a thread which fills both MVars
  parent <- myThreadId
  putStrLn "p: forking child thread"
  child <- forkIO $
           do putStrLn "c: filling full MVar" -- should block
              putMVar v1 "filled full var"
              yield
              putStrLn "c: filling empty MVar (expect parent to be blocked)"
              stat2 <- threadStatus parent
              putStrLn ("c: parent is " ++ show stat2)
              putMVar v2 "filled empty var"
  yield
  putStrLn "p: emptying full MVar (expect child to be blocked on it)"
  stat1 <- threadStatus child
  putStrLn ("p: child is " ++ show stat1)
  s1 <- takeMVar v1 -- should unblock child
  putStrLn ("p: from MVar: " ++ s1)
  putStrLn "p: reading empty MVar"
  s2 <- readMVar v2 -- should block
  putStrLn ("p: from MVar: " ++ s2)


import Control.Concurrent
import Control.Exception
import Data.Array
import System.Random
import System.Environment
import Control.Monad
import GHC.Conc

-- A fiendish throwTo test.  A bunch of threads take random MVars from
-- a shared array; if the MVar has Nothing in it, replace it with Just
-- of the current thread's ThreadId.  If the MVar has another ThreadId
-- in it, then killThread that thread, and replace it with the current
-- thread's ThreadId.  We keep going until only one thread is left
-- standing.
--
-- On multiple CPUs this should give throwTo a good workout.
--
main = do
  [m, t] <- fmap (fmap read) getArgs
  ms <- replicateM m $ newMVar Nothing
  let arr = listArray (1,m) ms
  dead <- newTVarIO 0
  ts <- replicateM t $ forkIO (thread m arr `onException`
                                      (atomically $ do d <- readTVar dead
                                                       writeTVar dead $! d+1))
  atomically $ do
    d <- readTVar dead
    when (d < t-1) $ retry

thread m arr = do
  x <- randomIO
  id <- myThreadId
  modifyMVar_ (arr ! ((x `mod` m) + 1)) $ \b ->
    case b of
      Nothing    -> return (Just id)
      Just other -> do when (other /= id) $ killThread other
                       return (Just id)
  thread m arr


{-# LANGUAGE RecursiveDo, ScopedTypeVariables #-}
import Control.Concurrent
import Control.Exception
import Data.Array
import System.Random
import System.Environment
import Control.Monad
import GHC.Conc
import Data.IORef

main = do
  r <- newIORef 0
  rec
    t1 <- mask $ \restore -> forkIO (thread restore r t2)
    t2 <- mask $ \restore -> forkIO (thread restore r t1)
  threadDelay 1000000
  readIORef r >>= print . (/= 0)

thread restore r t = run
  where
    run = (restore $ forever $ do killThread t
                                  i <- atomicModifyIORef r (\i -> (i + 1, i))
                                  evaluate i)
             `catch` \(e::SomeException) -> run


{-# LANGUAGE DoRec, ScopedTypeVariables #-}
import Control.Concurrent
import Control.Exception
import Control.Monad

main = do
  m <- newMVar 1
  t1 <- mask $ \restore -> forkIO $ thread restore m
  t2 <- forkIO $ forever $ killThread t1
  threadDelay 1000000
  takeMVar m

thread restore m = run
  where
    run = (restore $ forever $ modifyMVar_ m $ \v -> if v `mod` 2 == 1 then return (v*2) else return (v-1))
             `catch` \(e::SomeException) -> run


module Main where

import Control.Concurrent

main = do
    m <- newMVar (0 :: Int)
    Just 0 <- tryReadMVar m
    takeMVar m
    Nothing <- tryReadMVar m
    return ()


module Main where

import Control.Concurrent
import Control.Monad

main = do
    m <- newEmptyMVar
    done <- newEmptyMVar
    let q = 200000
    forkIO (do mapM (\n -> putMVar m n) [1..q]; putMVar done ())
    forkIO (do replicateM_ q $ readMVar m; putMVar done ())
    forkIO (do replicateM_ q $ tryReadMVar m; putMVar done ())
    forkIO (do replicateM_ q $ takeMVar m; putMVar done ())
    replicateM_ 4 $ takeMVar done


{-# LANGUAGE RankNTypes #-}

module Memo where
import Data.Bits

type Memo a = forall r. (a -> r) -> (a -> r)

memo2 :: Memo a -> Memo b -> (a -> b -> r) -> (a -> b -> r)
memo2 a b = a . (b .)

wrap :: (a -> b) -> (b -> a) -> Memo a -> Memo b
wrap i j m f = m (f . i) . j

pair :: Memo a -> Memo b -> Memo (a,b)
pair m m' f = uncurry (m (\x -> m' (\y -> f (x,y))))

bits :: (Num a, Ord a, Bits a) => Memo a
bits f = apply (fmap f identity)

data IntTrie a = IntTrie (BitTrie a) a (BitTrie a)  -- negative, 0, positive
data BitTrie a = BitTrie a (BitTrie a) (BitTrie a)

instance Functor BitTrie where
    fmap f ~(BitTrie x l r) = BitTrie (f x) (fmap f l) (fmap f r)

instance Functor IntTrie where
    fmap f ~(IntTrie neg z pos) = IntTrie (fmap f neg) (f z) (fmap f pos)

-- | Apply the trie to an argument.  This is the semantic map.
apply :: (Ord b, Num b, Bits b) => IntTrie a -> b -> a
apply (IntTrie neg z pos) x =
    case compare x 0 of
        LT -> applyPositive neg (-x)
        EQ -> z
        GT -> applyPositive pos x

applyPositive :: (Num b, Bits b) => BitTrie a -> b -> a
applyPositive (BitTrie one eve od) x
    | x == 1 = one
    | testBit x 0 = applyPositive od (x `shiftR` 1)
    | otherwise   = applyPositive eve (x `shiftR` 1)

identity :: (Num a, Bits a) => IntTrie a
identity = IntTrie (fmap negate identityPositive) 0 identityPositive

identityPositive :: (Num a, Bits a) => BitTrie a
identityPositive = go
    where
      go = BitTrie 1 (fmap (`shiftL` 1) go) (fmap (\n -> (n `shiftL` 1) .|. 1) go)


{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, DefaultSignatures, TypeOperators, FlexibleContexts #-}

module Parallel
    (NFData, parMap, rdeepseq) where

import Control.Monad
import GHC.Exts
import Control.DeepSeq

infixl 0 `using`

type Strategy a = a -> Eval a

newtype Eval a = Eval (State# RealWorld -> (# State# RealWorld, a #))

instance Functor Eval where
  fmap = liftM

instance Applicative Eval where
  pure x = Eval $ \s -> (# s, x #)
  (<*>)  = ap

instance Monad Eval where
  return = pure
  Eval x >>= k = Eval $ \s -> case x s of
                                (# s', a #) -> case k a of
                                                      Eval f -> f s'

rpar :: Strategy a
rpar  x = Eval $ \s -> spark# x s

rparWith :: Strategy a -> Strategy a
rparWith s a = do l <- rpar r; return (case l of Lift x -> x)
  where r = case s a of
              Eval f -> case f realWorld# of
                          (# _, a' #) -> Lift a'

data Lift a = Lift a

using :: a -> Strategy a -> a
x `using` strat = runEval (strat x)

rdeepseq :: NFData a => Strategy a
rdeepseq x = do rseq (rnf x); return x

parList :: Strategy a -> Strategy [a]
parList strat = traverse (rparWith strat)

parMap :: Strategy b -> (a -> b) -> [a] -> [b]
parMap strat f = (`using` parList strat) . map f

runEval :: Eval a -> a
runEval (Eval x) = case x realWorld# of (# _, a #) -> a

rseq :: Strategy a
rseq x = Eval $ \s -> seq# x s


{-# LANGUAGE RankNTypes #-}

module Main where

import Parallel
import qualified Memo
import qualified Data.Map.Lazy as M
import Control.DeepSeq
import Control.Monad.ST
import Data.STRef

fight :: Int -> Int -> [Int]
fight i a = map fst $ fightVanillaM i a

fightVanillaM :: Int -> Int -> [(Int, Int)]
fightVanillaM = Memo.memo2 Memo.bits Memo.bits fightVanilla

fightVanilla :: Int -> Int -> [(Int, Int)]
fightVanilla php ohp
  | php <= 0 || ohp <= 0 = [(max 0 php, max 0 ohp)]
  | otherwise = regroup $ do
      (odmg, pdmg) <- [(9,3),(10,2),(11,2),(12,2),(14,1),(16,1),(18,0),(100,0),(100,0),(100,0)]
      fightVanillaM (php - pdmg) (ohp - odmg)

update :: Int -> Int -> [(Int, Int)]
update i outcome = (,) outcome <$> fight i outcome

memoState :: Memo.Memo (Int, Int)
memoState = Memo.pair Memo.bits Memo.bits

fibFight :: Int -> [Int]
fibFight 0 = []
fibFight 1 = []
fibFight x = [(x - 1), (x - 2)]

-----------------------------------------------------------------------------------
regroup :: (NFData a, Show a, Eq a, Ord a) => [(a, Int)] -> [(a, Int)]
regroup xs =
    let xs' = M.toList $ M.fromListWith (+) xs
        s' = addTheNumbers (map (\(_,x) -> x) xs) -- sum (map snd xs')
        s  = sum (map snd xs)
     in if s' /= s
            then if show s' == show s
                    then error "WAT????"
                    else error $ "Those are expected to be equal" ++ show (s', s)
            else xs'
----------------------------------------------------------------------------------

addTheNumbers :: [Int] -> Int
addTheNumbers xs0 = runST $ do
  y <- newSTRef 0
  let go [] = readSTRef y
      go (x : xs) = do
        modifySTRef y (+x)
        go xs
  go xs0

main :: IO ()
main = rnf (go (80, 250)) `seq` return ()
    where
        go = memoState (rnf . parMap rdeepseq (map go) . step)
step (cid, hp) = map (update hp) (fibFight cid)


{-# LANGUAGE PatternSignatures #-}

import Control.Monad
import Control.Parallel
import System.Environment
import System.Random

sort (x:xs) = sort lesser ++ [x] ++ sort greater
    where lesser = filter (<  x) xs
          greater = filter (>= x) xs
sort _ = []

psort xs 10 = sort xs
psort (x:xs) d = let d' = d + 1
                     l = psort lesser d'
                     g = psort greater d'
              in l `par` g `par` (l ++ [x] ++ g)
    where lesser = filter (<  x) xs
          greater = filter (>= x) xs
psort _ _ = []

main = do
  args <- getArgs
  let counts | null args = [100000]
             | otherwise = map read args
  rs :: [Int] <- randoms `fmap` getStdGen
  forM_ counts $ \k -> do
    let xs = take k rs
    print . length $ xs
--    s <- getCurrentTime
    print . length $ psort xs 0
--    e <- getCurrentTime
--    print (e `diffUTCTime` s)


-- $Id: Cpr001_imp.hs,v 1.1 2001/08/22 12:21:15 simonmar Exp $

module Cpr001_imp where

import Control.Applicative (Applicative(..))
import Control.Monad (liftM, ap)

data MS         = MS { instr    :: String
                     , pc       :: Int
                     , mem      :: String
                     , stack    :: String
                     , frames   :: [String]
                     , status   :: Maybe String
                     }

newtype StateTrans s a = ST ( s -> (s, Maybe a))

-- state monad with error handling
-- in case of an error, the state remains
-- as it is and Nothing is returned as value
-- else execution continues

instance Functor (StateTrans s) where
    fmap = liftM

instance Applicative (StateTrans s) where
    pure = return
    (<*>) = ap

instance Monad (StateTrans s) where
    (ST p) >>= k
        = ST (\s0 -> let
                     (s1, r0)   = p s0
                     in
                     case r0 of
                     Just v -> let
                               (ST q) = k v
                               in
                               q s1
                     Nothing -> (s1, Nothing)
             )
    return v
        = ST (\s -> (s, Just v))

-- machine state transitions

type MachineStateTrans  = StateTrans MS

type MST = MachineStateTrans

{-# NOINLINE setMTerminated #-}
setMTerminated
    = ST (\ms -> (ms { status = Just "Terminated" }, Just ()))

setMSvc call
    = ST (\ms -> (ms { status = Just "Service" }, Just ()))

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

data Instr
    = LoadI             Int             -- load int const
    | SysCall           String          -- system call (svc)


repeat' :: x -> [x]
repeat' x = x : repeat' x

main = print (repeat' () !! 10 )


{-# LANGUAGE DataKinds, PolyKinds #-}

module Dep1 where

import Data.Kind

data Proxy k (a :: k) = P

x :: Proxy Type Int
x = P

y :: Proxy Bool True
y = P


{-# LANGUAGE PolyKinds, GADTs #-}

module Dep2 where

data G (a :: k) where
  G1 :: G Int
  G2 :: G Maybe


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

module Dep3 where

import Data.Kind
import GHC.Exts ( Constraint )

type Star1 = Type

data Id1 (a :: Star1) where
  Id1 :: a -> Id1 a

data Id1' :: Star1 -> Type where
  Id1' :: a -> Id1' a

type family Star2 x where
  Star2 x = Type

data Id2a (a :: Star2 Constraint) = Id2a a

data Id2 (a :: Star2 Constraint) where
  Id2 :: a -> Id2 a

data Id2' :: Star2 Constraint -> Type where
  Id2' :: a -> Id2' a


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

module DkNameRes where

import Data.Proxy
import Data.Kind

type family IfK (e :: Proxy (j :: Bool)) :: Type where
   IfK (_ :: Proxy True) = ()


{- This is the code extracted from "A reflection on types", by Simon PJ,
Stephanie Weirich, Richard Eisenberg, and Dimitrios Vytiniotis, 2016. -}

-- NB: it includes a negative-recursive function (see delta1), and
-- so will give "simplifier ticks exhausted", at least with -O

{-#  LANGUAGE RankNTypes, PolyKinds, TypeOperators,
             ScopedTypeVariables, GADTs, FlexibleInstances,
             UndecidableInstances, RebindableSyntax,
             DataKinds, MagicHash #-}
{-# OPTIONS_GHC -Wno-missing-methods -Wno-redundant-constraints #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
  -- Because we define a local Typeable class and have
  --   instance Data.Typeable.Typeable a => Typeable a

module Dynamic where

import Data.Map ( Map )
import qualified Data.Map as Map
import Unsafe.Coerce ( unsafeCoerce )
import Control.Monad ( (<=<) )
import Prelude hiding ( lookup, fromInteger, replicate )
import qualified Prelude
import qualified Data.Typeable
import qualified Data.Data
import Data.Kind

lookupMap = Map.lookup
insertMap = Map.insert

--  let's ignore overloaded numbers
fromInteger :: Integer -> Int
fromInteger = Prelude.fromInteger

insertStore = undefined
schema = undefined
withTypeable = undefined
throw# = undefined

toDynamicST = undefined
fromDynamicST = undefined

extendStore  :: Typeable a => STRef s a -> a -> Store -> Store
lookupStore  :: Typeable a => STRef s a -> Store -> Maybe a

type Key = Int
data STRef s a = STR Key
type Store = Map Key Dynamic

extendStore (STR k) v  s =  insertMap k (toDynamicST v) s
lookupStore (STR k)    s =  case lookupMap k s of
                              Just d   -> fromDynamicST d
                              Nothing  -> Nothing

toDynamicST    :: Typeable a => a -> Dynamic
fromDynamicST  :: Typeable a => Dynamic -> Maybe a

eval = undefined
data Term

data DynamicSilly  =  DIntSilly  Int
              |  DBoolSilly Bool
              |  DCharSilly Char
              |  DPairSilly DynamicSilly DynamicSilly

toDynInt :: Int -> DynamicSilly
toDynInt = DIntSilly

fromDynInt :: DynamicSilly -> Maybe Int
fromDynInt (DIntSilly n)  = Just n
fromDynInt _         = Nothing

toDynPair :: DynamicSilly -> DynamicSilly -> DynamicSilly
toDynPair = DPairSilly

dynFstSilly :: DynamicSilly -> Maybe DynamicSilly
dynFstSilly (DPairSilly x1 x2) = Just x1
dynFstSilly _             = Nothing

eval :: Term -> DynamicSilly

eqT = undefined

instance Typeable (->)
instance Typeable Maybe
instance Typeable Bool
instance Typeable Int
instance (Typeable a, Typeable b) => Typeable (a b)
instance Typeable (,)

instance Eq SomeTypeRep

data Dynamic where
   Dyn :: TypeRep a -> a -> Dynamic

toDynamic :: Typeable a => a -> Dynamic
toDynamic x = Dyn typeRep x

eqTNoKind = undefined

eqTNoKind :: TypeRep a -> TypeRep b -> Maybe (a :***: b)
   --  Primitive; implemented by compiler

data a :***: b where
  ReflNoKind :: a :***: a

fromDynamic :: forall d. Typeable d => Dynamic -> Maybe d
fromDynamic (Dyn (ra :: TypeRep a) (x :: a))
  =  case eqT ra (typeRep :: TypeRep d) of
       Nothing    -> Nothing
       Just Refl  -> Just x

fromDynamicMonad :: forall d. Typeable d => Dynamic -> Maybe d

fromDynamicMonad (Dyn ra x)
  = do  Refl <- eqT ra (typeRep :: TypeRep d)
        return x

cast :: forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast x = do  Refl <- eqT  (typeRep :: TypeRep a)
                          (typeRep :: TypeRep b)
             return x

gcast :: forall a b c. (Typeable a, Typeable b) => c a -> Maybe (c b)
gcast x = do  Refl <- eqT  (typeRep :: TypeRep a)
                           (typeRep :: TypeRep b)
              return x

data SameKind :: k -> k -> Type
type CheckAppResult = SameKind AppResult AppResultNoKind
  --  not the most thorough check
foo :: AppResult x -> AppResultNoKind x
foo (App y z) = AppNoKind y z

splitApp :: TypeRep a -> Maybe (AppResult a)
splitApp = undefined
splitAppNoKind = undefined
splitAppNoKind :: TypeRep a -> Maybe (AppResultNoKind a)
   --  Primitive; implemented by compiler

data AppResultNoKind t where
  AppNoKind :: TypeRep a -> TypeRep b -> AppResultNoKind (a b)

dynFstNoKind :: Dynamic -> Maybe Dynamic
dynFstNoKind (Dyn rpab x)
  = do  AppNoKind rpa rb  <- splitAppNoKind rpab
        AppNoKind rp  ra  <- splitAppNoKind rpa
        Refl        <- eqT rp (typeRep :: TypeRep (,))
        return (Dyn ra (fst x))

dynApply :: Dynamic -> Dynamic -> Maybe Dynamic
dynApply (Dyn rf f) (Dyn rx x) = do
    App ra rt2   <- splitApp rf
    App rtc rt1  <- splitApp ra
    Refl         <- eqT rtc (typeRep :: TypeRep (->))
    Refl         <- eqT rt1 rx
    return (Dyn rt2 (f x))

data TypeRepAbstract (a :: k)  --  primitive, indexed by type and kind

class Typeable (a :: k) where
   typeRep :: TypeRep a

data AppResult (t :: k) where
  App ::  forall k1 k (a :: k1 -> k) (b :: k1).
          TypeRep a -> TypeRep b -> AppResult (a b)

dynFst :: Dynamic -> Maybe Dynamic
dynFst (Dyn (rpab :: TypeRep pab) (x :: pab))

  = do  App (rpa  :: TypeRep pa ) (rb :: TypeRep b)  <- splitApp rpab
            --  introduces kind |k2|, and types |pa :: k2 -> Type|, |b :: k2|

        App (rp   :: TypeRep p  ) (ra :: TypeRep a)  <- splitApp rpa
            --  introduces kind |k1|, and types |p :: k1 -> k2 -> Type|,
            --                                  |a :: k1|

        Refl       <- eqT rp (typeRep :: TypeRep (,))
            --  introduces |p ~ (,)| and
            --             |(k1 -> k2 -> Type) ~ (Type -> Type -> Type)|

        return (Dyn ra (fst x))

eqT :: forall k1 k2 (a :: k1) (b :: k2).
       TypeRep a -> TypeRep b -> Maybe (a :~: b)

data (a :: k1) :~: (b :: k2) where
  Refl :: forall k (a :: k). a :~: a

castDance :: (Typeable a, Typeable b)  => a -> Maybe b
castDance = castR typeRep typeRep

withTypeable :: TypeRep a -> (Typeable a => r) -> r

castR :: TypeRep a -> TypeRep b -> a -> Maybe b
castR ta tb = withTypeable ta (withTypeable tb castDance)

cmpT = undefined
compareTypeRep = undefined

data SomeTypeRep where
   SomeTypeRep :: TypeRep a -> SomeTypeRep

type TyMapLessTyped = Map SomeTypeRep Dynamic

insertLessTyped :: forall a. Typeable a => a -> TyMapLessTyped -> TyMapLessTyped
insertLessTyped x
  = Map.insert (SomeTypeRep (typeRep :: TypeRep a)) (toDynamic x)

lookupLessTyped :: forall a. Typeable a => TyMapLessTyped -> Maybe a
lookupLessTyped
  = fromDynamic <=< Map.lookup (SomeTypeRep (typeRep :: TypeRep a))

instance Ord SomeTypeRep where
  compare (SomeTypeRep tr1) (SomeTypeRep tr2) = compareTypeRep tr1 tr2

compareTypeRep :: TypeRep a -> TypeRep b -> Ordering  --  primitive

data TyMap = Empty | Node Dynamic TyMap TyMap

lookup :: TypeRep a -> TyMap -> Maybe a
lookup tr1 (Node (Dyn tr2 v) left right) =
  case compareTypeRep tr1 tr2 of
    LT  -> lookup tr1 left
    EQ  -> castR tr2 tr1 v   --  know this cast will succeed
    GT  -> lookup tr1 right
lookup tr1 Empty = Nothing

cmpT :: TypeRep a -> TypeRep b -> OrderingT a b
  --  definition is primitive

data OrderingT a b where
  LTT  :: OrderingT a b
  EQT  :: OrderingT t t
  GTT  :: OrderingT a b

data TypeRep (a :: k) where
  TrApp    :: TypeRep a -> TypeRep b -> TypeRep (a b)
  TrTyCon  :: TyCon -> TypeRep k -> TypeRep (a :: k)

data TyCon = TyCon { tc_module :: Module, tc_name :: String }
data Module = Module { mod_pkg :: String, mod_name :: String }

tcMaybe  :: TyCon
tcMaybe  = TyCon  { tc_module  = Module  { mod_pkg   = "base"
                                               , mod_name  = "Data.Maybe" }
                        , tc_name    = "Maybe" }

rt = undefined

delta1 :: Dynamic -> Dynamic
-- NB: this function behaves like a negative-recursive data type
-- and hence leads compiler into an infinite inlining loop,
-- and we get "simplifier ticks exhausted".
-- See Section 7 of the paper "A reflection on types"
delta1 dn = case fromDynamic dn of
             Just f   -> f dn
             Nothing  -> dn
loop1 = delta1 (toDynamic delta1)

data Rid = MkT (forall a. TypeRep a -> a -> a)
rt :: TypeRep Rid
delta :: forall a. TypeRep a -> a -> a
delta ra x = case (eqT ra rt) of
             Just Refl  -> case x of MkT y -> y rt x
             Nothing    -> x
loop = delta rt (MkT delta)

throw# :: SomeException -> a

data SomeException where
  SomeException :: Exception e => e -> SomeException

class (Typeable e, Show e) => Exception e where {   }

data Company
data Salary
incS :: Float -> Salary -> Salary
incS = undefined

--  some impedance matching with SYB
instance Data.Data.Data Company
instance {-#  INCOHERENT  #-} Data.Typeable.Typeable a => Typeable a

mkT :: (Typeable a, Typeable b) => (b -> b) -> a -> a
mkT f x = case (cast f) of
            Just g   -> g x
            Nothing  -> x

data Expr a
frontEnd = undefined

data DynExp where
  DE :: TypeRep a -> Expr a -> DynExp

frontEnd :: String -> DynExp

data TyConOld

typeOf = undefined
eqTOld = undefined
funTcOld = undefined :: TyConOld
splitTyConApp = undefined
mkTyCon3 = undefined
boolTcOld = undefined
tupleTc = undefined
mkTyConApp = undefined
instance Eq TypeRepOld
instance Eq TyConOld

data TypeRepOld       --  Abstract

class TypeableOld a where
  typeRepOld :: proxy a -> TypeRepOld

data DynamicOld where
   DynOld :: TypeRepOld -> a -> DynamicOld

data Proxy a = Proxy

fromDynamicOld :: forall d. TypeableOld d => DynamicOld -> Maybe d
fromDynamicOld (DynOld trx x)
 | typeRepOld (Proxy :: Proxy d) == trx  = Just (unsafeCoerce x)
 | otherwise                          = Nothing

dynApplyOld :: DynamicOld -> DynamicOld -> Maybe DynamicOld
dynApplyOld (DynOld trf f) (DynOld trx x) =
  case splitTyConApp trf of
      (tc, [t1,t2]) | tc == funTcOld && t1 == trx ->
          Just (DynOld t2 ((unsafeCoerce f) x))
      _ -> Nothing

data DynamicClosed where
  DynClosed :: TypeRepClosed a -> a -> DynamicClosed

data TypeRepClosed (a :: Type) where
  TBool  :: TypeRepClosed Bool
  TFun   :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a -> b)
  TProd  :: TypeRepClosed a -> TypeRepClosed b -> TypeRepClosed (a, b)

lookupPil = undefined

lookupPil :: Typeable a => [Dynamic] -> Maybe a

data Dyn1 = Dyn1 Int
         | DynFun (Dyn1 -> Dyn1)
         | DynPair (Dyn1, Dyn1)

data TypeEnum = IntType | FloatType | BoolType | DateType | StringType
data Schema = Object [Schema] |
              Field TypeEnum |
              Array Schema

schema :: Typeable a => a -> Schema


{-# LANGUAGE PolyKinds #-}

module InferDependency where

data Proxy k (a :: k)
data Proxy2 k a = P (Proxy k a)


{-# LANGUAGE PolyKinds, GADTs, ExplicitForAll #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}

module KindEqualities where

import Data.Kind

data TyRep1 :: Type -> Type where
  TyInt1 :: TyRep1 Int
  TyBool1 :: TyRep1 Bool

zero1 :: forall a. TyRep1 a -> a
zero1 TyInt1 = 0
zero1 TyBool1 = False

data Proxy (a :: k) = P

data TyRep :: forall k. k -> Type where
  TyInt :: TyRep Int
  TyBool :: TyRep Bool
  TyMaybe :: TyRep Maybe
  TyApp :: TyRep a -> TyRep b -> TyRep (a b)

zero :: forall (a :: Type). TyRep a -> a
zero TyInt = 0
zero TyBool = False
zero (TyApp TyMaybe _) = Nothing


{-# LANGUAGE DataKinds, GADTs, PolyKinds, TypeFamilies, ExplicitForAll,
             TemplateHaskell, UndecidableInstances, ScopedTypeVariables #-}

module KindEqualities2 where

import Data.Kind
import GHC.Exts ( Any )

data Kind = Star | Arr Kind Kind

data Ty :: Kind -> Type where
  TInt :: Ty Star
  TBool :: Ty Star
  TMaybe :: Ty (Arr Star Star)
  TApp :: Ty (Arr k1 k2) -> Ty k1 -> Ty k2

data TyRep (k :: Kind) (t :: Ty k) where
  TyInt :: TyRep Star TInt
  TyBool :: TyRep Star TBool
  TyMaybe :: TyRep (Arr Star Star) TMaybe
  TyApp :: TyRep (Arr k1 k2) a -> TyRep k1 b -> TyRep k2 (TApp a b)

type family IK (k :: Kind)
type instance IK Star = Type
type instance IK (Arr k1 k2) = IK k1 -> IK k2

$(return [])  -- necessary because the following instances depend on the
              -- previous ones.

type family I (t :: Ty k) :: IK k
type instance I TInt = Int
type instance I TBool = Bool
type instance I TMaybe = Maybe
type instance I (TApp a b) = (I a) (I b)

zero :: forall (a :: Ty 'Star). TyRep Star a -> I a
zero TyInt = 0
zero TyBool = False
zero (TyApp TyMaybe TyInt) = Nothing

main = print $ zero (TyApp TyMaybe TyInt)


{-# LANGUAGE DataKinds, PolyKinds #-}

module KindLevels where

import Data.Kind

data A
data B :: A -> Type
data C :: B a -> Type
data D :: C b -> Type
data E :: D c -> Type


{-# LANGUAGE GADTs, PolyKinds #-}

module GADTVars where

import Data.Kind
import Data.Proxy

data T (k1 :: Type) (k2 :: Type) (a :: k2) (b :: k2) where
  MkT :: T x1 Type (Proxy (y :: x1), z) z


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

module A where

import Data.Kind

data family Sing (k :: Type) :: k -> Type
type Sing' (x :: k) = Sing k x
data TyFun' (a :: Type) (b :: Type) :: Type
type TyFun (a :: Type) (b :: Type) = TyFun' a b -> Type
type family (a :: TyFun k1 k2) @@ (b :: k1) :: k2
data TyPi' (a :: Type) (b :: TyFun a Type) :: Type
type TyPi (a :: Type) (b :: TyFun a Type) = TyPi' a b -> Type
type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b
$(return [])

data A (a :: Type) (b :: a) (c :: TyFun' a Type)
  -- A :: forall a -> a -> a ~> Type
type instance (@@) (A a b) c = Type
$(return [])
data B (a :: Type) (b :: TyFun' a Type)
  -- B :: forall a -> a ~> Type
type instance (@@) (B a) b = TyPi a (A a b)
$(return [])
data C (a :: Type) (b :: TyPi a (B a)) (c :: a) (d :: a)
       (e :: TyFun' (b @@@ c @@@ d) Type)


{-# LANGUAGE DataKinds, PolyKinds, GADTs, TypeOperators, TypeFamilies #-}
{-# OPTIONS_GHC -fwarn-unticked-promoted-constructors #-}

module RaeBlogPost where

import Data.Kind

-- a Proxy type with an explicit kind
data Proxy k (a :: k) = P
prox :: Proxy Type Bool
prox = P

prox2 :: Proxy Bool 'True
prox2 = P

-- implicit kinds still work
data A
data B :: A -> Type
data C :: B a -> Type
data D :: C b -> Type
data E :: D c -> Type
-- note that E :: forall (a :: A) (b :: B a) (c :: C b). D c -> Type

-- a kind-indexed GADT
data TypeRep (a :: k) where
  TInt   :: TypeRep Int
  TMaybe :: TypeRep Maybe
  TApp   :: TypeRep a -> TypeRep b -> TypeRep (a b)

zero :: TypeRep a -> a
zero TInt            = 0
zero (TApp TMaybe _) = Nothing

data Nat = Zero | Succ Nat
type family a + b where
  'Zero     + b = b
  ('Succ a) + b = 'Succ (a + b)

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

-- promoted GADT, and using + as a "kind family":
type family (x :: Vec a n) ++ (y :: Vec a m) :: Vec a (n + m) where
  'Nil      ++ y = y
  (h ':> t) ++ y = h ':> (t ++ y)

-- datatype that mentions Type
data U = Star (Type)
       | Bool Bool

-- kind synonym
type Monadish = Type -> Type
class MonadTrans (t :: Monadish -> Monadish) where
  lift :: Monad m => m a -> t m a
data Free :: Monadish where
  Return :: a -> Free a
  Bind   :: Free a -> (a -> Free b) -> Free b

-- yes, Type really does have type Type.
type Star = (Type :: (Type :: (Type :: Type)))


{- Copyright (c) 2016 Richard Eisenberg
 -}

{-# LANGUAGE TypeOperators, TypeFamilies, TypeApplications, AllowAmbiguousTypes,
             ExplicitForAll, ScopedTypeVariables, GADTs, TypeFamilyDependencies,
             DataKinds, PolyKinds , ConstraintKinds, UndecidableInstances,
             FlexibleInstances, MultiParamTypeClasses, FunctionalDependencies,
             FlexibleContexts, StandaloneDeriving, InstanceSigs,
             RankNTypes, UndecidableSuperClasses #-}

module RaeJobTalk where

import Data.Type.Bool
import Data.Type.Equality hiding ((:~~:)(..))
import GHC.TypeLits
import Data.Proxy
import GHC.Exts
import Data.Kind
import Unsafe.Coerce
import Data.Char
import Data.Maybe

-------------------------------
-- Utilities

-- Heterogeneous propositional equality
data (a :: k1) :~~: (b :: k2) where
  HRefl :: a :~~: a

-- Type-level inequality
type a /= b = Not (a == b)

-- append type-level lists (schemas)
type family s1 ++ s2 where
  '[]       ++ s2 = s2
  (s ': s1) ++ s2 = s ': (s1 ++ s2)

-- This is needed in order to prove disjointness, because GHC can't
-- handle inequality well.
assumeEquality :: forall a b r. ((a ~ b) => r) -> r
assumeEquality thing = case unsafeCoerce Refl :: a :~: b of
  Refl -> thing

-- Shorter name for shorter example
eq :: TestEquality f => f a -> f b -> Maybe (a :~: b)
eq = testEquality

-------------------------------
-- Singleton lists

-- Unlike in the singletons paper, we now have injective type
-- families, so we use that to model singletons; it's a bit
-- cleaner than the original approach
type family Sing = (r :: k -> Type) | r -> k

-- Cute type synonym.
type Î  = Sing

-- Really, just singleton lists. Named Schema for better output
-- during example.
data Schema :: forall k. [k] -> Type where
  Nil :: Schema '[]
  (:>>) :: Sing h -> Schema t -> Schema (h ': t)
infixr 5 :>>
type instance Sing = Schema

-- Append singleton lists
(%:++) :: Schema a -> Schema b -> Schema (a ++ b)
Nil %:++ x = x
(a :>> b) %:++ c = a :>> (b %:++ c)

--------------------------------
-- Type-indexed type representations
-- Based on "A reflection on types"

data TyCon (a :: k) where
  Int :: TyCon Int
  Bool :: TyCon Bool
  Char :: TyCon Char
  List :: TyCon []
  Maybe :: TyCon Maybe
  Arrow :: TyCon (->)
  TYPE  :: TyCon TYPE
  RuntimeRep :: TyCon RuntimeRep
  LiftedRep' :: TyCon 'LiftedRep
  -- If extending, add to eqTyCon too

eqTyCon :: TyCon a -> TyCon b -> Maybe (a :~~: b)
eqTyCon Int Int = Just HRefl
eqTyCon Bool Bool = Just HRefl
eqTyCon Char Char = Just HRefl
eqTyCon List List = Just HRefl
eqTyCon Maybe Maybe = Just HRefl
eqTyCon Arrow Arrow = Just HRefl
eqTyCon TYPE TYPE = Just HRefl
eqTyCon RuntimeRep RuntimeRep = Just HRefl
eqTyCon LiftedRep' LiftedRep' = Just HRefl
eqTyCon _ _ = Nothing

-- Check whether or not a type is really a plain old tycon;
-- necessary to avoid warning in kindRep
type family Primitive (a :: k) :: Constraint where
  Primitive (_ _) = ('False ~ 'True)
  Primitive _     = (() :: Constraint)

data TypeRep (a :: k) where
  TyCon :: forall k (a :: k). (Primitive a, Typeable k) => TyCon a -> TypeRep a
  TyApp :: TypeRep a -> TypeRep b -> TypeRep (a b)

-- Equality on TypeReps
eqT :: TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqT (TyCon tc1) (TyCon tc2) = eqTyCon tc1 tc2
eqT (TyApp f1 a1) (TyApp f2 a2) = do
  HRefl <- eqT f1 f2
  HRefl <- eqT a1 a2
  return HRefl
eqT _ _ = Nothing

--------------------------------------
-- Existentials

data TyConX where
  TyConX :: forall k (a :: k). (Primitive a, Typeable k) => TyCon a -> TyConX

instance Read TyConX where
  readsPrec _ "Int" = [(TyConX Int, "")]
  readsPrec _ "Bool" = [(TyConX Bool, "")]
  readsPrec _ "List" = [(TyConX List, "")]
  readsPrec _ _ = []

-- This variant of SomeTypeRep allows you to specify an arbitrary
-- constraint on the inner TypeRep
data SomeTypeRep :: (forall k. k -> Constraint) -> Type where
  SomeTypeRep :: forall k (c :: forall k'. k' -> Constraint) (a :: k).
              c a => TypeRep a -> SomeTypeRep c

-- This constraint is always satisfied
class ConstTrue (a :: k) -- needs the :: k to make it a specified tyvar
instance ConstTrue a

instance Show (SomeTypeRep ConstTrue) where
  show (SomeTypeRep tr) = show tr

-- can't write Show (SomeTypeRep c) because c's kind mentions a forall,
-- and the impredicativity check gets nervous. See #11519
instance Show (SomeTypeRep IsType) where
  show (SomeTypeRep tr) = show tr

-- Just enough functionality to get through example. No parentheses
-- or other niceties.
instance Read (SomeTypeRep ConstTrue) where
  readsPrec p s = do
    let tokens = words s
    tyreps <- mapM read_token tokens
    return (foldl1 mk_app tyreps, "")

    where
      read_token :: String -> [SomeTypeRep ConstTrue]
      read_token "String" = return (SomeTypeRep $ typeRep @String)
      read_token other = do
        (TyConX tc, _) <- readsPrec p other
        return (SomeTypeRep (TyCon tc))

      mk_app :: SomeTypeRep ConstTrue -> SomeTypeRep ConstTrue -> SomeTypeRep ConstTrue
      mk_app (SomeTypeRep f) (SomeTypeRep a) = case kindRep f of
        TyCon Arrow `TyApp` k1 `TyApp` _
          | Just HRefl <- k1 `eqT` kindRep a -> SomeTypeRep (TyApp f a)
        _ -> error "ill-kinded type"

-- instance Read (SomeTypeRep ((~~) Type))  RAE: need (~~) :: forall k1. k1 -> forall k2. k2 -> Constraint
-- RAE: need kind signatures on classes

-- SomeTypeRep ((~~) Type)
-- (~~) :: forall k1 k2. k1 -> k2 -> Constraint
-- I need: (~~) :: forall k1. k1 -> forall k2. k2 -> Constraint

class k ~~ Type => IsType (x :: k)
instance k ~~ Type => IsType (x :: k)

instance Read (SomeTypeRep IsType) where
  readsPrec p s = case readsPrec @(SomeTypeRep ConstTrue) p s of
    [(SomeTypeRep tr, "")]
      | Just HRefl <- eqT (kindRep tr) (typeRep @Type)
      -> [(SomeTypeRep tr, "")]
    _ -> error "wrong kind"

-----------------------------
-- Get the kind of a type

kindRep :: TypeRep (a :: k) -> TypeRep k
kindRep (TyCon _) = typeRep
kindRep (TyApp (f :: TypeRep (tf :: k1 -> k)) _) = case kindRep f :: TypeRep (k1 -> k) of
  TyApp _ res -> res

-- Convert an explicit TypeRep into an implicit one. Doesn't require unsafeCoerce
-- in Core
withTypeable :: forall a r. TypeRep a -> (Typeable a => r) -> r
withTypeable tr thing = unsafeCoerce (Don'tInstantiate thing :: DI a r) tr
newtype DI a r = Don'tInstantiate (Typeable a => r)

-----------------------------
-- Implicit TypeReps (Typeable)

class (Primitive a, Typeable k) => TyConAble (a :: k) where
  tyCon :: TyCon a

instance TyConAble Int       where tyCon = Int
instance TyConAble Bool      where tyCon = Bool
instance TyConAble Char      where tyCon = Char
instance TyConAble []        where tyCon = List
instance TyConAble Maybe     where tyCon = Maybe
instance TyConAble (->)      where tyCon = Arrow
instance TyConAble TYPE      where tyCon = TYPE
instance TyConAble 'LiftedRep   where tyCon = LiftedRep'
instance TyConAble RuntimeRep    where tyCon = RuntimeRep

-- Can't just define Typeable the way we want, because the instances
-- overlap. So we have to mock up instance chains via closed type families.
class Typeable' a (b :: Bool) where
  typeRep' :: TypeRep a

type family CheckPrim a where
  CheckPrim (_ _) = 'False
  CheckPrim _     = 'True

-- NB: We need the ::k and the ::Constraint so that this has a CUSK, allowing
-- the polymorphic recursion with TypeRep. See also #9200, though the requirement
-- for the constraints is correct.
type Typeable (a :: k) = (Typeable' a (CheckPrim a) :: Constraint)

instance TyConAble a => Typeable' a 'True where
  typeRep' = TyCon tyCon

instance (Typeable a, Typeable b) => Typeable' (a b) 'False where
  typeRep' = TyApp typeRep typeRep

typeRep :: forall a. Typeable a => TypeRep a
typeRep = typeRep' @_ @(CheckPrim a)

-----------------------------
-- Useful instances

instance Show (TypeRep a) where
  show (TyCon tc) = show tc
  show (TyApp tr1 tr2) = show tr1 ++ " " ++ show tr2

deriving instance Show (TyCon a)

instance TestEquality TypeRep where
  testEquality tr1 tr2
    | Just HRefl <- eqT tr1 tr2
    = Just Refl
    | otherwise
    = Nothing

---------------------------
-- More singletons

-- a TypeRep really is a singleton
type instance Sing = (TypeRep :: Type -> Type)

data SSymbol :: Symbol -> Type where
  SSym :: KnownSymbol s => SSymbol s
type instance Sing = SSymbol

instance TestEquality SSymbol where
  testEquality :: forall s1 s2. SSymbol s1 -> SSymbol s2 -> Maybe (s1 :~: s2)
  testEquality SSym SSym = sameSymbol @s1 @s2 Proxy Proxy

instance Show (SSymbol name) where
  show s@SSym = symbolVal s

--------------
-- Finds Read and Show instances for the example
getReadShowInstances :: TypeRep a
                     -> ((Show a, Read a) => r)
                     -> r
getReadShowInstances tr thing
  | Just HRefl <- eqT tr (typeRep @Int) = thing
  | Just HRefl <- eqT tr (typeRep @Bool) = thing
  | Just HRefl <- eqT tr (typeRep @Char) = thing

  | TyApp list_rep elt_rep <- tr
  , Just HRefl <- eqT list_rep (typeRep @[])
  = getReadShowInstances elt_rep $ thing

  | otherwise = error $ "I don't know how to read or show " ++ show tr

-------------------------
-- A named column in our database
data Column = Attr Symbol Type
type Col = 'Attr

-- Singleton for columns
data SColumn :: Column -> Type where
  Col :: Sing s -> TypeRep ty -> SColumn (Col s ty)
type instance Sing = SColumn

-- Extract the type of a column
type family ColType col where
  ColType (Col _ ty) = ty

-- A schema is an ordered list of named attributes
type TSchema = [Column]

-- predicate to check that a schema is free of a certain attribute
type family ColNotIn name s where
  ColNotIn _    '[]                    = 'True
  ColNotIn name ((Col name' _) ': t) =
    (name /= name') && (ColNotIn name t)

-- predicate to check that two schemas are disjoint
type family Disjoint s1 s2 where
  Disjoint '[]      _ = 'True
  Disjoint ((Col name ty) ': t) s = (ColNotIn name s) && (Disjoint t s)

-- A Row is one row of our database table, keyed by its schema.
data Row :: TSchema -> Type where
  EmptyRow :: Row '[]
  (::>) :: ColType col -> Row s -> Row (col ': s)
infixr 5 ::>

-- Map a predicate over all the types in a schema
type family AllSchemaTys c sch where
  AllSchemaTys _ '[] = (() :: Constraint)
  AllSchemaTys c (col ': cols) = (c (ColType col), AllSchemaTys c cols)

-- Convenient abbreviations for being to print and parse the types
-- in a schema
type ShowSchema s = AllSchemaTys Show s
type ReadSchema s = AllSchemaTys Read s

-- We can easily print out rows, as long as the data are printable
instance ShowSchema s => Show (Row s) where
  show EmptyRow  = ""
  show (h ::> t) = show h ++ " " ++ show t

-- In our simplistic case, we just store the list of rows. A more
-- sophisticated implementation could store some identifier to the connection
-- to an external database.
data Table :: TSchema -> Type where
  Table :: [Row s] -> Table s

instance ShowSchema s => Show (Table s) where
  show (Table rows) = unlines (map show rows)

-- The following functions parse our very simple flat file database format.

-- The file, with a name ending in ".table", consists of a sequence of lines,
-- where each line contains one entry in the table. There is no row separator;
-- if a row contains n pieces of data, that row is represented in n lines in
-- the file.

-- A schema is stored in a file ending in ".schema".
-- Each line is a column name followed by its type.

-- Read a row of a table
readRow :: ReadSchema s => Schema s -> [String] -> (Row s, [String])
readRow Nil             strs    = (EmptyRow, strs)
readRow (_ :>> _)       []      = error "Ran out of data while processing row"
readRow (_ :>> schTail) (sh:st) = (read sh ::> rowTail, strTail)
  where (rowTail, strTail) = readRow schTail st

-- Read in a table
readRows :: ReadSchema s => Schema s -> [String] -> [Row s]
readRows _   []  = []
readRows sch lst = (row : tail)
  where (row, strTail) = readRow  sch lst
        tail           = readRows sch strTail

-- Read in one line of a .schema file. Note that the type read must have kind *
readCol :: String -> (String, SomeTypeRep IsType)
readCol str = case break isSpace str of
  (name, ' ' : ty) -> (name, read ty)
  _                -> schemaError $ "Bad parse of " ++ str

-- Load in a schema.
withSchema :: String
           -> (forall (s :: TSchema). Schema s -> IO a)
           -> IO a
withSchema filename thing_inside = do
  schString <- readFile filename
  let schEntries = lines schString
      cols       = map readCol schEntries
  go cols thing_inside
  where
    go :: [(String, SomeTypeRep IsType)]
       -> (forall (s :: TSchema). Schema s -> IO a)
       -> IO a
    go []                           thing = thing Nil
    go ((name, SomeTypeRep tr) : cols) thing
      = go cols $ \schema ->
        case someSymbolVal name of
          SomeSymbol (_ :: Proxy name) ->
            thing (Col (SSym @name) tr :>> schema)

-- Load in a table of a given schema
loadTable :: ReadSchema s => String -> Schema s -> IO (Table s)
loadTable name schema = do
  dataString <- readFile name
  return (Table $ readRows schema (lines dataString))

-- In order to define strongly-typed projection from a row, we need to have a notion
-- that one schema is a subset of another. We permit the schemas to have their columns
-- in different orders. We define this subset relation via two inductively defined
-- propositions. In Haskell, these inductively defined propositions take the form of
-- GADTs. In their original form, they would look like this:
{-
data InProof :: Column -> Schema -> Type where
  InHere  :: InProof col (col ': schTail)
  InThere :: InProof col cols -> InProof col (a ': cols)

data SubsetProof :: Schema -> Schema -> Type where
  SubsetEmpty :: SubsetProof '[] s'
  SubsetCons  :: InProof col s' -> SubsetProof cols s'
              -> SubsetProof (col ': cols) s'
-}
-- However, it would be convenient to users of the database library not to require
-- building these proofs manually. So, we define type classes so that the compiler
-- builds the proofs automatically. To make everything work well together, we also
-- make the parameters to the proof GADT constructors implicit -- i.e. in the form
-- of type class constraints.

data InProof :: Column -> TSchema -> Type where
  InHere  :: InProof col (col ': schTail)
  InThere :: In name u cols => InProof (Col name u) (a ': cols)

class In (name :: Symbol) (u :: Type) (sch :: TSchema) where
  inProof :: InProof (Col name u) sch

-- These instances must be INCOHERENT because they overlap badly. The coherence
-- derives from the fact that one schema will mention a name only once, but this
-- is beyond our capabilities to easily encode, given the lack of a solver for
-- type-level finite maps.
instance {-# INCOHERENT #-} In name u ((Col name u) ': schTail) where
  inProof = InHere
instance {-# INCOHERENT #-} In name u cols => In name u (a ': cols) where
  inProof = InThere

data SubsetProof :: TSchema -> TSchema -> Type where
  SubsetEmpty :: SubsetProof '[] s'
  SubsetCons :: (In name u s', Subset cols s')
             => Proxy name -> Proxy u -> SubsetProof ((Col name u) ': cols) s'

class SubsetSupport s s' => Subset (s :: TSchema) (s' :: TSchema) where
  subset :: SubsetProof s s'

  -- The use of this constraint family allows us to assume a subset relationship
  -- when we recur on the structure of s.
  type SubsetSupport s s' :: Constraint

instance Subset '[] s' where
  subset = SubsetEmpty
  type SubsetSupport '[] s' = ()

instance (In name u s', Subset cols s') =>
           Subset ((Col name u) ': cols) s' where
  subset = SubsetCons Proxy Proxy
  type SubsetSupport ((Col name u) ': cols) s' = Subset cols s'

-- To access the data in a structured (and well-typed!) way, we use
-- an RA (short for Relational Algebra). An RA is indexed by the schema
-- of the data it produces.

data RA :: TSchema -> Type where
  -- The RA includes all data represented by the handle.
  Read :: Table s -> RA s

  -- The RA is a Cartesian product of the two RAs provided. Note that
  -- the schemas of the two provided RAs must be disjoint.
  Product :: (Disjoint s s' ~ 'True) => RA s -> RA s' -> RA (s ++ s')

  -- The RA is a projection conforming to the schema provided. The
  -- type-checker ensures that this schema is a subset of the data
  -- included in the provided RA.
  Project :: Subset s' s => RA s -> RA s'

  -- The RA contains only those rows of the provided RA for which
  -- the provided expression evaluates to True. Note that the
  -- schema of the provided RA and the resultant RA are the same
  -- because the columns of data are the same. Also note that
  -- the expression must return a Bool for this to type-check.
  Select :: Expr s Bool -> RA s -> RA s

-- Other constructors would be added in a more robust database
-- implementation.

-- An Expr is used with the Select constructor to choose some
-- subset of rows from a table. Expressions are indexed by the
-- schema over which they operate and the return value they
-- produce.
data Expr :: TSchema -> Type -> Type where
  (:+), (:-), (:*), (:/) :: Expr s Int -> Expr s Int -> Expr s Int

  (:<), (:<=), (:>), (:>=), (:==), (:/=)
    :: Ord a => Expr s a -> Expr s a -> Expr s Bool

  -- A literal
  Literal :: ty -> Expr s ty

  -- element of a list
  ElementOf :: Eq ty => Expr s ty -> Expr s [ty] -> Expr s Bool

  -- Projection in an expression -- evaluates to the value
  -- of the named column.
  Element :: In name ty s => Proxy name -> Expr s ty

-- Choose the elements of one list based on truth values in another
choose :: [Bool] -> [a] -> [a]
choose bs as = [ a | (a,True) <- zip as bs ]

-- Project a component of one row, assuming that the desired projection
-- is valid.
projectRow :: forall sub super.
              Subset sub super => Row super -> Row sub
projectRow r = case subset @sub @super of
  SubsetEmpty -> EmptyRow
  SubsetCons (_ :: Proxy name) (_ :: Proxy ty) ->
      find_datum inProof r ::> projectRow r
    where
      find_datum :: InProof (Col name ty) s -> Row s -> ty
      find_datum InHere  (h ::> _) = h
      find_datum InThere (_ ::> t) = find_datum inProof t

-- Evaluate an Expr
eval :: Expr s ty -> Row s -> ty
eval (a :+ b)  r = eval a r +  eval b r
eval (a :- b)  r = eval a r -  eval b r
eval (a :* b)  r = eval a r *  eval b r
eval (a :/ b)  r = eval a r `div` eval b r
eval (a :< b)  r = eval a r <  eval b r
eval (a :<= b) r = eval a r <= eval b r
eval (a :> b)  r = eval a r >  eval b r
eval (a :>= b) r = eval a r >= eval b r
eval (a :== b) r = eval a r == eval b r
eval (a :/= b) r = eval a r /= eval b r
eval (Literal n)                 _ = n
eval (ElementOf elt list)        r = eval elt r `elem` eval list r
eval (Element (_ :: Proxy name)) r = get_element inProof r
  where
    get_element :: InProof (Col name ty) s -> Row s -> ty
    get_element InHere (elt ::> _) = elt
    get_element InThere (_ ::> tail) = get_element inProof tail

-- Append two rows. Needed for Cartesian product.
rowAppend :: Row s -> Row s' -> Row (s ++ s')
rowAppend EmptyRow  r = r
rowAppend (h ::> t) r = h ::> rowAppend t r

-- The query function is the eliminator for an RA. It returns a list of
-- rows containing the data produced by the RA. In the IO monad only
-- because more sophisticated implementations would actually go out to
-- a DB server for this.
query :: RA s -> IO [Row s]
query (Read (Table rows)) = return rows
query (Product ra rb) = do
  rowsa <- query ra
  rowsb <- query rb
  return [ rowAppend rowa rowb | rowa <- rowsa, rowb <- rowsb ]
query (Project ra)     = map projectRow <$> query ra
query (Select expr ra) = filter (eval expr) <$> query ra

field :: forall name ty s. In name ty s => Expr s ty
field = Element (Proxy :: Proxy name)

-- A schema is a list of columns, with
-- data Column = Col String Type
-- NB: Dependent type support is still experimental
checkIn :: Î  name -> Î  ty -> Î  schema
        -> (In name ty schema => r)
        -> r
checkIn name _  Nil                        _
  = schemaError ("Field " ++ show name ++ " not found.")
checkIn name ty ((Col name' ty') :>> rest) callback
  = case (name `eq` name', ty `eq` ty') of
      (Just Refl, Just Refl) -> callback
      (Just _,    _)         -> schemaError ("Found " ++ show name ++
                                             " but it maps to " ++ show ty')
      _                      -> checkIn name ty rest callback

-- example call:
-- checkIn "id" Int schema ({- access "id" and assume it has type Int -})

-- Establish a Subset constraint
checkSubset :: Î  sch1 -> Î  sch2 -> (Subset sch1 sch2 => r) -> r
checkSubset Nil                    _     callback = callback
checkSubset (Col name ty :>> rest) super callback
  = checkSubset rest super $
    checkIn name ty super $
    callback

-- Check that two names are distinct
checkNotEqual :: forall (name1 :: Symbol) name2 r.
                 Î  name1 -> Î  name2
              -> (((name1 /= name2) ~ 'True) => r) -> r
checkNotEqual name1 name2 callback
  = case name1 `eq` name2 of
      Just Refl -> schemaError $ "Found " ++ show name1 ++
                          " in both supposedly disjoint schemas."
      Nothing   -> assumeEquality @(name1 /= name2) @'True $
                   callback

-- Establish a ColNotIn condition
checkColNotIn :: Î  name -> Î  sch2
              -> ((ColNotIn name sch2 ~ 'True) => r) -> r
checkColNotIn _    Nil                    callback = callback
checkColNotIn name (Col name' _ :>> rest) callback
  = checkNotEqual name name' $
    checkColNotIn name rest $
    callback

-- Establish a Disjointness constraint
checkDisjoint :: Î  sch1 -> Î  sch2
              -> ((Disjoint sch1 sch2 ~ 'True) => r) -> r
checkDisjoint Nil                   _    callback = callback
checkDisjoint (Col name _ :>> rest) sch2 callback
  = checkColNotIn name sch2 $
    checkDisjoint rest sch2 $
    callback

-- Establish a ShowSchema constraint
checkShowSchema :: Î  sch -> (ShowSchema sch => r) -> r
checkShowSchema Nil                 callback = callback
checkShowSchema (Col _ ty :>> rest) callback
  = getReadShowInstances ty $
    checkShowSchema rest $
    callback

-- Establish a ReadSchema constraint
checkReadSchema :: Î  sch -> (ReadSchema sch => r) -> r
checkReadSchema Nil                 callback = callback
checkReadSchema (Col _ ty :>> rest) callback
  = getReadShowInstances ty $
    checkReadSchema rest $
    callback

-- Terminate program with an easy-to-understand message
schemaError :: String -> a
schemaError str = errorWithoutStackTrace $ "Schema validation error: " ++ str

-------------------------
type NameSchema = [ Col "first" String, Col "last" String ]

printName :: Row NameSchema -> IO ()
printName (first ::> last ::> _) = putStrLn (first ++ " " ++ last)

readDB classes_sch students_sch = do
  classes_tab  <- loadTable "classes.table" classes_sch
  students_tab <- loadTable "students.table" students_sch

  putStr "Whose students do you want to see? "
  prof <- getLine

  let joined = Project (
                Select (field @"id" @Int `ElementOf` field @"students") (
                 Product (Select (field @"prof" :== Literal prof) (Read classes_tab))
                         (Read students_tab)))
  rows <- query joined
  mapM_ printName rows

------------------
main :: IO ()
main = withSchema "classes.schema" $ \classes_sch ->
       withSchema "students.schema" $ \students_sch ->
       checkDisjoint classes_sch students_sch $
       checkIn (SSym @"students") (typeRep @[Int]) (classes_sch %:++ students_sch) $
       checkIn (SSym @"prof") (typeRep @String) classes_sch $
       checkIn (SSym @"last") (typeRep @String) (classes_sch %:++ students_sch) $
       checkIn (SSym @"id") (typeRep @Int) (classes_sch %:++ students_sch) $
       checkIn (SSym @"first") (typeRep @String) (classes_sch %:++ students_sch) $
       checkReadSchema students_sch $
       checkReadSchema classes_sch $
       readDB classes_sch students_sch


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

module RAE_T32b where

import Data.Kind

data family Sing (k :: Type) :: k -> Type

data TyArr (a :: Type) (b :: Type) :: Type
type family (a :: TyArr k1 k2 -> Type) @@ (b :: k1) :: k2
$(return [])

data Sigma (p :: Type) (r :: TyArr p Type -> Type) :: Type where
  Sigma :: forall (p :: Type) (r :: TyArr p Type -> Type)
                  (a :: p) (b :: r @@ a).
           Sing Type p -> Sing (TyArr p Type -> Type) r -> Sing p a ->
           Sing (r @@ a) b -> Sigma p r
$(return [])

data instance Sing (Sigma p r) (x :: Sigma p r) :: Type where
  SSigma :: forall (p :: Type) (r :: TyArr p Type -> Type)
                   (a :: p) (b :: r @@ a)
                   (sp :: Sing Type p) (sr :: Sing (TyArr p Type -> Type) r)
                   (sa :: Sing p a) (sb :: Sing (r @@ a) b).
            Sing (Sing (r @@ a) b) sb ->
            Sing (Sigma p r) ('Sigma sp sr sa sb)


{-# LANGUAGE ExplicitForAll, KindSignatures, PartialTypeSignatures #-}

module T11241 where

foo :: forall (a :: _) . a -> a
foo = id


module T11311 where

import Data.Kind

foo :: ()
foo = (id :: Type -> Type) undefined `seq` ()

main = print foo


{-# LANGUAGE ImplicitParams, PolyKinds, ExplicitForAll #-}

module T11405 where

import GHC.Exts
import GHC.Stack

x :: forall (v :: RuntimeRep) (a :: TYPE v). (?callStack :: CallStack) => a
x = undefined


{-# LANGUAGE PolyKinds, KindSignatures, ExplicitForAll, RankNTypes #-}

module T11635 where

import Data.Kind

data X (a :: forall k. k -> Type) b = X


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}

module T11711 where

import Data.Kind (Type)

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

data TypeRep (a :: k) where
    TrTyCon :: String -> TypeRep k -> TypeRep (a :: k)
    TrApp   :: forall k1 k2 (a :: k1 -> k2) (b :: k1).
               TypeRep (a :: k1 -> k2)
            -> TypeRep (b :: k1)
            -> TypeRep (a b)

class Typeable (a :: k) where
    typeRep :: TypeRep a

data SomeTypeRep where
    SomeTypeRep :: forall k (a :: k). TypeRep a -> SomeTypeRep

eqTypeRep :: TypeRep a -> TypeRep b -> Maybe (a :~~: b)
eqTypeRep = undefined

typeRepKind :: forall k (a :: k). TypeRep a -> TypeRep k
typeRepKind = undefined

instance Typeable Type where
  typeRep = TrTyCon "Type" typeRep

funResultTy :: SomeTypeRep -> SomeTypeRep -> Maybe SomeTypeRep
funResultTy (SomeTypeRep f) (SomeTypeRep x)
  | Just HRefl <- (typeRep :: TypeRep Type) `eqTypeRep` typeRepKind f
  , TRFun arg res <- f
  , Just HRefl <- arg `eqTypeRep` x
  = Just (SomeTypeRep res)
  | otherwise
  = Nothing

trArrow :: TypeRep (->)
trArrow = undefined

pattern TRFun :: forall fun. ()
              => forall arg res. (fun ~ (arg -> res))
              => TypeRep arg
              -> TypeRep res
              -> TypeRep fun
pattern TRFun arg res <- TrApp (TrApp (eqTypeRep trArrow -> Just HRefl) arg) res


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

module T11719 where

import Data.Kind

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type

type family (f :: a ~> b) @@ (x :: a) :: b

data Null a = Nullable a | NotNullable a

type family ((f :: b ~> c) âˆ˜ (g :: a ~> b)) (x :: a) :: c where
  (f âˆ˜ g) x = f @@ (g @@ x)

type family BaseType (k :: forall a. a ~> Type) (x :: b) :: Type where   -- this fails :(


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeOperators #-}

module T11966 where

import Data.Kind (Type)
import GHC.TypeLits (Symbol)

-- Simplification
type family Col (f :: k -> j) (x :: k) :: Type

-- Base types
data PGBaseType = PGInteger | PGText

-- Transformations
data Column t = Column Symbol t
newtype Nullable t = Nullable t
newtype HasDefault t = HasDefault t

-- Interpretations
data Expr k

data Record (f :: forall k. k -> Type) =
  Record {rX :: Col f ('Column "x" 'PGInteger)
         ,rY :: Col f ('Column "y" ('Nullable 'PGInteger))
         ,rZ :: Col f ('HasDefault 'PGText)}

x :: Record Expr
x = undefined


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

module T12176 where

import Data.Kind

data Proxy :: forall k. k -> Type where
  MkProxy :: forall k (a :: k). Proxy a

data X where
  MkX :: forall (k :: Type) (a :: k). Proxy a -> X

type Expr = (MkX :: forall (a :: Bool). Proxy a -> X)

type family Foo (x :: forall (a :: k). Proxy a -> X) where
  Foo (MkX :: forall (a :: k). Proxy a -> X) = (MkProxy :: Proxy k)

type Bug = Foo Expr  -- this failed with #12176


-- Based on https://github.com/idris-lang/Idris-dev/blob/v0.9.10/libs/effects/Effects.idr

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

module T12442 where

import Data.Kind

data family Sing (a :: k)
data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>
type family (a :: k1 ~> k2) @@ (b :: k1) :: k2

data TyCon1 :: (Type -> Type) -> (Type ~> Type)
type instance (TyCon1 t) @@ x = t x

data TyCon2 :: (Type -> Type -> Type) -> (Type ~> Type ~> Type)
type instance (TyCon2 t) @@ x = (TyCon1 (t x))

data TyCon3 :: (Type -> Type -> Type -> Type) -> (Type ~> Type ~> Type ~> Type)
type instance (TyCon3 t) @@ x = (TyCon2 (t x))

type Effect = Type ~> Type ~> Type ~> Type

data EFFECT :: Type where
  MkEff :: Type -> Effect -> EFFECT

data EffElem :: (Type ~> Type ~> Type ~> Type) -> Type -> [EFFECT] -> Type where
  Here :: EffElem x a (MkEff a x ': xs)

data instance Sing (elem :: EffElem x a xs) where
  SHere :: Sing Here

type family UpdateResTy b t (xs :: [EFFECT]) (elem :: EffElem e a xs)
                        (thing :: e @@ a @@ b @@ t) :: [EFFECT] where
  UpdateResTy b _ (MkEff a e ': xs) Here n = MkEff b e ': xs

data EffM :: (Type ~> Type) -> [EFFECT] -> [EFFECT] -> Type -> Type

effect :: forall e a b t xs prf eff m.
          Sing (prf :: EffElem e a xs)
       -> Sing (eff :: e @@ a @@ b @@ t)
       -> EffM m xs (UpdateResTy b t xs prf eff) t
effect = undefined

data State :: Type -> Type -> Type -> Type where
  Get :: State a a a

data instance Sing (e :: State a b c) where
  SGet :: Sing Get

type STATE t = MkEff t (TyCon3 State)

get_ :: forall m x. EffM m '[STATE x] '[STATE x] x
get_ = effect @(TyCon3 State) SHere SGet


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

module T12742 where

import Data.Kind

type family F :: forall k2. (k1, k2)

data T :: (forall k2. (Bool, k2)) -> Type

type S = T F


{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeFamilies, TypeFamilyDependencies #-}
{-# LANGUAGE KindSignatures, DataKinds, PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications     #-}
module T13538 where

import GHC.TypeLits
import Data.Proxy

-- | Synonym for a type-level snoc (injective!)
type (ns :: [k]) +: (n :: k) = GetList1 (SinkFirst (n ': ns))
infixl 5 +:

-- | A weird data type used to make `(+:)` operation injective.
--   `List k [k]` must have at least two elements.
data List1 k = L1Single k | L1Head k [k]

-- | Sink first element of a list to the end of the list
type family SinkFirst (xs :: [k]) = (ys :: List1 k) | ys -> xs where
  SinkFirst '[y]       = 'L1Single y
  -- SinkFirst (y ': x ': xs :: [Nat])
  --     = ('L1Head x (GetList1Nat (SinkFirst (y ': xs))) :: List1 Nat)
  SinkFirst (y ': x ': xs :: [k])
      = ('L1Head x (GetList1    (SinkFirst (y ': xs))) :: List1 k)

type family GetList1 (ts :: List1 k) = (rs :: [k]) | rs -> ts where
  GetList1 ('L1Single x) = '[x]
  GetList1 ('L1Head y (x ':xs)) = y ': x ': xs
type family GetList1Nat (ts :: List1 Nat) = (rs :: [Nat]) | rs -> ts where
  GetList1Nat ('L1Single x) = '[x]
  GetList1Nat ('L1Head y (x ': xs)) = y ': x ': xs

type family (++) (as :: [k]) (bs :: [k]) :: [k] where
  '[] ++ bs = bs
  (a ': as) ++ bs = a ': (as ++ bs)

ff :: Proxy k -> Proxy (as +: k) -> Proxy (k ': bs) -> Proxy (as ++ bs)
ff _ _ _ = Proxy

yy :: Proxy '[3,7,2]
yy = ff (Proxy @5) (Proxy @'[3,7,5]) (Proxy @'[5,2])


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T13910 where

import Data.Kind
import Data.Type.Equality

data family Sing (a :: k)

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

data SomeSing k where
  SomeSing :: Sing (a :: k) -> SomeSing k

withSomeSing :: forall k r
              . SingKind k
             => Demote k
             -> (forall (a :: k). Sing a -> r)
             -> r
withSomeSing x f =
  case toSing x of
    SomeSing x' -> f x'

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>

type family Apply (f :: k1 ~> k2) (x :: k1) :: k2
type a @@ b = Apply a b
infixl 9 @@

data FunArrow = (:->) | (:~>)

class FunType (arr :: FunArrow) where
  type Fun (k1 :: Type) arr (k2 :: Type) :: Type

class FunType arr => AppType (arr :: FunArrow) where
  type App k1 arr k2 (f :: Fun k1 arr k2) (x :: k1) :: k2

type FunApp arr = (FunType arr, AppType arr)

instance FunType (:->) where
  type Fun k1 (:->) k2 = k1 -> k2

$(return []) -- This is only necessary for GHC 8.0 -- GHC 8.2 is smarter

instance AppType (:->) where
  type App k1 (:->) k2 (f :: k1 -> k2) x = f x

instance FunType (:~>) where
  type Fun k1 (:~>) k2 = k1 ~> k2

$(return [])

instance AppType (:~>) where
  type App k1 (:~>) k2 (f :: k1 ~> k2) x = f @@ x

infixr 0 -?>
type (-?>) (k1 :: Type) (k2 :: Type) (arr :: FunArrow) = Fun k1 arr k2

data instance Sing (z :: a :~: b) where
  SRefl :: Sing Refl

instance SingKind (a :~: b) where
  type Demote (a :~: b) = a :~: b
  fromSing SRefl = Refl
  toSing Refl = SomeSing SRefl

(~>:~:) :: forall (k :: Type) (a :: k) (b :: k) (r :: a :~: b) (p :: forall (y :: k). a :~: y ~> Type).
           Sing r
        -> p @@ Refl
        -> p @@ r
(~>:~:) SRefl pRefl = pRefl

type WhyReplacePoly (arr :: FunArrow) (from :: t) (p :: (t -?> Type) arr)
                    (y :: t) (e :: from :~: y) = App t arr Type p y
data WhyReplacePolySym (arr :: FunArrow) (from :: t) (p :: (t -?> Type) arr)
  :: forall (y :: t). from :~: y ~> Type
type instance Apply (WhyReplacePolySym arr from p :: from :~: y ~> Type) x
  = WhyReplacePoly arr from p y x

replace :: forall (t :: Type) (from :: t) (to :: t) (p :: t -> Type).
           p from
        -> from :~: to
        -> p to
replace = replacePoly @(:->)

replaceTyFun :: forall (t :: Type) (from :: t) (to :: t) (p :: t ~> Type).
                p @@ from
             -> from :~: to
             -> p @@ to
replaceTyFun = replacePoly @(:~>) @_ @_ @_ @p

replacePoly :: forall (arr :: FunArrow) (t :: Type) (from :: t) (to :: t)
                      (p :: (t -?> Type) arr).
               FunApp arr
            => App t arr Type p from
            -> from :~: to
            -> App t arr Type p to
replacePoly from eq =
  withSomeSing eq $ \(singEq :: Sing r) ->
    (~>:~:) @t @from @to @r @(WhyReplacePolySym arr from p) singEq from

type WhyLeibnizPoly (arr :: FunArrow) (f :: (t -?> Type) arr) (a :: t) (z :: t)
  = App t arr Type f a -> App t arr Type f z
data WhyLeibnizPolySym (arr :: FunArrow) (f :: (t -?> Type) arr) (a :: t)
  :: t ~> Type
type instance Apply (WhyLeibnizPolySym arr f a) z = WhyLeibnizPoly arr f a z

leibnizPoly :: forall (arr :: FunArrow) (t :: Type) (f :: (t -?> Type) arr)
                      (a :: t) (b :: t).
               FunApp arr
            => a :~: b
            -> App t arr Type f a
            -> App t arr Type f b
leibnizPoly = replaceTyFun @t @a @b @(WhyLeibnizPolySym arr f a) id

leibniz :: forall (t :: Type) (f :: t -> Type) (a :: t) (b :: t).
           a :~: b
        -> f a
        -> f b
leibniz = replaceTyFun @t @a @b @(WhyLeibnizPolySym (:->) f a) id
-- The line above is what you get if you inline the definition of leibnizPoly.
-- It causes a panic, however.
--
-- An equivalent implementation is commented out below, which does *not*
-- cause GHC to panic.
--
-- leibniz = leibnizPoly @(:->)

leibnizTyFun :: forall (t :: Type) (f :: t ~> Type) (a :: t) (b :: t).
                a :~: b
             -> f @@ a
             -> f @@ b
leibnizTyFun = leibnizPoly @(:~>) @_ @f


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module T13938 where

import T13938a
import Data.Kind
import Data.Type.Equality
import GHC.TypeLits

type family Length (l :: [a]) :: Nat where {}
type family Map (f :: a ~> b) (l :: [a]) :: [b] where {}

type WhyMapPreservesLength (f :: x ~> y) (l :: [x])
  = Length l :~: Length (Map f l)
data WhyMapPreservesLengthSym1 (f :: x ~> y) :: [x] ~> Type
type instance Apply (WhyMapPreservesLengthSym1 f) l = WhyMapPreservesLength f l

mapPreservesLength :: forall (x :: Type) (y :: Type) (f :: x ~> y) (l :: [x]).
                      Length l :~: Length (Map f l)
mapPreservesLength
  = elimListTyFun @x @(WhyMapPreservesLengthSym1 f) @l undefined undefined undefined


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T13938a where

import Data.Kind (Type)

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

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>

type family Apply (f :: k1 ~> k2) (x :: k1) :: k2
type a @@ b = Apply a b
infixl 9 @@

data FunArrow = (:->) -- ^ '(->)'
              | (:~>) -- ^ '(~>)'

class FunType (arr :: FunArrow) where
  type Fun (k1 :: Type) arr (k2 :: Type) :: Type

class FunType arr => AppType (arr :: FunArrow) where
  type App k1 arr k2 (f :: Fun k1 arr k2) (x :: k1) :: k2

type FunApp arr = (FunType arr, AppType arr)

instance FunType (:->) where
  type Fun k1 (:->) k2 = k1 -> k2

$(return []) -- This is only necessary for GHC 8.0 -- GHC 8.2 is smarter

instance AppType (:->) where
  type App k1 (:->) k2 (f :: k1 -> k2) x = f x

instance FunType (:~>) where
  type Fun k1 (:~>) k2 = k1 ~> k2

$(return [])

instance AppType (:~>) where
  type App k1 (:~>) k2 (f :: k1 ~> k2) x = f @@ x

infixr 0 -?>
type (-?>) (k1 :: Type) (k2 :: Type) (arr :: FunArrow) = Fun k1 arr k2

elimList :: forall (a :: Type) (p :: [a] -> Type) (l :: [a]).
            Sing l
         -> p '[]
         -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> p xs -> p (x:xs))
         -> p l
elimList = elimListPoly @(:->)

elimListTyFun :: forall (a :: Type) (p :: [a] ~> Type) (l :: [a]).
                 Sing l
              -> p @@ '[]
              -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> p @@ xs -> p @@ (x:xs))
              -> p @@ l
elimListTyFun = elimListPoly @(:~>) @_ @p

elimListPoly :: forall (arr :: FunArrow) (a :: Type) (p :: ([a] -?> Type) arr) (l :: [a]).
                FunApp arr
             => Sing l
             -> App [a] arr Type p '[]
             -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> App [a] arr Type p xs -> App [a] arr Type p (x:xs))
             -> App [a] arr Type p l
elimListPoly SNil                      pNil _     = pNil
elimListPoly (SCons x (xs :: Sing xs)) pNil pCons = pCons x xs (elimListPoly @arr @a @p @xs xs pNil pCons)


{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeOperators #-}
module T14038 where

import Data.Kind (Type)

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

data TyFun :: Type -> Type -> Type
type a ~> b = TyFun a b -> Type
infixr 0 ~>

type family Apply (f :: k1 ~> k2) (x :: k1) :: k2
type a @@ b = Apply a b
infixl 9 @@

data FunArrow = (:->) -- ^ '(->)'
              | (:~>) -- ^ '(~>)'

class FunType (arr :: FunArrow) where
  type Fun (k1 :: Type) arr (k2 :: Type) :: Type

class FunType arr => AppType (arr :: FunArrow) where
  type App k1 arr k2 (f :: Fun k1 arr k2) (x :: k1) :: k2

type FunApp arr = (FunType arr, AppType arr)

instance FunType (:->) where
  type Fun k1 (:->) k2 = k1 -> k2

instance AppType (:->) where
  type App k1 (:->) k2 (f :: k1 -> k2) x = f x

instance FunType (:~>) where
  type Fun k1 (:~>) k2 = k1 ~> k2

instance AppType (:~>) where
  type App k1 (:~>) k2 (f :: k1 ~> k2) x = f @@ x

infixr 0 -?>
type (-?>) (k1 :: Type) (k2 :: Type) (arr :: FunArrow) = Fun k1 arr k2

elimList :: forall (a :: Type) (p :: [a] -> Type) (l :: [a]).
            Sing l
         -> p '[]
         -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> p xs -> p (x:xs))
         -> p l
elimList = elimListPoly @(:->)

elimListTyFun :: forall (a :: Type) (p :: [a] ~> Type) (l :: [a]).
                 Sing l
              -> p @@ '[]
              -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> p @@ xs -> p @@ (x:xs))
              -> p @@ l
elimListTyFun = elimListPoly @(:~>) @_ @p

elimListPoly :: forall (arr :: FunArrow) (a :: Type) (p :: ([a] -?> Type) arr) (l :: [a]).
                FunApp arr
             => Sing l
             -> App [a] arr Type p '[]
             -> (forall (x :: a) (xs :: [a]). Sing x -> Sing xs -> App [a] arr Type p xs -> App [a] arr Type p (x:xs))
             -> App [a] arr Type p l
elimListPoly SNil                      pNil _     = pNil
elimListPoly (SCons x (xs :: Sing xs)) pNil pCons = pCons x xs (elimListPoly @arr @a @p @xs xs pNil pCons)


{-# LANGUAGE TypeFamilies, DataKinds, PolyKinds, ExplicitForAll, GADTs,
             UndecidableInstances, RankNTypes, ScopedTypeVariables #-}

module T14066a where

import Data.Proxy
import Data.Kind
import Data.Type.Bool

type family Bar x y where
  Bar (x :: a) (y :: b) = Int
  Bar (x :: c) (y :: d) = Bool   -- a,b,c,d should be TyVarTvs and unify appropriately

  -- the two k's, even though they have different scopes, should unify in the
  -- kind-check and then work in the type-check because Prox3 has been generalized

data Prox3 a where
  MkProx3a :: Prox3 (a :: k1)
  MkProx3b :: Prox3 (a :: k2)

  -- This probably should be rejected, as it's polymorphic recursion without a CUSK.
  -- But GHC accepts it because the polymorphic occurrence is at a type variable.
data T0 a = forall k (b :: k). MkT0 (T0 b) Int

  -- k and j should unify
type family G x a where
  G Int (b :: k) = Int
  G Bool (c :: j) = Bool

-- this last example just checks that GADT pattern-matching on kinds still works.
-- nothing new here.
data T (a :: k) where
  MkT :: T (a :: Type -> Type)

data S (a :: Type -> Type) where
  MkS :: S a

f :: forall k (a :: k). Proxy a -> T a -> ()
f _ MkT = let y :: S a
              y = MkS
          in ()

-- This is questionable. Should we use the RHS to determine dependency? It works
-- now, but if it stops working in the future, that's not a deal-breaker.
type P k a = Proxy (a :: k)

-- This is a challenge. It should be accepted, but only because c's kind is learned
-- to be Proxy True, allowing b to be assigned kind `a`. If we don't know c's kind,
-- then GHC would need to be convinced that If (c's kind) b d always has kind `a`.
-- Naively, we don't know about c's kind early enough.

data SameKind :: forall k. k -> k -> Type
type family IfK (e :: Proxy (j :: Bool)) (f :: m) (g :: n) :: If j m n where
   IfK (_ :: Proxy True)  f _ = f
   IfK (_ :: Proxy False) _ g = g
x :: forall c. (forall a b (d :: a). SameKind (IfK c b d) d) -> (Proxy (c :: Proxy True))
x _ = Proxy

f2 :: forall b. b -> Proxy Maybe
f2 x = fstOf3 y :: Proxy Maybe
  where
    y :: (Proxy a, Proxy c, b)
    y = (Proxy, Proxy, x)

fstOf3 (x, _, _) = x

f3 :: forall b. b -> Proxy Maybe
f3 x = fst y :: Proxy Maybe
  where
    y :: (Proxy a, b)
    y = (Proxy, x)

-- cf. dependent/should_fail/T14066h. Here, y's type does *not* capture any variables,
-- so it is generalized, even with MonoLocalBinds.
f4 x = (fst y :: Proxy Int, fst y :: Proxy Maybe)
  where
    y :: (Proxy a, Int)
    y = (Proxy, x)


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

module T14066h where

import Data.Proxy

f :: forall b. b -> (Proxy Int, Proxy Maybe)
f x = (fst y :: Proxy Int, fst y :: Proxy Maybe)
  where
    y :: (Proxy a, b)  -- this generalizes over the kind of a
    y = (Proxy, x)