{-# LANGUAGE MagicHash #-}
{-# LANGUAGE UnboxedTuples #-}

module Main where

import Data.Bits
import GHC.Exts

wordWidth :: Int
wordWidth = finiteBitSize (0 :: Word)

checkI
    :: (Int, Int)                          -- ^ expected results
    -> (Int# -> Int# -> (# Int#, Int# #))  -- ^ primop
    -> Int                                 -- ^ first argument
    -> Int                                 -- ^ second argument
    -> Maybe String                        -- ^ maybe error
checkI (expX, expY) op (I# a) (I# b) =
  case op a b of
      (# x, y #)
          | I# x == expX && I# y == expY -> Nothing
          | otherwise ->
              Just $
                  "Expected " ++ show expX ++ " and " ++ show expY
                      ++ " but got " ++ show (I# x) ++ " and " ++ show (I# y)
checkW
    :: (Word, Word)                            -- ^ expected results
    -> (Word# -> Word# -> (# Word#, Word# #))  -- ^ primop
    -> Word                                    -- ^ first argument
    -> Word                                    -- ^ second argument
    -> Maybe String                            -- ^ maybe error
checkW (expX, expY) op (W# a) (W# b) =
    case op a b of
        (# x, y #)
            | W# x == expX && W# y == expY -> Nothing
            | otherwise ->
                Just $
                    "Expected " ++ show expX ++ " and " ++ show expY
                        ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y)

checkW2
    :: (Word, Word)  -- ^ expected results
    -> (Word# -> Word# -> Word# -> (# Word#, Word# #))
                     -- ^ primop
    -> Word          -- ^ first argument
    -> Word          -- ^ second argument
    -> Word          -- ^ third argument
    -> Maybe String  -- ^ maybe error
checkW2 (expX, expY) op (W# a) (W# b) (W# c) =
    case op a b c of
        (# x, y #)
            | W# x == expX && W# y == expY -> Nothing
            | otherwise ->
                Just $
                    "Expected " ++ show expX ++ " and " ++ show expY
                        ++ " but got " ++ show (W# x) ++ " and " ++ show (W# y)

check :: String -> Maybe String -> IO ()
check s (Just err) = error $ "Error for " ++ s ++ ": " ++ err
check _ Nothing    = return ()

main :: IO ()
main = do
    -- First something trivial
    check "addIntC# maxBound 0" $ checkI (maxBound, 0) addIntC# maxBound 0
    check "addIntC# 0 maxBound" $ checkI (maxBound, 0) addIntC# 0 maxBound
    -- Overflows
    check "addIntC# maxBound 1" $ checkI (minBound, 1) addIntC# maxBound 1
    check "addIntC# 1 maxBound" $ checkI (minBound, 1) addIntC# 1 maxBound
    check "addIntC# maxBound 2" $ checkI (minBound + 1, 1) addIntC# maxBound 2
    check "addIntC# 2 maxBound" $ checkI (minBound + 1, 1) addIntC# 2 maxBound
    check "addIntC# minBound minBound" $
      checkI (0, 1) addIntC# minBound minBound

    -- First something trivial
    check "subIntC# minBound 0" $ checkI (minBound, 0) subIntC# minBound 0
    -- Overflows
    check "subIntC# minBound 1" $ checkI (maxBound, 1) subIntC# minBound 1
    check "subIntC# minBound 1" $ checkI (maxBound - 1, 1) subIntC# minBound 2
    check "subIntC# 0 minBound" $ checkI (minBound, 1) subIntC# 0 minBound
    check "subIntC# -1 minBound" $ checkI (maxBound, 0) subIntC# (-1) minBound
    check "subIntC# minBound -1" $
      checkI (minBound + 1, 0) subIntC# minBound (-1)

    -- First something trivial (note that the order of results is different!)
    check "plusWord2# maxBound 0" $ checkW (0, maxBound) plusWord2# maxBound 0
    check "plusWord2# 0 maxBound" $ checkW (0, maxBound) plusWord2# 0 maxBound
    -- Overflows
    check "plusWord2# maxBound 1" $
      checkW (1, minBound) plusWord2# maxBound 1
    check "plusWord2# 1 maxBound" $
      checkW (1, minBound) plusWord2# 1 maxBound
    check "plusWord2# maxBound 2" $
      checkW (1, minBound + 1) plusWord2# maxBound 2
    check "plusWord2# 2 maxBound" $
      checkW (1, minBound + 1) plusWord2# 2 maxBound

    check "timesWord2# maxBound 0" $ checkW (0, 0) timesWord2# maxBound 0
    check "timesWord2# 0 maxBound" $ checkW (0, 0) timesWord2# 0 maxBound
    check "timesWord2# maxBound 1" $ checkW (0, maxBound) timesWord2# maxBound 1
    check "timesWord2# 1 maxBound" $ checkW (0, maxBound) timesWord2# 1 maxBound
    -- Overflows
    check "timesWord2# (2^(N-1)) 2"   $ checkW (1, 0) timesWord2# (2 ^ (wordWidth-1)) 2
    check "timesWord2# (2^(N-1)) 2^2" $ checkW (2, 0) timesWord2# (2 ^ (wordWidth-1)) (2 ^ 2)
    check "timesWord2# (2^(N-1)) 2^3" $ checkW (4, 0) timesWord2# (2 ^ (wordWidth-1)) (2 ^ 3)
    check "timesWord2# (2^(N-1)) 2^4" $ checkW (8, 0) timesWord2# (2 ^ (wordWidth-1)) (2 ^ 4)
    check "timesWord2# maxBound 2" $
      checkW (1, maxBound - 1) timesWord2# maxBound 2
    check "timesWord2# 2 maxBound" $
      checkW (1, maxBound - 1) timesWord2# 2 maxBound
    check "timesWord2# maxBound 3" $
      checkW (2, maxBound - 2) timesWord2# maxBound 3
    check "timesWord2# 3 maxBound" $
      checkW (2, maxBound - 2) timesWord2# 3 maxBound

    check "quotRemWord2# 0 0 1" $ checkW2 (0, 0) quotRemWord2# 0 0 1
    check "quotRemWord2# 0 4 2" $ checkW2 (2, 0) quotRemWord2# 0 4 2
    check "quotRemWord2# 0 7 3" $ checkW2 (2, 1) quotRemWord2# 0 7 3
    check "quotRemWord2# 1 0 (2^(N-1))" $
      checkW2 (2, 0) quotRemWord2# 1 0 (2 ^ (wordWidth-1))
    check "quotRemWord2# 1 1 (2^(N-1))" $
      checkW2 (2, 1) quotRemWord2# 1 1 (2 ^ (wordWidth-1))
    check "quotRemWord2# 1 0 maxBound" $
      checkW2 (1, 1) quotRemWord2# 1 0 maxBound
    check "quotRemWord2# 2 0 maxBound" $
      checkW2 (2, 2) quotRemWord2# 2 0 maxBound
    check "quotRemWord2# 1 maxBound maxBound" $
      checkW2 (2, 1) quotRemWord2# 1 maxBound maxBound
    check "quotRemWord2# (2^(N-1)) 0 maxBound" $
      checkW2 (2 ^ (wordWidth-1), 2 ^ (wordWidth-1)) quotRemWord2# (2 ^ (wordWidth-1)) 0 maxBound
    check "quotRemWord2# (2^(N-1)) maxBound maxBound" $
      checkW2 (2 ^ (wordWidth-1) + 1, 2 ^ (wordWidth-1)) quotRemWord2# (2 ^ (wordWidth-1)) maxBound maxBound


module Ppr001 where

main = putStrLn "hello"

foo x = y + 3
  where
    y = 2 ^ x


{-# LANGUAGE Arrows #-}
module Arrow where

import Control.Arrow
import qualified Control.Category as Cat

addA :: Arrow a => a b Int -> a b Int -> a b Int
addA f g = proc x -> do
                y <- f -< x
                z <- g -< x
                returnA -< y + z

newtype Circuit a b = Circuit { unCircuit :: a -> (Circuit a b, b) }

instance Cat.Category Circuit where
    id = Circuit $ \a -> (Cat.id, a)
    (.) = dot
      where
        (Circuit cir2) `dot` (Circuit cir1) = Circuit $ \a ->
            let (cir1', b) = cir1 a
                (cir2', c) = cir2 b
            in  (cir2' `dot` cir1', c)

instance Arrow Circuit where
    arr f = Circuit $ \a -> (arr f, f a)
    first (Circuit cir) = Circuit $ \(b, d) ->
        let (cir', c) = cir b
        in  (first cir', (c, d))

-- | Accumulator that outputs a value determined by the supplied function.
accum :: acc -> (a -> acc -> (b, acc)) -> Circuit a b
accum acc f = Circuit $ \input ->
    let (output, acc') = input `f` acc
    in  (accum acc' f, output)

-- | Accumulator that outputs the accumulator value.
accum' :: b -> (a -> b -> b) -> Circuit a b
accum' acc f = accum acc (\a b -> let b' = a `f` b in (b', b'))

total :: Num a => Circuit a a
total = accum' 0 (+)

mean3 :: Fractional a => Circuit a a
mean3 = proc value -> do
    (t, n) <- (| (&&&) (total -< value) (total -< 1) |)
    returnA -< t / n


main = putStrLn "hello"

foo x =
  case x of
   { ;;; -- leading
     0 -> 'a';  -- case 0
     1 -> 'b'   -- case 1
   ; 2 -> 'c' ; -- case 2
   ; 3 -> 'd'   -- case 3
          ;;;   -- case 4
   }


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

-- From https://www.haskell.org/haskellwiki/GHC/Type_families#An_associated_data_type_example

import qualified Data.IntMap
import Prelude hiding (lookup)
import Data.Char (ord)

class GMapKey k where
  data GMap k :: * -> *
  empty       :: GMap k v
  lookup      :: k -> GMap k v -> Maybe v
  insert      :: k -> v -> GMap k v -> GMap k v

-- An Int instance
instance GMapKey Int where
  data GMap Int v        = GMapInt (Data.IntMap.IntMap v)
  empty                  = GMapInt Data.IntMap.empty
  lookup k   (GMapInt m) = Data.IntMap.lookup k m
  insert k v (GMapInt m) = GMapInt (Data.IntMap.insert k v m)

-- A Char instance
instance GMapKey Char where
  data GMap Char v        = GMapChar (GMap Int v)
  empty                   = GMapChar empty
  lookup k (GMapChar m)   = lookup (ord k) m
  insert k v (GMapChar m) = GMapChar (insert (ord k) v m)

-- A Unit instance
instance GMapKey () where
  data GMap () v           = GMapUnit (Maybe v)
  empty                    = GMapUnit Nothing
  lookup () (GMapUnit v)   = v
  insert () v (GMapUnit _) = GMapUnit $ Just v

-- Product and sum instances
instance (GMapKey a, GMapKey b) => GMapKey (a, b) where
  data GMap (a, b) v            = GMapPair (GMap a (GMap b v))
  empty                         = GMapPair empty
  lookup (a, b) (GMapPair gm)   = lookup a gm >>= lookup b
  insert (a, b) v (GMapPair gm) = GMapPair $ case lookup a gm of
                                    Nothing  -> insert a (insert b v empty) gm
                                    Just gm2 -> insert a (insert b v gm2  ) gm

instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where
  data GMap (Either a b) v                = GMapEither (GMap a v) (GMap b v)
  empty                                   = GMapEither empty empty
  lookup (Left  a) (GMapEither gm1  _gm2) = lookup a gm1
  lookup (Right b) (GMapEither _gm1 gm2 ) = lookup b gm2
  insert (Left  a) v (GMapEither gm1 gm2) = GMapEither (insert a v gm1) gm2
  insert (Right b) v (GMapEither gm1 gm2) = GMapEither gm1 (insert b v gm2)

myGMap :: GMap (Int, Either Char ()) String
myGMap = insert (5, Left 'c') "(5, Left 'c')"    $
         insert (4, Right ()) "(4, Right ())"    $
         insert (5, Right ()) "This is the one!" $
         insert (5, Right ()) "This is the two!" $
         insert (6, Right ()) "(6, Right ())"    $
         insert (5, Left 'a') "(5, Left 'a')"    $
         empty

main = putStrLn $ maybe "Couldn't find key!" id $ lookup (5, Right ()) myGMap

-- (Type) Synonym Family

type family Elem c

type instance Elem [e] = e

-- type instance Elem BitSet = Char

data family T a
data    instance T Int  = T1 Int | T2 Bool
newtype instance T Char = TC Bool

data family G a b
data instance G [a] b where
   G1 :: c -> G [Int] b
   G2 :: G [a] Bool


module Ppr005 where

import Data.List

foo = do
  let x = 1
  Just 5

f = undefined
go = undefined
e = undefined


{-# LANGUAGE QuasiQuotes #-}
module Ppr006 where

commands :: [Command]
commands = [
    command "help" "display a list of all commands, and their current keybindings" $ do
      macroGuesses <- Macro.guessCommands commandNames <$> getMacros
      addTab (Other "Help") (makeHelpWidget commands macroGuesses) AutoClose

  , command "log" "show the error log" $ do
      messages <- gets logMessages
      let widget = ListWidget.moveLast (ListWidget.new $ reverse messages)
      addTab (Other "Log") (AnyWidget . LogWidget $ widget) AutoClose

  , command "map" "display a list of all commands that are currently bound to keys" $ do
      showMappings

  , command "map" "display the command that is currently bound to the key {name}" $ do
      showMapping

  , command "map" [help|
        Bind the command {expansion} to the key {name}.  The same command may
        be bound to different keys.
        |] $ do
      addMapping

  , command "unmap" "remove the binding currently bound to the key {name}" $ do
      \(MacroName m) -> removeMacro m

  , command "mapclear" "" $ do
      clearMacros

  , command "exit" "exit vimus" $ do
      eval "quit"

  , command "quit" "exit vimus" $ do
      liftIO exitSuccess :: Vimus ()

  , command "close" "close the current window (not all windows can be closed)" $ do
      void closeTab

  , command "source" "read the file {path} and interprets all lines found there as if they were entered as commands." $ do
      \(Path p) -> liftIO (expandHome p) >>= either printError source_

  , command "runtime" "" $
      \(Path p) -> liftIO (getDataFileName p) >>= source_

  , command "color" "define the fore- and background color for a thing on the screen." $ do
      \color fg bg -> liftIO (defineColor color fg bg) :: Vimus ()

  , command "repeat" "set the playlist option *repeat*. When *repeat* is set, the playlist will start over when the last song has finished playing." $ do
      MPD.repeat  True :: Vimus ()

  , command "norepeat" "Unset the playlist option *repeat*." $ do
      MPD.repeat  False :: Vimus ()

  , command "consume" "set the playlist option *consume*. When *consume* is set, songs that have finished playing are automatically removed from the playlist." $ do
      MPD.consume True :: Vimus ()

  , command "noconsume" "Unset the playlist option *consume*." $ do
      MPD.consume False :: Vimus ()

  , command "random" "set the playlist option *random*. When *random* is set, songs in the playlist are played in random order." $ do
      MPD.random  True :: Vimus ()

  , command "norandom" "Unset the playlist option *random*." $ do
      MPD.random  False :: Vimus ()

  , command "single" "Set the playlist option *single*. When *single* is set, playback does not advance automatically to the next item in the playlist. Combine with *repeat* to repeatedly play the same song." $ do
      MPD.single  True :: Vimus ()

  , command "nosingle" "Unset the playlist option *single*." $ do
      MPD.single  False :: Vimus ()

  , command "autotitle" "Set the *autotitle* option.  When *autotitle* is set, the console window title is automatically set to the currently playing song." $ do
      setAutoTitle True

  , command "noautotitle" "Unset the *autotitle* option." $ do
      setAutoTitle False

  , command "volume" "[+-] set volume to  or adjust by [+-] num" $ do
      volume :: Volume -> Vimus ()

 , command "toggle-repeat" "Toggle the *repeat* option." $ do
      MPD.status >>= MPD.repeat  . not . MPD.stRepeat :: Vimus ()

  , command "toggle-consume" "Toggle the *consume* option." $ do
      MPD.status >>= MPD.consume . not . MPD.stConsume :: Vimus ()

  , command "toggle-random" "Toggle the *random* option." $ do
      MPD.status >>= MPD.random  . not . MPD.stRandom :: Vimus ()

  , command "toggle-single" "Toggle the *single* option." $ do
      MPD.status >>= MPD.single  . not . MPD.stSingle :: Vimus ()

  , command "set-library-path" "While MPD knows where your songs are stored, vimus doesn't. If you want to use the *%* feature of the command :! you need to tell vimus where your songs are stored." $ do
      \(Path p) -> setLibraryPath p

  , command "next" "stop playing the current song, and starts the next one" $ do
      MPD.next :: Vimus ()

  , command "previous" "stop playing the current song, and starts the previous one" $ do
      MPD.previous :: Vimus ()

  , command "toggle" "toggle between play and pause" $ do
      MPDE.toggle :: Vimus ()

  , command "stop" "stop playback" $ do
      MPD.stop :: Vimus ()

  , command "update" "tell MPD to update the music database. You must update your database when you add or delete files in your music directory, or when you edit the metadata of a song.  MPD will only rescan a file already in the database if its modification time has changed." $ do
      void (MPD.update Nothing) :: Vimus ()

  , command "rescan" "" $ do
      void (MPD.rescan Nothing) :: Vimus ()

  , command "clear" "delete all songs from the playlist" $ do
      MPD.clear :: Vimus ()

  , command "search-next" "jump to the next occurrence of the search string in the current window"
      searchNext

  , command "search-prev" "jump to the previous occurrence of the search string in the current window"
      searchPrev

  , command "window-library" "open the *Library* window" $
      selectTab Library

  , command "window-playlist" "open the *Playlist* window" $
      selectTab Playlist

  , command "window-search" "open the *SearchResult* window" $
      selectTab SearchResult

  , command "window-browser" "open the *Browser* window" $
      selectTab Browser

  , command "window-next" "open the window to the right of the current one"
      nextTab

  , command "window-prev" "open the window to the left of the current one"
      previousTab

  , command "!" "execute {cmd} on the system shell. See chapter \"Using an external tag editor\" for an example."
      runShellCommand

  , command "seek" "jump to the given position in the current song"
      seek

  , command "visual" "start visual selection" $
      sendEventCurrent EvVisual

  , command "novisual" "cancel visual selection" $
      sendEventCurrent EvNoVisual

  -- Remove current song from playlist
  , command "remove" "remove the song under the cursor from the playlist" $
      sendEventCurrent EvRemove

  , command "paste" "add the last deleted song after the selected song in the playlist" $
      sendEventCurrent EvPaste

  , command "paste-prev" "" $
      sendEventCurrent EvPastePrevious

  , command "copy" "" $
      sendEventCurrent EvCopy

  , command "shuffle" "shuffle the current playlist" $ do
      MPD.shuffle Nothing :: Vimus ()

  , command "add" "append selected songs to the end of the playlist" $ do
      sendEventCurrent EvAdd

  -- insert a song right after the current song
  , command "insert" [help|
      inserts a song to the playlist. The song is inserted after the currently
      playing song.
      |] $ do
      st <- MPD.status
      case MPD.stSongPos st of
        Just n -> do
          -- there is a current song, insert after
          sendEventCurrent (EvInsert (n + 1))
        _ -> do
          -- there is no current song, just add
          sendEventCurrent EvAdd

  -- Playlist: play selected song
  -- Library:  add song to playlist and play it
  -- Browse:   either add song to playlist and play it, or :move-in
  , command "default-action" [help|
      depending on the item under the cursor, something different happens:

      - *Playlist* start playing the song under the cursor

      - *Library* append the song under the cursor to the playlist and start playing it

      - *Browser* on a song: append the song to the playlist and play it. On a directory: go down to that directory.
      |] $ do
      sendEventCurrent EvDefaultAction

  , command "add-album" "add all songs of the album of the selected song to the playlist" $ do
      songs <- fromCurrent MPD.Album [MPD.Disc, MPD.Track]
      maybe (printError "Song has no album metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs

  , command "add-artist" "add all songs of the artist of the selected song to the playlist" $ do
      songs <- fromCurrent MPD.Artist [MPD.Date, MPD.Album, MPD.Disc, MPD.Track]
      maybe (printError "Song has no artist metadata!") (MPDE.addMany "" . map MPD.sgFilePath) songs

  -- movement
  , command "move-up" "move the cursor one line up" $
      sendEventCurrent EvMoveUp

  , command "move-down" "move the cursor one line down" $
      sendEventCurrent EvMoveDown

  , command "move-album-prev" "move the cursor up to the first song of an album" $
      sendEventCurrent EvMoveAlbumPrev

  , command "move-album-next" "move the cursor down to the first song of an album" $
      sendEventCurrent EvMoveAlbumNext

  , command "move-in" "go down one level the directory hierarchy in the *Browser* window" $
      sendEventCurrent EvMoveIn

  , command "move-out" "go up one level in the directory hierarchy in the *Browser* window" $
      sendEventCurrent EvMoveOut

  , command "move-first" "go to the first line in the current window" $
      sendEventCurrent EvMoveFirst

  , command "move-last" "go to the last line in the current window" $
      sendEventCurrent EvMoveLast

  , command "scroll-up" "scroll the contents of the current window up one line" $
      sendEventCurrent (EvScroll (-1))

  , command "scroll-down" "scroll the contents of the current window down one line" $
      sendEventCurrent (EvScroll 1)

  , command "scroll-page-up" "scroll the contents of the current window up one page" $
      pageScroll >>= sendEventCurrent . EvScroll . negate

  , command "scroll-half-page-up" "scroll the contents of the current window up one half page" $
      pageScroll >>= sendEventCurrent . EvScroll . negate . (`div` 2)

  , command "scroll-page-down" "scroll the contents of the current window down one page" $
      pageScroll >>= sendEventCurrent . EvScroll

  , command "scroll-half-page-down" "scroll the contents of the current window down one half page" $
      pageScroll >>= sendEventCurrent . EvScroll . (`div` 2)

  , command "song-format" "set song rendering format" $
      sendEvent . EvChangeSongFormat
  ]


{-# LANGUAGE ApplicativeDo #-}
module Ppr007 where

g :: IO ()
g = do
  x <- getChar
  'a' <- return (3::Int) -- type error
  return ()


{-# LANGUAGE Unsafe #-}
{-# LANGUAGE CPP
           , NoImplicitPrelude
           , ScopedTypeVariables
           , BangPatterns
  #-}

module Ppr008
    (
    -- * Managing the IO manager
      Signal
    , ControlMessage(..)
    , Control
    , newControl
    , closeControl
    -- ** Control message reception
    , readControlMessage
    -- *** File descriptors
    , controlReadFd
    , controlWriteFd
    , wakeupReadFd
    -- ** Control message sending
    , sendWakeup
    , sendDie
    -- * Utilities
    , setNonBlockingFD
    ) where

#include "EventConfig.h"

import Foreign.ForeignPtr (ForeignPtr)
import GHC.Base
import GHC.Conc.Signal (Signal)
import GHC.Real (fromIntegral)
import GHC.Show (Show)
import GHC.Word (Word8)
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types (CInt(..), CSize(..))
import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr)
import Foreign.Marshal (alloca, allocaBytes)
import Foreign.Marshal.Array (allocaArray)
import Foreign.Ptr (castPtr)
import Foreign.Storable (peek, peekElemOff, poke)
import System.Posix.Internals (c_close, c_pipe, c_read, c_write,
                               setCloseOnExec, setNonBlockingFD)
import System.Posix.Types (Fd)

#if defined(HAVE_EVENTFD)
import Foreign.C.Error (throwErrnoIfMinus1)
import Foreign.C.Types (CULLong(..))
#else
import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno)
#endif

data ControlMessage = CMsgWakeup
                    | CMsgDie
                    | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8)
                                 {-# UNPACK #-} !Signal
    deriving (Eq, Show)

-- | The structure used to tell the IO manager thread what to do.
data Control = W {
      controlReadFd  :: {-# UNPACK #-} !Fd
    , controlWriteFd :: {-# UNPACK #-} !Fd
#if defined(HAVE_EVENTFD)
    , controlEventFd :: {-# UNPACK #-} !Fd
#else
    , wakeupReadFd   :: {-# UNPACK #-} !Fd
    , wakeupWriteFd  :: {-# UNPACK #-} !Fd
#endif
    , didRegisterWakeupFd :: !Bool
    } deriving (Show)

#if defined(HAVE_EVENTFD)
wakeupReadFd :: Control -> Fd
wakeupReadFd = controlEventFd
{-# INLINE wakeupReadFd #-}
#endif

-- | Create the structure (usually a pipe) used for waking up the IO
-- manager thread from another thread.
newControl :: Bool -> IO Control
newControl shouldRegister = allocaArray 2 $ \fds -> do
  let createPipe = do
        throwErrnoIfMinus1_ "pipe" $ c_pipe fds
        rd <- peekElemOff fds 0
        wr <- peekElemOff fds 1
        -- The write end must be non-blocking, since we may need to
        -- poke the event manager from a signal handler.
        setNonBlockingFD wr True
        setCloseOnExec rd
        setCloseOnExec wr
        return (rd, wr)
  (ctrl_rd, ctrl_wr) <- createPipe
#if defined(HAVE_EVENTFD)
  ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0
  setNonBlockingFD ev True
  setCloseOnExec ev
  when shouldRegister $ c_setIOManagerWakeupFd ev
#else
  (wake_rd, wake_wr) <- createPipe
  when shouldRegister $ c_setIOManagerWakeupFd wake_wr
#endif
  return W { controlReadFd  = fromIntegral ctrl_rd
           , controlWriteFd = fromIntegral ctrl_wr
#if defined(HAVE_EVENTFD)
           , controlEventFd = fromIntegral ev
#else
           , wakeupReadFd   = fromIntegral wake_rd
           , wakeupWriteFd  = fromIntegral wake_wr
#endif
           , didRegisterWakeupFd = shouldRegister
           }

-- | Close the control structure used by the IO manager thread.
-- N.B. If this Control is the Control whose wakeup file was registered with
-- the RTS, then *BEFORE* the wakeup file is closed, we must call
-- c_setIOManagerWakeupFd (-1), so that the RTS does not try to use the wakeup
-- file after it has been closed.
closeControl :: Control -> IO ()
closeControl w = do
  _ <- c_close . fromIntegral . controlReadFd $ w
  _ <- c_close . fromIntegral . controlWriteFd $ w
  when (didRegisterWakeupFd w) $ c_setIOManagerWakeupFd (-1)
#if defined(HAVE_EVENTFD)
  _ <- c_close . fromIntegral . controlEventFd $ w
#else
  _ <- c_close . fromIntegral . wakeupReadFd $ w
  _ <- c_close . fromIntegral . wakeupWriteFd $ w
#endif
  return ()

io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8
io_MANAGER_WAKEUP = 0xff
io_MANAGER_DIE    = 0xfe

foreign import ccall "__hscore_sizeof_siginfo_t"
    sizeof_siginfo_t :: CSize

readControlMessage :: Control -> Fd -> IO ControlMessage
readControlMessage ctrl fd
    | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do
                    throwErrnoIfMinus1_ "readWakeupMessage" $
                      c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize)
                    return CMsgWakeup
    | otherwise =
        alloca $ \p -> do
            throwErrnoIfMinus1_ "readControlMessage" $
                c_read (fromIntegral fd) p 1
            s <- peek p
            case s of
                -- Wakeup messages shouldn't be sent on the control
                -- file descriptor but we handle them anyway.
                _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup
                _ | s == io_MANAGER_DIE    -> return CMsgDie
                _ -> do  -- Signal
                    fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
                    withForeignPtr fp $ \p_siginfo -> do
                        r <- c_read (fromIntegral fd) (castPtr p_siginfo)
                             sizeof_siginfo_t
                        when (r /= fromIntegral sizeof_siginfo_t) $
                            error "failed to read siginfo_t"
                        let !s' = fromIntegral s
                        return $ CMsgSignal fp s'

  where wakeupBufferSize =
#if defined(HAVE_EVENTFD)
            8
#else
            4096
#endif

sendWakeup :: Control -> IO ()
#if defined(HAVE_EVENTFD)
sendWakeup c =
  throwErrnoIfMinus1_ "sendWakeup" $
  c_eventfd_write (fromIntegral (controlEventFd c)) 1
#else
sendWakeup c = do
  n <- sendMessage (wakeupWriteFd c) CMsgWakeup
  case n of
    _ | n /= -1   -> return ()
      | otherwise -> do
                   errno <- getErrno
                   when (errno /= eAGAIN && errno /= eWOULDBLOCK) $
                     throwErrno "sendWakeup"
#endif

sendDie :: Control -> IO ()
sendDie c = throwErrnoIfMinus1_ "sendDie" $
            sendMessage (controlWriteFd c) CMsgDie

sendMessage :: Fd -> ControlMessage -> IO Int
sendMessage fd msg = alloca $ \p -> do
  case msg of
    CMsgWakeup        -> poke p io_MANAGER_WAKEUP
    CMsgDie           -> poke p io_MANAGER_DIE
    CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS"
  fromIntegral `fmap` c_write (fromIntegral fd) p 1

#if defined(HAVE_EVENTFD)
foreign import ccall unsafe "sys/eventfd.h eventfd"
   c_eventfd :: CInt -> CInt -> IO CInt

foreign import ccall unsafe "sys/eventfd.h eventfd_write"
   c_eventfd_write :: CInt -> CULLong -> IO CInt
#endif

foreign import ccall unsafe "setIOManagerWakeupFd"
   c_setIOManagerWakeupFd :: CInt -> IO ()

foreign import ccall unsafe "static baz"
   c_baz :: CInt -> IO ()


module Ppr009 where

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


{-# Language CPP #-}
module Ppr010 where

#if __GLASGOW_HASKELL__ > 704
foo :: Int
#else
foo :: Integer
#endif
foo = 3

bar :: (
#if __GLASGOW_HASKELL__ > 704
    Int)
#else
    Integer)
#endif
bar = 4


{-# Language DatatypeContexts #-}
{-# Language ExistentialQuantification #-}
{-# LAnguage GADTs #-}
{-# LAnguage KindSignatures #-}

data Foo = A
         | B
         | C

--         | data_or_newtype capi_ctype tycl_hdr constrs deriving
data {-# Ctype "Foo" "bar" #-} F1 = F1
data {-# Ctype       "baz" #-} Eq a =>  F2 a = F2 a

data (Eq a,Ord a) => F3 a = F3 Int a

data F4 a = forall x y. (Eq x,Eq y) => F4 a x y
          | forall x y. (Eq x,Eq y) => F4b a x y

data G1 a :: * where
  G1A,  G1B :: Int -> G1 a
  G1C :: Double -> G1 a

data G2 a :: * where
  G2A :: { g2a :: a, g2b :: Int } -> G2 a
  G2C :: Double -> G2 a

data (Eq a,Ord a) => G3 a = G3
  { g3A :: Int
  , g3B :: Bool
  , g3a :: a
  } deriving (Eq,Ord)


module Dead1(foo) where

foo :: Int -> Int
foo n = baz (n+1) (bar1 n)

{-# NOINLINE bar1 #-}
bar1 n = 1 + bar n

bar :: Int -> Int
{-# NOINLINE bar #-}
{-# RULES
"bar/foo" forall n. bar (foo n) = n
   #-}
bar n = n-1

baz :: Int -> Int -> Int
{-# INLINE [0] baz #-}
baz m n = m

{- Ronam writes (Feb08)

    Note that bar becomes dead as soon as baz gets inlined. But strangely,
    the simplifier only deletes it after full laziness and CSE. That is, it
    is not deleted in the phase in which baz gets inlined. In fact, it is
    still there after w/w and the subsequent simplifier run. It gets deleted
    immediately if I comment out the rule.

    I stumbled over this when I removed one simplifier run after SpecConstr
    (at the moment, it runs twice at the end but I don't think that should
    be necessary). With this change, the original version of a specialised
    loop (the one with the rules) is not longer deleted even if it isn't
    used any more. I'll reenable the second simplifier run for now but
    should this really be necessary?

No, it should not be necessary.  A refactoring in OccurAnal makes
this work right. Look at the simplifier output just before strictness
analysis; there should be a binding for 'foo', but for nothing else.

-}


{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}

import Data.Data

data Foo = FooA | FooB

deriving instance Show Foo

deriving instance {-# Overlappable #-} Eq Foo
deriving instance {-# Overlapping  #-} Ord Foo
deriving instance {-# Overlaps     #-} Typeable Foo
deriving instance {-# Incoherent   #-} Data Foo


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

-- from https://ocharles.org.uk/blog/guest-posts/2014-12-19-existential-quantification.html

data HashMap k v = HM  -- ... -- actual implementation

class Hashable v where
  h :: v -> Int

data HashMapM hm = HashMapM
  { empty  :: forall k v . hm k v
  , lookup :: Hashable k => k -> hm k v -> Maybe v
  , insert :: Hashable k => k -> v -> hm k v -> hm k v
  , union  :: Hashable k => hm k v -> hm k v -> hm k v
  }

data HashMapE = forall hm . HashMapE (HashMapM hm)

-- public
mkHashMapE :: Int -> HashMapE
mkHashMapE = HashMapE . mkHashMapM

-- private
mkHashMapM :: Int -> HashMapM HashMap
mkHashMapM salt = HashMapM { {- implementation -} }

instance Hashable String where

type Name = String
data Gift = G String

giraffe :: Gift
giraffe = G "giraffe"

addGift :: HashMapM hm -> hm Name Gift -> hm Name Gift
addGift mod gifts =
  let
    HashMapM{..} = mod
  in
    insert "Ollie" giraffe gifts

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

santa'sSecretSalt = undefined
sendGiftToOllie = undefined
traverse_ = undefined

sendGifts =
  case mkHashMapE santa'sSecretSalt of
    HashMapE (mod@HashMapM{..}) ->
      let
        gifts = addGift mod empty
      in
        traverse_ sendGiftToOllie $ lookup "Ollie" gifts


module ExprPragmas where

a = {-# SCC "name"   #-}  0x5

b = {-# SCC foo   #-} 006


{-# LANGUAGE ImplicitParams #-}

explicit :: ((?above :: q, ?below :: a -> q) => b) -> q -> (a -> q) -> b
explicit x ab be = x where ?above = ab; ?below = be


{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ExplicitNamespaces #-}
module Imports( f, type (+), pattern Single ) where

import GHC.TypeLits

pattern Single x = [x]

f = undefined


{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}

data Foo a = F Int | A a
  deriving Show

data Foo1 a = F1 Int | A1 a
  deriving (Show)

data Foo2 a = F2 Int | A2 a
  deriving (Show, Eq)

data FooStock = FS Int
  deriving stock Show

data FooAnyClass = Fa Int
  deriving anyclass Show

newtype FooNewType = Fn Int
  deriving newtype (Show)


{-# LANGUAGE DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses,
             CPP #-}
#if __GLASGOW_HASKELL__ >= 708
{-# LANGUAGE RoleAnnotations #-}
#endif

{-# OPTIONS_HADDOCK hide #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Array.IO.Internal
-- Copyright   :  (c) The University of Glasgow 2001-2012
-- License     :  BSD-style (see the file libraries/base/LICENSE)
--
-- Maintainer  :  libraries@haskell.org
-- Stability   :  experimental
-- Portability :  non-portable (uses Data.Array.Base)
--
-- Mutable boxed and unboxed arrays in the IO monad.
--
-----------------------------------------------------------------------------

module Data.Array.IO.Internals (
    IOArray(..),         -- instance of: Eq, Typeable
    IOUArray(..),        -- instance of: Eq, Typeable
    castIOUArray,        -- :: IOUArray ix a -> IO (IOUArray ix b)
    unsafeThawIOUArray,
  ) where

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

import Control.Monad.ST         ( RealWorld, stToIO )
import Foreign.Ptr              ( Ptr, FunPtr )
import Foreign.StablePtr        ( StablePtr )

#if __GLASGOW_HASKELL__ < 711
import Data.Ix
#endif
import Data.Array.Base

import GHC.IOArray (IOArray(..))

-----------------------------------------------------------------------------
-- Flat unboxed mutable arrays (IO monad)

-- | Mutable, unboxed, strict arrays in the 'IO' monad.  The type
-- arguments are as follows:
--
--  * @i@: the index type of the array (should be an instance of 'Ix')
--
--  * @e@: the element type of the array.  Only certain element types
--    are supported: see "Data.Array.MArray" for a list of instances.
--
newtype IOUArray i e = IOUArray (STUArray RealWorld i e)
                       deriving Typeable
#if __GLASGOW_HASKELL__ >= 708
-- Both parameters have class-based invariants. See also #9220.
type role IOUArray nominal nominal
#endif

instance Eq (IOUArray i e) where
    IOUArray s1 == IOUArray s2  =  s1 == s2

instance MArray IOUArray Bool IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Char IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Int IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Word IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray (Ptr a) IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray (FunPtr a) IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Float IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Double IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray (StablePtr a) IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Int8 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Int16 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Int32 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Int64 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Word8 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Word16 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Word32 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

instance MArray IOUArray Word64 IO where
    {-# INLINE getBounds #-}
    getBounds (IOUArray arr) = stToIO $ getBounds arr
    {-# INLINE getNumElements #-}
    getNumElements (IOUArray arr) = stToIO $ getNumElements arr
    {-# INLINE newArray #-}
    newArray lu initialValue = stToIO $ do
        marr <- newArray lu initialValue; return (IOUArray marr)
    {-# INLINE unsafeNewArray_ #-}
    unsafeNewArray_ lu = stToIO $ do
        marr <- unsafeNewArray_ lu; return (IOUArray marr)
    {-# INLINE newArray_ #-}
    newArray_ = unsafeNewArray_
    {-# INLINE unsafeRead #-}
    unsafeRead (IOUArray marr) i = stToIO (unsafeRead marr i)
    {-# INLINE unsafeWrite #-}
    unsafeWrite (IOUArray marr) i e = stToIO (unsafeWrite marr i e)

-- | Casts an 'IOUArray' with one element type into one with a
-- different element type.  All the elements of the resulting array
-- are undefined (unless you know what you\'re doing...).
castIOUArray :: IOUArray ix a -> IO (IOUArray ix b)
castIOUArray (IOUArray marr) = stToIO $ do
    marr' <- castSTUArray marr
    return (IOUArray marr')

{-# INLINE unsafeThawIOUArray #-}
#if __GLASGOW_HASKELL__ >= 711
unsafeThawIOUArray :: UArray ix e -> IO (IOUArray ix e)
#else
unsafeThawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
#endif
unsafeThawIOUArray arr = stToIO $ do
    marr <- unsafeThawSTUArray arr
    return (IOUArray marr)

{-# RULES
"unsafeThaw/IOUArray" unsafeThaw = unsafeThawIOUArray
    #-}

#if __GLASGOW_HASKELL__ >= 711
thawIOUArray :: UArray ix e -> IO (IOUArray ix e)
#else
thawIOUArray :: Ix ix => UArray ix e -> IO (IOUArray ix e)
#endif
thawIOUArray arr = stToIO $ do
    marr <- thawSTUArray arr
    return (IOUArray marr)

{-# RULES
"thaw/IOUArray" thaw = thawIOUArray
    #-}

{-# INLINE unsafeFreezeIOUArray #-}
#if __GLASGOW_HASKELL__ >= 711
unsafeFreezeIOUArray :: IOUArray ix e -> IO (UArray ix e)
#else
unsafeFreezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
#endif
unsafeFreezeIOUArray (IOUArray marr) = stToIO (unsafeFreezeSTUArray marr)

{-# RULES
"unsafeFreeze/IOUArray" unsafeFreeze = unsafeFreezeIOUArray
    #-}

#if __GLASGOW_HASKELL__ >= 711
freezeIOUArray :: IOUArray ix e -> IO (UArray ix e)
#else
freezeIOUArray :: Ix ix => IOUArray ix e -> IO (UArray ix e)
#endif
freezeIOUArray (IOUArray marr) = stToIO (freezeSTUArray marr)

{-# RULES
"freeze/IOUArray" freeze = freezeIOUArray
    #-}


{-# LANGUAGE LambdaCase #-}

foo = f >>= \case
        Just h -> loadTestDB (h ++ "/.testdb")
        Nothing -> fmap S.Right initTestDB

{-| Is the alarm set - i.e. will it go off at some point in the future even if
   `setAlarm` is not called? -}
isAlarmSetSTM :: AlarmClock -> STM Bool
isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting
  >>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True }


{-# LANGUAGE PatternSynonyms #-}
{-# Language DeriveFoldable #-}
{-# LANGUAGE Safe #-}
{-# options_ghc -w #-}

-- | A simple let expression, to ensure the layout is detected
-- With some haddock in the top
{- And a normal
   multiline comment too -}
  module {- brah -}  LetExpr        ( foo -- foo does ..
                                    , bar -- bar does ..
                                    , Baz () -- baz does ..
                                 , Ba   ( ..),Ca(Cc,Cd)   ,
                                     bbb ,  aaa
                                  , module  Data.List
                                    , pattern  Bar
                                    )
    where

import Data.List
-- A comment in the middle
import {-# SOURCE #-} BootImport ( Foo(..) )
import {-# SoURCE  #-} safe   qualified  BootImport   as    BI
import qualified Data.Map as {- blah -}  Foo.Map

import Control.Monad  (   )
import Data.Word (Word8)
import Data.Tree hiding  (  drawTree   )

import qualified Data.Maybe as M hiding    ( maybe  , isJust  )

-- comment
foo = let x = 1
          y = 2
      in x + y

bar = 3
bbb x
 | x == 1 = ()
 | otherwise = ()

aaa [ ] _   = 0
aaa x  _unk = 1

aba () = 0

x `ccc` 1 = x + 1
x `ccc` y = x + y

x !@# y = x + y

data Baz = Baz1 | Baz2

data Ba = Ba | Bb

data Ca = Cc | Cd

pattern Foo a <- RealFoo a
pattern Bar a <- RealBar a

data Thing = RealFoo Thing | RealBar Int


{-# LANGUAGE DataKinds, TemplateHaskell #-}

applicate :: Bool -> [Stmt] -> ExpQ
applicate rawPatterns stmt = do
    return $ foldl (\g e -> VarE '(<**>) `AppE` e `AppE` g)
                    (VarE 'pure `AppE` f')
                    es

tuple :: Int -> ExpQ
tuple n = do
    ns <- replicateM n (newName "x")
    lamE [foldr (\x y -> conP '(:) [varP x,y]) wildP ns] (tupE $ map varE ns)


class AwsType a where
    toText :: a -> b

    {-# MINIMAL toText #-}

class Minimal a where
  toText :: a -> b
  {-# MINIMAL decimal, hexadecimal, realFloat, scientific #-}

class Minimal a where
  toText :: a -> b
  {-# MINIMAL shape, (maskedIndex | maskedLinearIndex) #-}

class Minimal a where
  toText :: a -> b
  {-# MINIMAL (toSample | toSamples) #-}

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

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

class Foo2 a where
  f :: a
  {-# MiNiMaL f #-}


import Data.List  ()
import Data.List  hiding ()

infixl 1 `f`
-- infixr 2 `\\\`
infix  3 :==>
infix  4 `MkFoo`

data Foo = MkFoo Int | Float :==> Double

x `f` y = x

(\\\) :: (Eq a) => [a] -> [a] -> [a]
(\\\) xs ys =  xs

g x = x + if True then 1 else 2
h x = x + 1::Int

{-# SPECIALISe j :: Int -> Int
                  , Integer -> Integer #-}

j n = n + 1

test = let k x y = x+y in 1 `k` 2 `k` 3

data Rec = (:<-:) { a :: Int, b :: Float }

ng1 x y = negate y

instance (Num a, Num b) => Num (a,b)
  where
   {-# Specialise instance Num (Int,Int) #-}
   negate (a,b) = (ng 'c' a, ng1 'c' b)   where  ng x y = negate y

class Foo1 a where

class Foz a

x = 2 where
y = 3

instance Foo1 Int where

ff = ff where g = g where
type T = Int


{-# LANGUAGE Arrows #-}

operator = describe "Operators on ProcessA"$
  do
    describe "feedback" $
      do
        it "acts like local variable with hold." $
          do
            let
                pa = proc evx ->
                  do
                    (\evy -> hold 10 -< evy)
                      `feedback` \y ->
                      do
                        returnA -< ((+y) <$> evx, (y+1) <$ evx)
            run pa [1, 2, 3] `shouldBe` [11, 13, 15]

        it "correctly handles stream end." $
          do
            let
                pa = proc x ->
                    (\asx -> returnA -< asx)
                  `feedback`
                    (\asy -> returnA -< (asy::Event Int, x))
                comp = mkProc (PgPush PgStop) >>> pa
            stateProc comp [0, 0] `shouldBe` ([], [0])

        it "correctly handles stream end.(2)" $
          do
            pendingWith "many utilities behave incorrectly at end of stream."


{-# Language OverloadedStrings #-}
-- from https://ocharles.org.uk/blog/posts/2014-12-17-overloaded-strings.html

import Data.String

n :: Num a => a
n = 43

f  :: Fractional a => a
f = 03.1420

-- foo :: Text
foo :: Data.String.IsString a => a
foo = "hello\n there"


{-# OPTIONS -XTemplateHaskell #-}
module TH( x ) where
import Language.Haskell.TH

x = $(return (LitE (StringL "hello\ngoodbye\nand then")))


{-#LANGUAGE Arrows, RankNTypes, ScopedTypeVariables, FlexibleContexts,
  TypeSynonymInstances, NoMonomorphismRestriction, FlexibleInstances #-}

valForm initVal vtor label = withInput $
    proc ((),nm,fi) -> do
      s_curr <- keepState initVal -< fi
      valid <- vtor -< s_curr
      case valid of
         Left err -> returnA -< (textField label (Just err) s_curr nm,
                                                   Nothing)
         Right x -> returnA -< (textField label Nothing s_curr nm,
                                Just x)


module Rules where

import Data.Char

{-# RULES "map-loop" [ ~  ]  forall f . map' f = map' (id . f) #-}

{-# NOINLINE map' #-}
map' f [] = []
map' f (x:xs) = f x : map' f xs

main = print (map' toUpper "Hello, World")

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

-- Should warn
foo2 x = x
{-# INLINE foo2 #-}
{-# RULES "foo2" [~ 1 ] forall x. foo2 x = x #-}

-- Should not warn
foo3 x = x
{-# NOINLINE foo3 #-}
{-# RULES "foo3" forall x. foo3 x = x #-}

{-# NOINLINE f #-}
f :: Int -> String
f x = "NOT FIRED"

{-# NOINLINE neg #-}
neg :: Int -> Int
neg = negate

{-# RULES
     "f" forall (c::Char->Int) (x::Char). f (c x) = "RULE FIRED"
 #-}


{-# RULES
  "cFloatConv/Float->Float"    forall (x::Float).  cFloatConv x = x;
  "cFloatConv/Double->Double"  forall (x::Double). cFloatConv x = x;
  "cFloatConv/Float->CFloat"   forall (x::Float).  cFloatConv x = CFloat x;
  "cFloatConv/CFloat->Float"   forall (x::Float).  cFloatConv CFloat x = x;
  "cFloatConv/Double->CDouble" forall (x::Double). cFloatConv x = CDouble x;
  "cFloatConv/CDouble->Double" forall (x::Double). cFloatConv CDouble x = x
 #-};

cFloatConv = undefined


{-# LANGUAGE ImplicitParams, NamedFieldPuns, ParallelListComp, PatternGuards #-}
spec :: Spec
spec = do
  describe "split4'8" $ do
    it "0xabc" $ do
      split4'8 0xabc `shouldBe` (0x0a, 0xbc)
    it "0xfff" $ do
      split4'8 0xfff `shouldBe` (0x0f, 0xff)

    describe "(x, y) = split4'8 z" $ do
      prop "x <= 0x0f" $
        \z -> let (x, _) =  split4'8 z in x <= 0x0f
      prop "x << 8 | y == z" $ do
        \z -> let (x, y) = split4'8 z in
          fromIntegral x `shiftL` 8 .|. fromIntegral y == z

match s@Status{ pos, flips, captureAt, captureLen }
  | isOne ?pat = ite (pos .>= strLen) __FAIL__ one
  | otherwise = ite (pos + (toEnum $ minLen ?pat) .> strLen) __FAIL__ $ case ?pat of
    POr ps -> choice flips $ map (\p -> \b -> let ?pat = p in match s{ flips = b }) ps

foo = 1


{-# LANGUAGE PatternSynonyms #-}

module Sigs where

-- TypeSig
f :: Num a => a -> a
f = undefined

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

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

-- Fixities

infixr  6 +++
infixr  7 ***,///

(+++) :: Int -> Int -> Int
a +++ b = a + 2*b

(***) :: Int -> Int -> Int
a *** b = a - 4*b

(///) :: Int -> Int -> Int
a /// b = 2*a - 3*b

-- Inline signatures

{-# Inline g #-}
{-# INLINE [~34] f #-}

-- Specialise signature

-- Multiple sigs
x,y,z :: Int
x = 0
y = 0
z = 0


{-# LANGUAGE TemplateHaskell            #-}

import Language.Haskell.TH

makeLenses '' PostscriptFont

ty :: Q Type
ty = [t| Int |]

f :: $ty
f = undefined

g :: $(ty)
g = undefined

thb = $(do { let x = mkName "x"
                 v = return (LamE [VarP x] $ VarE x)
           ; [| $v . id |] })

foo2 :: A Bool
foo2 = $$(y)


{-# LANGUAGE NoImplicitPrelude #-}
module Algebra.Additive (
    -- * Class
    C,
    zero,
    (+), (-),
    negate, subtract,

    -- * Complex functions
    sum, sum1,
    sumNestedAssociative,
    sumNestedCommutative,

    -- * Instance definition helpers
    elementAdd, elementSub, elementNeg,
    (<*>.+), (<*>.-), (<*>.-$),

    -- * Instances for atomic types
    propAssociative,
    propCommutative,
    propIdentity,
    propInverse,
  ) where

import qualified Algebra.Laws as Laws

import Data.Int  (Int,  Int8,  Int16,  Int32,  Int64,  )
import Data.Word (Word, Word8, Word16, Word32, Word64, )

import qualified NumericPrelude.Elementwise as Elem
import Control.Applicative (Applicative(pure, (<*>)), )
import Data.Tuple.HT (fst3, snd3, thd3, )
import qualified Data.List.Match as Match

import qualified Data.Complex as Complex98
import qualified Data.Ratio as Ratio98
import qualified Prelude as P
import Prelude (Integer, Float, Double, fromInteger, )
import NumericPrelude.Base

infixl 6  +, -

{- |
Additive a encapsulates the notion of a commutative group, specified
by the following laws:

@
          a + b === b + a
    (a + b) + c === a + (b + c)
       zero + a === a
   a + negate a === 0
@

Typical examples include integers, dollars, and vectors.

Minimal definition: '+', 'zero', and ('negate' or '(-)')
-}

class C a where
    {-# MINIMAL zero, (+), ((-) | negate) #-}
    -- | zero element of the vector space
    zero     :: a
    -- | add and subtract elements
    (+), (-) :: a -> a -> a
    -- | inverse with respect to '+'
    negate   :: a -> a

    {-# INLINE negate #-}
    negate a = zero - a
    {-# INLINE (-) #-}
    a - b    = a + negate b

{- |
'subtract' is @(-)@ with swapped operand order.
This is the operand order which will be needed in most cases
of partial application.
-}
subtract :: C a => a -> a -> a
subtract = flip (-)

{- |
Sum up all elements of a list.
An empty list yields zero.

This function is inappropriate for number types like Peano.
Maybe we should make 'sum' a method of Additive.
This would also make 'lengthLeft' and 'lengthRight' superfluous.
-}
sum :: (C a) => [a] -> a
sum = foldl (+) zero

{- |
Sum up all elements of a non-empty list.
This avoids including a zero which is useful for types
where no universal zero is available.
-}
sum1 :: (C a) => [a] -> a
sum1 = foldl1 (+)

{- |
Sum the operands in an order,
such that the dependencies are minimized.
Does this have a measurably effect on speed?

Requires associativity.
-}
sumNestedAssociative :: (C a) => [a] -> a
sumNestedAssociative [] = zero
sumNestedAssociative [x] = x
sumNestedAssociative xs = sumNestedAssociative (sum2 xs)

{-
Make sure that the last entries in the list
are equally often part of an addition.
Maybe this can reduce rounding errors.
The list that sum2 computes is a breadth-first-flattened binary tree.

Requires associativity and commutativity.
-}
sumNestedCommutative :: (C a) => [a] -> a
sumNestedCommutative [] = zero
sumNestedCommutative xs@(_:rs) =
   let ys = xs ++ Match.take rs (sum2 ys)
   in  last ys

_sumNestedCommutative :: (C a) => [a] -> a
_sumNestedCommutative [] = zero
_sumNestedCommutative xs@(_:rs) =
   let ys = xs ++ take (length rs) (sum2 ys)
   in  last ys

{-
[a,b,c, a+b,c+(a+b)]
[a,b,c,d, a+b,c+d,(a+b)+(c+d)]
[a,b,c,d,e, a+b,c+d,e+(a+b),(c+d)+e+(a+b)]
[a,b,c,d,e,f, a+b,c+d,e+f,(a+b)+(c+d),(e+f)+((a+b)+(c+d))]
-}

sum2 :: (C a) => [a] -> [a]
sum2 (x:y:rest) = (x+y) : sum2 rest
sum2 xs = xs

{- |
Instead of baking the add operation into the element function,
we could use higher rank types
and pass a generic @uncurry (+)@ to the run function.
We do not do so in order to stay Haskell 98
at least for parts of NumericPrelude.
-}
{-# INLINE elementAdd #-}
elementAdd ::
   (C x) =>
   (v -> x) -> Elem.T (v,v) x
elementAdd f =
   Elem.element (\(x,y) -> f x + f y)

{-# INLINE elementSub #-}
elementSub ::
   (C x) =>
   (v -> x) -> Elem.T (v,v) x
elementSub f =
   Elem.element (\(x,y) -> f x - f y)

{-# INLINE elementNeg #-}
elementNeg ::
   (C x) =>
   (v -> x) -> Elem.T v x
elementNeg f =
   Elem.element (negate . f)

-- like <*>
infixl 4 <*>.+, <*>.-, <*>.-$

{- |
> addPair :: (Additive.C a, Additive.C b) => (a,b) -> (a,b) -> (a,b)
> addPair = Elem.run2 $ Elem.with (,) <*>.+  fst <*>.+  snd
-}
{-# INLINE (<*>.+) #-}
(<*>.+) ::
   (C x) =>
   Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a
(<*>.+) f acc =
   f <*> elementAdd acc

{-# INLINE (<*>.-) #-}
(<*>.-) ::
   (C x) =>
   Elem.T (v,v) (x -> a) -> (v -> x) -> Elem.T (v,v) a
(<*>.-) f acc =
   f <*> elementSub acc

{-# INLINE (<*>.-$) #-}
(<*>.-$) ::
   (C x) =>
   Elem.T v (x -> a) -> (v -> x) -> Elem.T v a
(<*>.-$) f acc =
   f <*> elementNeg acc

-- * Instances for atomic types

instance C Integer where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Float   where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Double  where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Int     where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Int8    where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Int16   where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Int32   where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Int64   where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Word    where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Word8   where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Word16  where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Word32  where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

instance C Word64  where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = P.fromInteger 0
   negate = P.negate
   (+)    = (P.+)
   (-)    = (P.-)

-- * Instances for composed types

instance (C v0, C v1) => C (v0, v1) where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = (,) zero zero
   (+)    = Elem.run2 $ pure (,) <*>.+  fst <*>.+  snd
   (-)    = Elem.run2 $ pure (,) <*>.-  fst <*>.-  snd
   negate = Elem.run  $ pure (,) <*>.-$ fst <*>.-$ snd

instance (C v0, C v1, C v2) => C (v0, v1, v2) where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero   = (,,) zero zero zero
   (+)    = Elem.run2 $ pure (,,) <*>.+  fst3 <*>.+  snd3 <*>.+  thd3
   (-)    = Elem.run2 $ pure (,,) <*>.-  fst3 <*>.-  snd3 <*>.-  thd3
   negate = Elem.run  $ pure (,,) <*>.-$ fst3 <*>.-$ snd3 <*>.-$ thd3

instance (C v) => C [v] where
   zero   = []
   negate = map negate
   (+) (x:xs) (y:ys) = (+) x y : (+) xs ys
   (+) xs     []     = xs
   (+) []     ys     = ys
   (-) (x:xs) (y:ys) = (-) x y : (-) xs ys
   (-) xs     []     = xs
   (-) []     ys     = negate ys

instance (C v) => C (b -> v) where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero       _ = zero
   (+)    f g x = (+) (f x) (g x)
   (-)    f g x = (-) (f x) (g x)
   negate f   x = negate (f x)

-- * Properties

propAssociative :: (Eq a, C a) => a -> a -> a -> Bool
propCommutative :: (Eq a, C a) => a -> a -> Bool
propIdentity    :: (Eq a, C a) => a -> Bool
propInverse     :: (Eq a, C a) => a -> Bool

propCommutative  =  Laws.commutative (+)
propAssociative  =  Laws.associative (+)
propIdentity     =  Laws.identity (+) zero
propInverse      =  Laws.inverse (+) negate zero

-- legacy

instance (P.Integral a) => C (Ratio98.Ratio a) where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero                =  P.fromInteger 0
   (+)                 =  (P.+)
   (-)                 =  (P.-)
   negate              =  P.negate

instance (P.RealFloat a) => C (Complex98.Complex a) where
   {-# INLINE zero #-}
   {-# INLINE negate #-}
   {-# INLINE (+) #-}
   {-# INLINE (-) #-}
   zero                =  P.fromInteger 0
   (+)                 =  (P.+)
   (-)                 =  (P.-)
   negate              =  P.negate


module Warning
{-# WARNINg ["This is a module warning",
             "multi-line"] #-}
  where

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

bar :: Char
bar = 'c'


module Deprecation
{-# Deprecated ["This is a module \"deprecation\"",
             "multi-line",
             "with unicode: FrÃ¨re" ] #-}
   ( foo )
 where

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

{-# DEPRECATED withBool        "The C2HS module will soon stop providing unnecessary\nutility functions. Please use standard FFI library functions instead." #-}


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

-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Singletons.Prelude.Eq
-- Copyright   :  (C) 2013 Richard Eisenberg
-- License     :  BSD-style (see LICENSE)
-- Maintainer  :  Richard Eisenberg (eir@cis.upenn.edu)
-- Stability   :  experimental
-- Portability :  non-portable
--
-- Defines the SEq singleton version of the Eq type class.
--
-----------------------------------------------------------------------------

module Data.Singletons.Prelude.Eq (
  PEq(..), SEq(..),
  (:==$), (:==$$), (:==$$$), (:/=$), (:/=$$), (:/=$$$)
  ) where

import Data.Singletons.Prelude.Bool
import Data.Singletons
import Data.Singletons.Single
import Data.Singletons.Prelude.Instances
import Data.Singletons.Util
import Data.Singletons.Promote
import Data.Type.Equality

-- NB: These must be defined by hand because of the custom handling of the
-- default for (:==) to use Data.Type.Equality.==

-- | The promoted analogue of 'Eq'. If you supply no definition for '(:==)',
-- then it defaults to a use of '(==)', from @Data.Type.Equality@.
class kproxy ~ 'KProxy => PEq (kproxy :: KProxy a) where
  type (:==) (x :: a) (y :: a) :: Bool
  type (:/=) (x :: a) (y :: a) :: Bool

  type (x :: a) :== (y :: a) = x == y
  type (x :: a) :/= (y :: a) = Not (x :== y)

infix 4 :==
infix 4 :/=

$(genDefunSymbols [''(:==), ''(:/=)])

-- | The singleton analogue of 'Eq'. Unlike the definition for 'Eq', it is
-- required that instances define a body for '(%:==)'. You may also supply a
-- body for '(%:/=)'.
class (kparam ~ 'KProxy) => SEq (kparam :: KProxy k) where
  -- | Boolean equality on singletons
  (%:==) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :== b)
  infix 4 %:==

  -- | Boolean disequality on singletons
  (%:/=) :: forall (a :: k) (b :: k). Sing a -> Sing b -> Sing (a :/= b)
  default (%:/=) :: forall (a :: k) (b :: k).
                    ((a :/= b) ~ Not (a :== b))
                 => Sing a -> Sing b -> Sing (a :/= b)
  a %:/= b = sNot (a %:== b)
  infix 4 %:/=

$(singEqInstances basicTypes)
$singEqInstances basicTypes
singEqInstances basicTypes


{-# LANGUAGE MagicHash #-}
module LiteralsTest2 where

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

s :: String
s = "\x20"

c :: Char
c = '\x20'

d :: Double
d = 0.00

blah = x
  where
    charH = '\x41'#
    intH = 0004#
    wordH = 005##
    floatH = 3.20#
    doubleH = 04.16##
    -- int64H = 00456L#
    -- word64H = 00456L##
    x = 1


{-# LANGUAGE MultiWayIf #-}
module MultiWayIf where

foo = if | test1 -> e1
         | test2 witharg -> e2
         | otherwise -> def

bar = if { | test1 -> if { | test2 -> e1
                           | test3 -> e2 }
           | test4 -> e3
         }

-- taken from GHC's test suite
x  = 10
x1 = if | x < 10 -> "< 10" | otherwise -> ""
x2 = if | x < 10 -> "< 10"
        | otherwise -> ""
x3 = if | x < 10 -> "< 10"
        | otherwise -> ""
x4 = if | True -> "yes"
x5 = if | True -> if | False -> 1 | True -> 2

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

x7 = (if | True -> 0)

-- issue #98
spam = if | () <- () -> ()


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

module RAE_T32a where

import Data.Kind

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

data TyArr' (a :: *) (b :: *) :: *
type TyArr (a :: *) (b :: *) = TyArr' a b -> *
type family (a :: TyArr k1 k2) @@ (b :: k1) :: k2
data TyPi' (a :: *) (b :: TyArr a *) :: *
type TyPi (a :: *) (b :: TyArr a *) = TyPi' a b -> *
type family (a :: TyPi k1 k2) @@@ (b :: k1) :: k2 @@ b
$(return [])

data MkStar (p :: *) (x :: TyArr' p *)
type instance MkStar p @@ x = *
$(return [])

type instance (MkStar p) @@ x = *
$(return [])

foo :: forall p x . MkStar p @@ x
foo = undefined

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

data instance Sing Sigma (Sigma p r) x where
  SSigma ::
    forall (p :: *) (r :: TyPi p (MkStar p)) (a :: p) (b :: r @@@ a)
    (sp :: Sing * p) (sr :: Sing (TyPi p (MkStar p)) 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)

-- I (RAE) believe this last definition is ill-typed.


{-# LANGUAGE MagicHash #-}
module Main where

import GHC.Prim

data P = Positives Int# Float# Double# Char# Word# deriving Show
data N = Negatives Int# Float# Double# deriving Show

main = do
  print $ Positives 42# 4.23# 4.23## '4'# 4##
  print $ Negatives -4# -4.0# -4.0##


{-# LANGUAGE MagicHash, GHCForeignImportPrim #-}

module T10461 where
import GHC.Exts

foreign import prim cheneycopy :: Any -> Word#

foreign import prim "foo" foo :: Any -> Word#


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

import Language.Haskell.TH

main :: IO ()
main = do
    putStrLn $([| 'a'#   |] >>= stringE . show)
    putStrLn $([| "abc"# |] >>= stringE . show)


{-# LANGUAGE DeriveLift #-}
module T1830_2 where

import Language.Haskell.TH.Syntax (Lift)

data Nothing deriving Lift


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE StarIsType #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns -fwarn-overlapping-patterns #-}

module T3927b where

import Data.Proxy
import GHC.Exts

data Message

data SocketType = Dealer | Push | Pull

data SocketOperation = Read | Write

type family Restrict (a :: SocketOperation) (as :: [SocketOperation])
            :: Constraint where
    Restrict a (a ': as) = ()
    Restrict x (a ': as) = Restrict x as
    Restrict x '[] = ("Error!" ~ "Tried to apply a restricted type!")

type family Implements (t :: SocketType) :: [SocketOperation] where
    Implements Dealer = ['Read, Write]
    Implements Push = '[Write]
    Implements Pull = '[ 'Read]

data SockOp :: SocketType -> SocketOperation -> * where
    SRead :: SockOp sock 'Read
    SWrite :: SockOp sock Write

data Socket :: SocketType -> * where
    Socket :: proxy sock
           -> (forall op . Restrict op (Implements sock)
                 => SockOp sock op -> Operation op)
           -> Socket sock

type family Operation (op :: SocketOperation) :: * where
    Operation 'Read = IO Message
    Operation Write = Message -> IO ()

class Restrict 'Read (Implements t) => Readable t where
    readSocket :: Socket t -> Operation 'Read
    readSocket (Socket _ f) = f (SRead :: SockOp t 'Read)

instance Readable Dealer

type family Writable (t :: SocketType) :: Constraint where
    Writable Dealer = ()
    Writable Push = ()

dealer :: Socket Dealer
dealer = Socket (Proxy :: Proxy Dealer) f
  where
    f :: Restrict op (Implements Dealer) => SockOp Dealer op -> Operation op
    f SRead = undefined
    f SWrite = undefined

push :: Socket Push
push = Socket (Proxy :: Proxy Push) f
  where
    f :: Restrict op (Implements Push) => SockOp Push op -> Operation op
    f SWrite = undefined

pull :: Socket Pull
pull = Socket (Proxy :: Proxy Pull) f
  where
    f :: Restrict op (Implements Pull) => SockOp Pull op -> Operation op
    f SRead = undefined

foo :: IO Message
foo = readSocket dealer


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

module Test10313 where

import "b\x61se" Data.List

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

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

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

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

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

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

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


module ExprPragmas where

-- Should it be possible to ppr the following annotation?
c = {-# GENERATED "foobar" 1 : 2  -  3 :   4 #-} 0.00


module Ppr048 where

{-# SCc foo #-}
foo :: Int -> Int
foo       x = x

{-# SCc foo2 "label" #-}
foo2 :: ()
foo2 = ()


module HolesInfix where

f, g, q :: Int -> Int -> Int
f x y = _ x y
g x y = x `_` y
q x y = x `_a` y


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
module Bug where

class C a b c
data B a b = B { aa :: a, bb :: b }

-- Types requiring parens.
$([d| instance C (Maybe a) (Maybe b) c
    |])

-- ---------------------------------------------------------------------
-- Patterns requiring parens according to hsPatNeedsParens

-- SigPatIn. What about SigPatOut?
$([d| g (a :: (Int -> Int) -> Int) = True |])

-- ViewPat
$([d| h (id -> x) = True |])

-- PrefixCon with non-null args
$([d| f (Just (Just False)) = True |])

-- InfixCon for ConPatIn
$([d| i (B (a `B` c) d) = True |])

-- RecCon does not
$([d| j B { aa = a} = True |])

$([d| k = id @(Maybe Int) |])

$([d| l = case Just 'a' of Just a -> Just ((\x -> x) a) |])


{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
module Bug where

$([d| type family Foo a b
      type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)

      data family Bar a b
      data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)
    |])

{-
    type instance Foo (Maybe a) b = Either (Maybe a) (Maybe b)

becomes

[TySynInstD Bug.Foo
  (TySynEqn
    [AppT
      (ConT GHC.Base.Maybe)
      (VarT a_6989586621679027317)
     ,VarT b_6989586621679027318]
    (AppT
      (AppT
        (ConT Data.Either.Either)
        (AppT
          (ConT GHC.Base.Maybe)
          (VarT a_6989586621679027317)
        )
      )
      (AppT (ConT GHC.Base.Maybe) (VarT b_6989586621679027318))
    )
  )
]

    data instance Bar (Maybe a) b = BarMaybe (Maybe a) (Maybe b)

becomes

[DataInstD [] Bug.Bar
  [AppT
    (ConT GHC.Base.Maybe)
    (VarT a_6989586621679027707)
  ,VarT b_6989586621679027708
  ]
  Nothing
  [NormalC
    BarMaybe_6989586621679027706
    [(Bang
        NoSourceUnpackedness
        NoSourceStrictness
      ,AppT
        (ConT GHC.Base.Maybe)
         (VarT a_6989586621679027707)
      )
    ,(Bang
       NoSourceUnpackedness
       NoSourceStrictness
     ,AppT
       (ConT GHC.Base.Maybe)
       (VarT b_6989586621679027708)
     )
    ]
  ]
  []]

-}


{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}
module T13942 where

$([d| f :: Either Int (Int -> Int)
      f = undefined
    |])

{-

Note: to debug

~/inplace/bin/ghc-stage2 --interactive
load the following
--------------------------------------
import Language.Haskell.TH

foo :: IO ()
foo = do
  r <- runQ ([d| f :: Either Int (Int -> Int)
                 f = undefined
             |])
  print r

----------------------------------------
foo
[SigD f_0 (AppT (AppT (ConT Data.Either.Either) (ConT GHC.Types.Int)) (AppT (AppT ArrowT (ConT GHC.Types.Int)) (ConT GHC.Types.Int)))
,ValD (VarP f_0) (NormalB (VarE GHC.Err.undefined)) []]

[SigD f_0
  (AppT (AppT (ConT Data.Either.Either)
              (ConT GHC.Types.Int))
        (AppT (AppT ArrowT
                    (ConT GHC.Types.Int))
              (ConT GHC.Types.Int)))
-}


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}

import Language.Haskell.TH

class C a b

$([d| data Foo a = Foo a deriving (C a) |])

{-

Note: to debug

~/inplace/bin/ghc-stage2 --interactive
load the following
----------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}

import Language.Haskell.TH

class C a b

main :: IO ()
main = putStrLn $([d| data Foo a = Foo a deriving (C a) |] >>= stringE . show)

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

-}


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}

import Language.Haskell.TH

class (a `C` b) c

$([d| data Foo a = Foo a deriving (y `C` z) |])

{-

Note: to debug

~/inplace/bin/ghc-stage2 --interactive
load the following
----------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}

import Language.Haskell.TH

class (a `C` b) c

main :: IO ()
main
  = putStrLn $([d| data Foo a = Foo a deriving (y `C` z) |] >>= stringE . show)

----------------------------------------
Bceomes

[DataD [] Foo_0 [PlainTV a_2] Nothing
  [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]]
  [DerivClause Nothing
      [AppT (AppT (ConT Main.C) (VarT y_6989586621679027885))
            (VarT z_6989586621679027886)]]]

-}


{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}

import Language.Haskell.TH

$([d| data Foo a = Foo a deriving (a ~ a) |])

{-

Note: to debug

~/inplace/bin/ghc-stage2 --interactive
load the following
----------------------------------------
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -ddump-splices -dsuppress-uniques #-}

import Language.Haskell.TH

class (a `C` b) c

main :: IO ()
main
  = putStrLn $([d| data Foo a = Foo a deriving (a ~ a) |] >>= stringE . show)

----------------------------------------
Becomes

[DataD [] Foo_0 [PlainTV a_2] Nothing
  [NormalC Foo_1 [(Bang NoSourceUnpackedness NoSourceStrictness,VarT a_2)]]
  [DerivClause Nothing
    [AppT (AppT EqualityT (VarT a_2))
          (VarT a_2)]]]

-}


{-# LANGUAGE MultiParamTypeClasses #-}
module T14306 where

class (a `C` b) c

class (a `D` b) c d

class (a `E` b)

class a `F` b


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Werror=typed-holes #-}

main :: IO ()
main = undefined

data Proxy k = Proxy

test1 = _ :: Proxy '[ 'True ]
test2 = _ :: Proxy '[ '[ 1 ] ]
test3 = _ :: Proxy '[ '( "Symbol", 1 ) ]


{-# LANGUAGE DataKinds #-}
{-# LANGUAGE PolyKinds #-}
{-# OPTIONS_GHC -Werror=typed-holes #-}

main :: IO ()
main = undefined

data Proxy k = Proxy

test1 = _ :: Proxy '( 'True, 'False )
test2 = _ :: Proxy '( '( 'True, 'False ), 'False )
test3 = _ :: Proxy '( '[ 1 ], 'False )


{-# LANGUAGE TypeFamilies, TypeOperators #-}

data family (a + b) c d

data instance (Int + Bool) Double = Float


-- This tests trac #249

main = return ()


-- This tests trac #931

module Main where

x = f [1..5] (f [2..] [3..])

f xs ys = l
    where
    l = [ if s then x else y | (x, y) <- zip xs ys ]
    s = g xs ys
    g [] _ = True
    g _ [] = False
    g (x:xs) (y:ys) = g xs ys

main = print (show x)


module T12790 (list) where

import Data.Foldable (asum)
import Text.ParserCombinators.Parsec (Parser, sepBy, try)

data Expr
  = Var Fixity String
  | App Expr Expr

data Fixity = Pref | Inf

cons, nil :: Expr
cons = Var Inf  ":"
nil  = Var Pref "[]"

brackets :: Parser a -> Parser a
brackets = undefined

symbol :: String -> Parser String
symbol = undefined

list :: Parser Expr
list = asum (map (try . brackets) plist) where
  plist = [
    foldr (\e1 e2 -> cons `App` e1 `App` e2) nil `fmap`
      (myParser False `sepBy` symbol ","),
    do e <- myParser False
       _ <- symbol ".."
       return $ Var Pref "enumFrom" `App` e,
    do e  <- myParser False
       _  <- symbol ","
       e' <- myParser False
       _  <- symbol ".."
       return $ Var Pref "enumFromThen" `App` e `App` e',
    do e  <- myParser False
       _  <- symbol ".."
       e' <- myParser False
       return $ Var Pref "enumFromTo" `App` e `App` e',
    do e   <- myParser False
       _   <- symbol ","
       e'  <- myParser False
       _   <- symbol ".."
       e'' <- myParser False
       return $ Var Pref "enumFromThenTo" `App` e `App` e' `App` e''
    ]

myParser :: Bool -> Parser Expr
myParser = undefined


{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module T14931_Bug where

import Prelude (Int, IO, Bool(..), Num(..), Monad(..), not, print)
import qualified Language.Haskell.TH.Syntax as TH
import T14931_State

wat :: IO ()
wat = print $(let playGame []     = do
                      (_, score) <- get
                      return score
                  playGame (x:xs) = do
                      (on, score) <- get
                      case x of
                           'a' | on -> put (on, score + 1)
                           'b' | on -> put (on, score - 1)
                           'c'      -> put (not on, score)
                           _        -> put (on, score)
                      playGame xs

                  startState :: (Bool, Int)
                  startState = (False, 0)
              in TH.lift (evalState (playGame "abcaaacbbcabbab") startState) )


{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module T14931_State (MonadState(..), Lazy.evalState) where

import qualified Control.Monad.Trans.State.Lazy as Lazy (StateT, get, put, evalState)

class Monad m => MonadState s m | m -> s where
    get :: m s
    put :: s -> m ()

instance Monad m => MonadState s (Lazy.StateT s m) where
    get = Lazy.get
    put = Lazy.put


module Main where

main :: IO ()
main = do
  _ <- return $ getInt Circle
  return ()

newtype MyInt = MyInt Int

data Shape = Circle | Square

getInt :: Shape -> MyInt
getInt sh =
  case sh of
    Circle ->
        let (MyInt i) = MyInt 3
        in myInt i
    Square ->
        let (MyInt i) = MyInt 2
        in myInt i
    where
      myInt = MyInt


{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-deprecations #-}
module C where

 data Complex a = !a :+ !a
     deriving (Eq, Show)

 instance  (RealFloat a) => Num (Complex a)  where
     {-# SPECIALISE instance Num (Complex Float) #-}
     {-# SPECIALISE instance Num (Complex Double) #-}
     (x :+ y) + (x' :+ y')   =  (x + x') :+ (y + y')


{-# LANGUAGE BangPatterns #-}
-- Main.hs
module Main (main) where

import NetworkRequestHeader

import Control.Monad

main :: IO ()
main = void $ parseHeaderLines []


{-# LANGUAGE BangPatterns #-}
-- NetworkRequestHeader.hs
module NetworkRequestHeader (parseHeaderLines, parseRequestLine) where

import Control.Exception
import Control.Monad
import Data.ByteString.Internal (ByteString(..), memchr)
import Data.Word
import Foreign.ForeignPtr (withForeignPtr)
import Foreign.Ptr (Ptr, plusPtr, minusPtr, nullPtr)
import Foreign.Storable (peek)

-- | Error types for bad 'Request'.
data InvalidRequest = NonHttp

instance Show InvalidRequest where show _ = ""
instance Exception InvalidRequest

parseHeaderLines :: [ByteString]
                 -> IO (ByteString
                       ,ByteString  --  Path
                       ,ByteString  --  Path, parsed
                       )
parseHeaderLines [] = throwIO $ NonHttp
parseHeaderLines (firstLine:_) = do
    (method, path') <- parseRequestLine firstLine
    let path = path'
    return (method, path', path)

parseRequestLine :: ByteString
                 -> IO (ByteString
                       ,ByteString)
parseRequestLine (PS fptr off len) = withForeignPtr fptr $ \ptr -> do
    when (len < 14) $ throwIO NonHttp
    let methodptr = ptr `plusPtr` off
        limptr = methodptr `plusPtr` len
        lim0 = fromIntegral len

    pathptr0 <- memchr methodptr 32 lim0 -- ' '
    when (pathptr0 == nullPtr || (limptr `minusPtr` pathptr0) < 11) $
        throwIO NonHttp
    let pathptr = pathptr0 `plusPtr` 1
        lim1 = fromIntegral (limptr `minusPtr` pathptr0)

    httpptr0 <- memchr pathptr 32 lim1 -- ' '
    when (httpptr0 == nullPtr || (limptr `minusPtr` httpptr0) < 9) $
        throwIO NonHttp
    let httpptr = httpptr0 `plusPtr` 1
        lim2 = fromIntegral (httpptr0 `minusPtr` pathptr)

    checkHTTP httpptr
    queryptr <- memchr pathptr 63 lim2 -- '?'

    let !method = bs ptr methodptr pathptr0
        !path
          | queryptr == nullPtr = bs ptr pathptr httpptr0
          | otherwise           = bs ptr pathptr queryptr

    return (method,path)
  where
    check :: Ptr Word8 -> Int -> Word8 -> IO ()
    check p n w = do
        w0 <- peek $ p `plusPtr` n
        when (w0 /= w) $ throwIO NonHttp
    checkHTTP httpptr = do
        check httpptr 0 72 -- 'H'
        check httpptr 1 84 -- 'T'
        check httpptr 2 84 -- 'T'
        check httpptr 3 80 -- 'P'
        check httpptr 4 47 -- '/'
        check httpptr 6 46 -- '.'
    bs ptr p0 p1 = PS fptr o l
      where
        o = p0 `minusPtr` ptr
        l = p1 `minusPtr` p0


import B

-- See B.hs for an explanation on how this bug is triggered.

-- This is a linker error, so we have to define a main and link
main :: IO ()
main = putStrLn $ show $ bar 100 Nothing


{-# OPTIONS_GHC -fprof-auto #-}
module B where

plus_noinline :: Integer -> Integer -> Integer
plus_noinline x y = x + y
{-# NOINLINE plus_noinline #-}

-- | This is the key function. We do not want this to be inlined into bar, but
-- we DO want it to be inlined into main (in A.hs). Moreover, when it is inlined
-- into main, we don't want the values inside the tuple to be inlined. To
-- achieve this, in main we call bar with Nothing allowing split to be inlined
-- with the first case, where the values in tuple are calls to NOINLINE
-- functions.
split :: Integer -> Maybe Integer -> (Integer, Integer)
split n Nothing = (n `plus_noinline` 1, n `plus_noinline` 2)
split n (Just m) =
  if n == 0 then (m, m) else split (n - 1) (Just m)

{- | The simplified core for bar is:

[GblId,
 Arity=2,
 Str=<L,U><S,1*U>,
 Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True,
         WorkFree=True, Expandable=True,
         Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
         Tmpl= \ (n_a1Gq [Occ=OnceL] :: Integer)
                 (m_a1Gr [Occ=OnceL] :: Maybe Integer) ->
                 scc<bar>
                 let {
                   ds_s2rg :: (Integer, Integer)
                   [LclId]
                   ds_s2rg = scc<bar.(...)> split n_a1Gq m_a1Gr } in
                 plus_noinline
                   (scc<bar.y>
                    case ds_s2rg of { (y_a2ps [Occ=Once], _ [Occ=Dead])
                      -> y_a2ps })
                   (scc<bar.z>
                    case ds_s2rg of { (_ [Occ=Dead], z_a2pu [Occ=Once])
                      -> z_a2pu })}]
bar
  = \ (n_a1Gq :: Integer) (m_a1Gr :: Maybe Integer) ->
      scc<bar>
      case scc<bar.(...)> split n_a1Gq m_a1Gr of
      { (ww1_s2s7, ww2_s2s8) ->
      plus_noinline ww1_s2s7 ww2_s2s8
      }

Note that there are sccs around the (x,y) pattern match in the unfolding, but
not in the simplified function. See #5889 for a discussion on why the sccs are
present in one but not the other, and whether this is correct.

split is not inlined here, because it is a recursive function.

In A.hs, bar is called with m = Nothing, allowing split to be inlined (as it is
not recursive in that case) and the sccs ARE present in the simplified core of
main (as they are around function calls, not ids). This triggers the linker
error.

-}
bar :: Integer -> Maybe Integer -> Integer
bar n m = y `plus_noinline` z
  where
    (y, z) = split n m


module Foo where

wibble :: a
wibble = {-# SCC "foo bar" #-} wibble


module Main where

import GHC.Stack
import Prelude hiding (mapM)

f :: Int -> IO Int
f x = do currentCallStack >>= print; return (x+1)

mapM :: Monad m => (a -> m b) -> [a] -> m [b]
mapM f xs = go xs
  where go []     = return []
        go (x:xs) = do
          x' <- f x
          xs' <- mapM f xs
          return (x':xs')

main = mapM f [42,42]


{-# LANGUAGE BangPatterns #-}
module Main where

import Debug.Trace
import Text.Printf
import Prelude hiding (map)
import GHC.Stack

f :: Int -> Int
f x = traceStack (printf "f: %d" x) (x * 2)

map :: (a -> b) -> [a] -> [b]
map f xs = go xs
  where go [] = []
        go (x:xs) = f x : map f xs

main = do
  let xs = map f [42,43]
  print xs
  putStrLn =<< renderStack `fmap` (whoCreated $! head xs)


{-
From: dw@minster.york.ac.uk
To: partain
Subject:    a compiler test
Date:        3 Mar 1992 12:31:00 GMT

Will,
   One of the decisions taken at the FLARE meeting yesterday was that we
(FLARE people) should send you (GRASP people) interesting Haskell programs
to test your new compiler. So allow me to present the following program,
written by Colin Runciman in various functional languages over the years,
which puts propositions into clausal form. The original program was
interactive, but I've made it batch so that you can run it over night.
Here is an example run with the prototype compiler. Note the result is
"a <=".

        hc clausify.hs
        Haskell-0.41 (EXPERIMENTAL)
        Glasgow University Haskell Compiler, version 0.41
        G-Code version
        -71$ a.out
        a <=
        -71$

Cheers,

David
-}

------------------------------------------------------------------------------
-- reducing propositions to clausal form
-- Colin Runciman, University of York, 18/10/90

-- an excellent benchmark is: (a = a = a) = (a = a = a) = (a = a = a)
-- batch mode version David Wakeling, February 1992

module Main(main) where

import Data.Ix
import System.Environment

main = do
  (n:_) <- getArgs
  putStr (res (read n))

res n = concat (map clauses xs)
 where xs = take n (repeat "(a = a = a) = (a = a = a) = (a = a = a)")
       {-# NOINLINE xs #-}

data StackFrame = Ast Formula | Lex Char

data Formula =
  Sym Char |
  Not Formula |
  Dis Formula Formula |
  Con Formula Formula |
  Imp Formula Formula |
  Eqv Formula Formula

-- separate positive and negative literals, eliminating duplicates
clause p = clause' p ([] , [])
           where
           clause' (Dis p q)       x   = clause' p (clause' q x)
           clause' (Sym s)       (c,a) = (insert s c , a)
           clause' (Not (Sym s)) (c,a) = (c , insert s a)

-- the main pipeline from propositional formulae to printed clauses
clauses = concat . map disp . unicl . split . disin . negin . elim . parse

conjunct (Con p q) = True
conjunct p = False

-- shift disjunction within conjunction
disin (Dis p (Con q r)) = Con (disin (Dis p q)) (disin (Dis p r))
disin (Dis (Con p q) r) = Con (disin (Dis p r)) (disin (Dis q r))
disin (Dis p q) =
  if conjunct dp || conjunct dq then disin (Dis dp dq)
  else (Dis dp dq)
  where
  dp = disin p
  dq = disin q
disin (Con p q) = Con (disin p) (disin q)
disin p = p

-- format pair of lists of propositional symbols as clausal axiom
disp (l,r) = interleave l spaces ++ "<=" ++ interleave spaces r ++ "\n"

-- eliminate connectives other than not, disjunction and conjunction
elim (Sym s) = Sym s
elim (Not p) = Not (elim p)
elim (Dis p q) = Dis (elim p) (elim q)
elim (Con p q) = Con (elim p) (elim q)
elim (Imp p q) = Dis (Not (elim p)) (elim q)
elim (Eqv f f') = Con (elim (Imp f f')) (elim (Imp f' f))

-- the priorities of propositional expressions
{- UNUSED:
fpri   (Sym c) = 6
fpri   (Not p) = 5
fpri (Con p q) = 4
fpri (Dis p q) = 3
fpri (Imp p q) = 2
fpri (Eqv p q) = 1
-}

-- insertion of an item into an ordered list
-- Note: this is a corrected version from Colin (94/05/03 WDP)
insert x [] = [x]
insert x p@(y:ys) =
  if x < y then x : p
  else if x > y then y : insert x ys
  else p

interleave (x:xs) ys = x : interleave ys xs
interleave []     _  = []

-- shift negation to innermost positions
negin (Not (Not p)) = negin p
negin (Not (Con p q)) = Dis (negin (Not p)) (negin (Not q))
negin (Not (Dis p q)) = Con (negin (Not p)) (negin (Not q))
negin (Dis p q) = Dis (negin p) (negin q)
negin (Con p q) = Con (negin p) (negin q)
negin p = p

-- the priorities of symbols during parsing
opri '(' = 0
opri '=' = 1
opri '>' = 2
opri '|' = 3
opri '&' = 4
opri '~' = 5

-- parsing a propositional formula
parse t = f where [Ast f] = parse' t []

parse' [] s = redstar s
parse' (' ':t) s = parse' t s
parse' ('(':t) s = parse' t (Lex '(' : s)
parse' (')':t) s = parse' t (x:s')
                   where
                   (x : Lex '(' : s') = redstar s
parse' (c:t) s = if inRange ('a','z') c then parse' t (Ast (Sym c) : s)
                 else if spri s > opri c then parse' (c:t) (red s)
                 else parse' t (Lex c : s)

-- reduction of the parse stack
red (Ast p : Lex '=' : Ast q : s) = Ast (Eqv q p) : s
red (Ast p : Lex '>' : Ast q : s) = Ast (Imp q p) : s
red (Ast p : Lex '|' : Ast q : s) = Ast (Dis q p) : s
red (Ast p : Lex '&' : Ast q : s) = Ast (Con q p) : s
red (Ast p : Lex '~' : s) = Ast (Not p) : s

-- iterative reduction of the parse stack
redstar = while ((/=) 0 . spri) red

-- old: partain:
--redstar = while ((/=) (0::Int) . spri) red

spaces = repeat ' '

-- split conjunctive proposition into a list of conjuncts
split p = split' p []
          where
          split' (Con p q) a = split' p (split' q a)
          split' p a = p : a

-- priority of the parse stack
spri (Ast x : Lex c : s) = opri c
spri s = 0

-- does any symbol appear in both consequent and antecedent of clause
tautclause (c,a) = [x | x <- c, x `elem` a] /= []

-- form unique clausal axioms excluding tautologies
unicl a = foldr unicl' [] a
          where
          unicl' p x = if tautclause cp then x else insert cp x
                       where
                       cp = clause p

while p f x = if p x then while p f (f x) else x


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

type S = String

newtype M s a = M { unM :: s -> (s,a) }

instance Monad (M s) where
  (M m) >>= k = M $ \s -> case m s of
                            (s',a) -> unM (k a) s'
  return a = M $ \s -> (s,a)

instance Functor (M s) where
    fmap = liftM

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

errorM :: String -> M s a
errorM s = M $ \_ -> error s

runM :: M s a -> s -> a
runM (M m) s = case m s of (_,a) -> a

main = print (runM (bar ["a","b"]) "state")

bar :: [String] -> M s [String]
bar xs = mapM foo xs

foo :: String -> M s String
foo x = errorM x


-- This example is from the User's Guide, so we better make sure it
-- produces the correct output.

main = print (f 30 + g 30)
  where
    f n  = fib n
    g n  = fib (n `div` 2)

fib n = if n < 2 then 1 else fib (n-1) + fib (n-2)


main :: IO ()
main = do let xs = [1..1000000]
          let ys = [1..2000000]
          print $ {-# SCC "last_xs" #-} last xs
          print $ {-# SCC "last_init_xs" #-} last $ init xs
          print $ {-# SCC "last_ys" #-} last ys
          print $ {-# SCC "last_init_ys" #-}last $ init ys


module Main (main, f, g, h, i) where

main = print (f 42)

f, g, h, i :: Int -> Int
f x = g x + h x + i x

g x = x + 1

{-# INLINE h #-}
h x = x + 2

{-# INLINABLE i #-}
i x = x + 3