-- The classic 8-queens problem made famous by Wirth.
-- This version Colin Runciman, March 2000.

main =
    if null solutions then putStrLn "no solution!"
    else putStr (board (head solutions))
    where
    solutions = queens 8

queens :: Int -> [[Int]]
queens n = valid n n

valid :: Int -> Int -> [[Int]]
valid 0 n = [[]]
valid m n = filter safe (extend n (valid (m-1) n))

extend n b = cp (fromTo 1 n) b

cp :: [a] -> [[a]] -> [[a]]
cp [] y = []
cp (a:x) y = map (a:) y ++ cp x y

safe (a:b) = no_threat a b 1

no_threat a [] m = True
no_threat a (b:y) m =
    a /= b && a+m /= b && a-m /= b && no_threat a y (m+1)

board :: [Int] -> String
board b =
    unlines (concat (zipWith rank (from 1) b))
  where
    rank r qcol =
        map line ["o o o", " \\|/ ", " === "]
      where
        line crown_slice =
            concat (zipWith square (from 1) b)
          where
            square scol _ =
                if scol == qcol then crown_slice
                else if (scol `rem` (2::Int)) == (r `rem` (2::Int)) then "....."
                else "     "

-- in place of ..

from :: Int -> [Int]
from n = n : from (n+1)

fromTo :: Int -> Int -> [Int]
fromTo m n = if m > n then [] else m : fromTo (m+1) n


{-      The purpose of this is to test that record update is
        sufficiently polymorphic.  See comments with
        tcExpr (RecordUpd) in TcExpr.lhs
-}

module Main where

data T a b c d  = MkT1 { op1 :: a, op2 :: b }
               | MkT2 { op1 :: a, op3 :: c }
               | MkT3 { op4 :: a, op5 :: d }

update1 :: a2 -> T a b c d -> T a2 b c d2
update1 x t = t { op1 = x }
        -- NB: the MkT3.op4 case doesn't constrain the result because
        -- it doesn't have an op1 field

update2 :: a2 -> T a b c d -> T a2 b2 c2 d
update2 x t = t { op4 = x }

main = print (op4 $
              update2 True $
              MkT3 { op4 = op2 $
                           update1 (1::Int) $
                           MkT1 { op1 = True }
              })


infixr  ->!,=\

-- auxiliary functions -----------------------------------------------------

g u v w (x:y:z) = i(v x y)(u x y (w z) z)(x:w(y:z))
g u v w [x]     = [x,512]
q u v w nil     = u : 95 : z v : w

long = several.length
((->!),(=\))=(map,($))
a           = g q f
y           = (-)32
z           = (+)32
several     = (>)2
fairlySmall = (<)64
notTooSmall = (>)91
justRight   = (==)95
notTooBig   = (<)96
veryBig     = (>)123
goodSize x  =foldr(&&)
  otherwise =\($x)->![notTooBig,veryBig]
f y z       =fairlySmall(z)&&goodSize(y)&&notTooSmall(z)
i cond th el=if(cond)then(th)else(el)
toBeIsToDoAndToDoIsToBeSaidConFuTse

-- main functions ----------------------------------------------------------

  g  =  interact$map
            toEnum.g.map
            fromEnum
main =
 toBeIsToDoAndToDoIsToBeSaidConFuTse(let h=a;t=x where x x=i(long x)x(h t x)
                                                       q v w x z = - y w:x
                                                       a = g q f
                                                       f x y = justRight x
                                                             && goodSize y
                                     in t)

-- rittri@cs.chalmers.se ---------------------------------------------------


{-
From: Paul Sanders <psanders@srd.bt.co.uk>
To: partain
Subject: A puzzle for you
Date: Mon, 28 Oct 91 17:02:19 GMT

I'm struggling with the following code fragment at the moment:
-}

import Data.Array -- 1.3
import Data.Ix    -- 1.3

conv_list :: (Ix a, Ix b) => [a] -> [b] -> [[c]] -> Array (a,b) c -> Array (a,b) c
conv_list [] _ _ ar = ar
conv_list _ _ [] ar = ar
conv_list (r:rs) cls (rt:rts) ar
      = conv_list rs cls rts ar'
        where ar' = conv_elems r cls rt ar

conv_elems :: (Ix a, Ix b) => a -> [b] -> [c] -> Array (a,b) c -> Array (a,b) c
conv_elems row [] _ ar = ar
conv_elems _ _ [] ar = ar
conv_elems row (col:cls) (rt:rts) ar
      = conv_elems row cls rts ar'
        where ar' = ar // [((row,col), rt)]

ar :: Array (Int, Int) Int
ar = conv_list [(1::Int)..(3::Int)] [(1::Int)..(3::Int)] ar_list init_ar
     where init_ar = array (((1::Int),(1::Int)),((3::Int),(3::Int))) []

ar_list :: [[Int]] -- WDP
ar_list = [[1,2,3],
           [6,7,8],
           [10,12,15]]

main = putStrLn (show ar)

{-
What it tries to do is turn a list of lists into a 2-d array in an incremental
fashion using 2 nested for-loops. It compiles okay on the prototype compiler
but gives a segmentation fault when it executes. I know I can define in the
array in one go (and I have done) but, for my piece of mind, I want to get this
way working properly.

Is it a bug in the prototype or is there a glaringly obvious error in my code
which I've been stupid to spot ????

Hoping its the latter,

Paul.
-}


{-

This test runs for a Long Time (10mins for the registerised version)
and allocates 3.4Gbytes.  It also hammers the GC; with -H16M it spend
40% of the time in the GC.

Date: Sun, 25 Oct 92 16:38:12 GMT
From: Julian Seward (DRL PhD) <sewardj@uk.ac.man.cs>
Message-Id: <9210251638.AA21153@r6b.cs.man.ac.uk>
To: partain@uk.ac.glasgow.dcs
Subject: Space consumption in 0.09 produced binary
Cc: sewardj@uk.ac.man.cs, simonpj@uk.ac.glasgow.dcs

Folks,

At the risk of wasting even more of your valuable time, here is
a small problem I ran into:

The program (XXXX.lhs) listed below runs in constant space (about 4k)
in both Gofer and hbc 0.998.5.  When compiled with 0.09, it runs out
of heap in seconds (4 meg heap).

The program builds a gigantic list of things (CDSs, in fact), I believe
at least 100,000 long, and searches to find out if a particular CDS is
present.  The CDS list is generated lazily, and should be thrown away
as it goes, until apply_cds is found (see the bottom of the listing).
Gofer and hbc behave as expected, but I suspect ghc is holding onto
the complete list unnecessarily.

I include XXXX.stat as supporting evidence.

Jules

(compiled hence:
ghc9 -v -O -gc-ap -flet-float -Rgc-stats -Rmax-heapsize 14M -o XXXX XXXX.lhs
)

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

XXXX +RTS -S

Collector: APPEL  HeapSize: 4,194,304 (bytes)

  Alloc   Live   Live   Astk   Bstk OldGen   GC    GC     TOT     TOT  Page Flts  Collec  Resid
  bytes   bytes    %   bytes  bytes  roots  user  elap    user    elap   GC  TOT   tion   %heap
2097108 1119672  53.4     52    132 1119616  0.33  0.35    1.01    1.15    0    0   Minor
1537300  918200  59.7     48    128 918188  0.26  0.31    1.76    1.95    0    0   Minor
1078216  654212  60.7     56    160 652612  0.19  0.18    2.29    2.46    0    0   Minor
 751108  442140  58.9     52    108 442140  0.12  0.12    2.64    2.84    0    0   Minor
3134224 2935044  93.6     52    108         1.49  1.50    4.13    4.34    0    0  *MAJOR* 70.0%
 629612  376848  59.9     52    132 376836  0.11  0.11    4.44    4.64    0    0   Minor
 441184  265100  60.1     96    200 264416  0.08  0.07    4.66    4.86    0    0   Minor
 308640  204072  66.1     56    160 199476  0.06  0.05    4.81    5.01    0    0   Minor
3781064 3687092  97.5     56    160         1.81  1.85    6.62    6.86    0    0  *MAJOR* 87.9%
 253600  160584  63.3     52    108 160584  0.05  0.04    6.75    6.98    0    0   Minor
 173312  112344  64.8     56    160 110304  0.03  0.03    6.83    7.07    0    0   Minor
 117128   77260  66.0     36    140  74112  0.01  0.02    6.88    7.13    0    0   Minor
4037280 3985284  98.7     36    140         1.96  1.98    8.85    9.11    0    0  *MAJOR* 95.0%

-------------------------------------------------------------------------
-}

> module Main where

> import Prelude hiding (traverse)

%============================================================
%============================================================

\section{A CDS interpreter}

\subsection{Declarations}

Second attempt at a CDS interpreter.  Should do
loop detection correctly in the presence of higher order functions.

The types allowed are very restrictive at the mo.

> data Type = Two
>           | Fn [Type]

Now, we also have to define CDSs and selectors.
\begin{itemize}
\item
@Empty@ is a non-legitimate CDS, denoting no value at all.  We use
it as an argument in calls to other CDSs denoting that
the particular argument is not really supplied.
\item
@Par@ is similarly a non-legit CDS, but useful for constructing
selectors.  It simply denotes the parameter specified (note
parameter numbering starts at 1).
\item
@Zero@ and @One@ are constant valued CDSs.
\item
@Call@.
Calls to other functions are done with @Call@, which expects
the callee to return @Zero@ or @One@, and selects the relevant
branch.  The @Tag@s identify calls in the dependancy list.
Although a @Call@ is a glorified @Case@ statement, the only allowed
return values are @Zero@ and @One@.  Hence the @CDS CDS@ continuations
rather than the more comprehensive @(AList Return CDS)@.
We require arguments to be fully disassembled.
\item @Case@
Case selectors can only be of the following form:
\begin{itemize}
\item
   @[Par n]@  if the n'th parameter is not a function space.
\item
   @[Par n, v1 ... vn]@ if the n'th parameter is a function space of
                      arity n.  The v's may be only @Empty@, @Zero@,
                      @One@, or @Par n@.
\end{itemize}
\end{itemize}
We also have a @Magic@ CDS which is a load of mumbo-jumbo for use
in enumeration of and compilation to CDSs.  Of no significance
whatever here.

> data CDS = Empty
>          | Par Int
>          | Zero
>          | One
>          | Case [CDS] (AList Return CDS)
>          | Call String Tag [CDS] CDS CDS
>          | Magic
>
> type AList a b = [(a, b)]
>
> type Tag = Int

> instance Eq CDS where
>    (Par n1) == (Par n2) = n1 == n2
>    Zero == Zero = True
>    One == One = True
>    (Case sels1 rets1) == (Case sels2 rets2) = sels1 == sels2 &&
>                                               rets1 == rets2
>    (Call f1 t1 sels1 a1 b1) == (Call f2 t2 sels2 a2 b2)
>       = f1 == f2 && t1 == t2 && sels1 == sels2 && a1 == a2 && b1 == b2
>    Magic == Magic = True
>    _ == _ = False

A @Return@ is a temporary thing used to decide which way to go at
a @Case@ statement.

> data Return = RZero
>             | ROne
>             | RP Int

> instance Eq Return where
>    RZero == RZero  = True
>    ROne == ROne = True
>    (RP p1) == (RP p2) = p1 == p2
>    _ == _ = False

We need a code store, which gives out a fresh instance of a CDS
as necessary.  ToDo: Need to rename call sites?  I don't think so.

> type Code = AList String CDS

%============================================================
%============================================================

\subsection{The evaluator}
Main CDS evaluator takes
\begin{itemize}
\item the code store
\item the dependancy list, a list of @Tag@s of calls which are
      currently in progress
\item the current arguments
\item the CDS fragment currently being worked on
\end{itemize}

> type Depends = [Tag]
>
> eval :: Code -> Depends -> [CDS] -> CDS -> CDS

Evaluating a constant valued CDS is trivial.  There may be arguments
present -- this is not a mistake.

> eval co de args Zero = Zero
> eval co de args One  = One

Making a call is also pretty simple, because we assume
that all non-functional arguments are presented as literals,
and all functional values have already been dismantled (unless
they are being passed unchanged in the same position in a recursive call
to the same function, something for the compiler to detect).

Two other issues are at work here.  Guided by the selectors,
we copy the args to make a set of args for the call.  However, if an
copied arg is Empty, the call cannot proceed, so we return the CDS as-is.
Note that an Empty *selector* is not allowed in a Call (although it is
in a Case).

The second issue arises if the call can go ahead.  We need to check the
tag on the call just about to be made with the tags of calls already in
progress (in de) to see if we are looping.  If the tag has already been
encountered, the result of the call is Zero, so the Zero alternative is
immediately selected.

> eval co de args cds@(Call fname tag params alt0 alt1)
>   = let (copied_an_empty, callee_args) = copy_args args params
>         augmented_de      = tag : de
>         callee_code       = lkup co fname
>         callee_result     = eval co augmented_de callee_args callee_code
>         been_here_before  = tag `elem` de
>     in
>         if    copied_an_empty
>         then  cds
>         else
>         if    been_here_before
>         then  eval co augmented_de args alt0
>         else  case callee_result of
>                  Zero -> eval co de args alt0
>                  One  -> eval co de args alt1
>                  _    -> error "Bad callee result"

Case really means "evaluate".

   - make sure first selector is non-Empty.  If so, return CDS as-is.

   - Copy other args.  If Empty is *copied*, return CDS as-is.
     Otherwise, call evaluator and switch on head of result.

Note about switching on the head of the result.  We expect to see
*only* the following as results:

   Zero
   One
   Case [Param m, rest]

in which case switching is performed on

   Zero
   One
   Case (Param m)

ToDo: what happens if a Call turns up ???

> eval co de args cds@(Case ((Par n):ps) alts)
>   = let (copied_an_empty, new_args) = copy_args args ps
>         functional_param = args !! (n-1)
>     in  if    functional_param == Empty ||
>               copied_an_empty
>         then  cds
>         else  eval co de args
>                    (lkup alts (get_head
>                                    (eval co de new_args functional_param)))

Auxiliary for evaluating Case expressions.

> get_head Zero                  = RZero
> get_head One                   = ROne
> get_head (Case ((Par n):_) _)  = RP n

Copy args based on directions in a list of selectors.
Also returns a boolean which is True if an Empty has been
*copied*.  An Empty *selector* simply produces Empty in the
corresponding output position.

> copy_args :: [CDS] -> [CDS] -> (Bool, [CDS])
>
> copy_args args params
>   = case cax False params [] of
>        (empty_copied, res) -> (empty_copied, reverse res)
>     where
>        cax empty [] res = (empty, res)
>        cax empty (Zero:ps) res = cax empty ps (Zero:res)
>        cax empty (One:ps) res = cax empty ps (One:res)
>        cax empty (Empty:ps) res = cax empty ps (Empty:res)
>        cax empty ((Par n):ps) res
>           = case args !! (n-1) of
>                Empty -> cax True ps (Empty:res)
>                other -> cax empty ps (other:res)

> lkup env k = head ( [v | (kk,v) <- env, kk == k] ++
>                       [error ( "Can't look up " ) ] )

%============================================================
%============================================================

%============================================================
%============================================================

Something to make running tests easier ...

> eval0 fname args = eval test [] args (lkup test fname)
>
> two = [Zero, One]

Now for some test data ...

> test
>  =
>  [
>    ("add",     add_cds),
>    ("apply",   apply_cds),
>    ("k0",      k0_cds),
>    ("id",      id_cds),
>    ("k1",      k1_cds),
>    ("kkkr",    kkkr_cds),
>    ("kkkl",    kkkl_cds),
>    ("apply2",  apply2_cds)
>  ]
>

Constant Zero function.

> k0_cds
>   = Case [Par 1]
>         [(RZero, Zero),
>          (ROne,  Zero)]
>

Identity.

> id_cds
>   = Case [Par 1]
>         [(RZero, Zero),
>          (ROne,  One)]

Constant One function.

> k1_cds
>   = Case [Par 1]
>         [(RZero, One),
>          (ROne,  One)]

Strict in both of two arguments, for example (+).

> add_cds
>  =    Case [Par 1]
>          [(RZero, Case [Par 2]
>                        [(RZero, Zero),
>                         (ROne,  Zero)
>                        ]),
>           (ROne, Case [Par 2]
>                       [(RZero, Zero),
>                        (ROne, One)
>                       ])
>          ]

The (in)famous apply function.

> apply_cds
>  = Case [Par 1, Empty]
>        [(RZero, Zero),
>         (ROne, One),
>         (RP 1, Case [Par 2]
>                    [(RZero, Case [Par 1, Zero]
>                                 [(RZero, Zero),
>                                  (ROne, One)]),
>                     (ROne,  Case [Par 1, One]
>                                 [(RZero, Zero),
>                                  (ROne, One)])
>                    ])
>        ]

The inverse K-combinator: K x y = y

> kkkr_cds
>  = Case [Par 2]
>        [(RZero, Zero),
>         (ROne, One)
>        ]

The standard K-combinator, defined thus: K x y = K-inverse y x.
Purpose of this is to test function calling.

> kkkl_cds
>  = Case [Par 1]
>        [(RZero, Case [Par 2]
>                     [(RZero, Call "kkkr" 101 [Zero, Zero] Zero One),
>                      (ROne,  Call "kkkr" 102 [One, Zero]  Zero One)
>                     ]),
>         (ROne,  Case [Par 2]
>                     [(RZero, Call "kkkr" 103 [Zero, One]  Zero One),
>                      (ROne,  Call "kkkr" 104 [One, One]   Zero One)
>                     ])
>        ]

Apply a 2-argument function (apply2 f x y = f x y).

> apply2_cds
>  = Case [Par 1, Empty, Empty]
>        [(RZero, Zero),
>         (ROne, One),
>         (RP 1, Case [Par 2]
>               [(RZero, Case [Par 1, Zero, Empty]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 2, Case [Par 3]
>                                        [(RZero, Case [Par 1, Zero, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, Zero, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ]),
>                (ROne,  Case [Par 1, One, Empty]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 2, Case [Par 3]
>                                        [(RZero, Case [Par 1, One, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, One, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ])
>               ]),
>         (RP 2, Case [Par 3]
>               [(RZero, Case [Par 1, Empty, Zero]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 1, Case [Par 2]
>                                        [(RZero, Case [Par 1, Zero, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, One, Zero]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ]),
>                (ROne,  Case [Par 1, Empty, One]
>                            [(RZero, Zero),
>                             (ROne, One),
>                             (RP 1, Case [Par 2]
>                                        [(RZero, Case [Par 1, Zero, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)]),
>                                         (ROne, Case [Par 1, One, One]
>                                                [(RZero, Zero),
>                                                 (ROne, One)])
>                                        ])
>                            ])
>               ])
>           ]

Simple, isn't it!

%============================================================
%============================================================

%============================================================
%============================================================

Enumeration of all CDSs of a given type.

Define n-ary branched trees.  These are used to hold the
possible prefixes of function arguments, something essential
when enumerating higher-order CDSs. ToDo: translate to English

> data NTree a = NLeaf
>              | NBranch a [NTree a]

The enumeration enterprise involves some mutual recursion
when it comes to higher-order functions.  We define the
top-level enumerator function, for trivial cases, hence:

> enumerate :: Type -> [CDS]
>
> enumerate Two = [Zero, One]
> enumerate (Fn ats) =
>    expand_templates (traverse (length ats) (gen_pfx_trees ats))

Enumerating a function space is tricky.  In summary:

   - Generate the prefix trees for each argument.
     For non-function arguments this trivial, but for
     function-valued arguments this means a call to the
     enumerator to get all the possible values of the
     (argument) function space.

   - Traverse the prefix trees, generating a series of
     "templates" for functions.

   - Expand each template thus generated into a genuine CDS.
     Each template denotes a group of CDSs, all of
     the same "shape" and differing only in the constants
     they return.  The Magic and RMagic constructors are
     used for these purposes.

Generating prefix trees.  For a Two-argument, is easy:

> gen_pfx_trees :: [Type] -> [NTree [CDS]]
>
> gen_pfx_trees ts = zipWith gen_pfx_tree ts [1 .. length ts]
>
> gen_pfx_tree :: Type -> Int -> NTree [CDS]
>
> gen_pfx_tree Two n = NBranch [Par n] []

Note all prefixes are missing the initial (Par n) selector ...

For a function arg

   - enumerate each of the *function's* args

   - starting with a selector [Empty, ...., Empty],
     make a tree wherein at each level, branching is
     achieved by filling in every Empty with every value
     of that argument type.  ToDo: fix this

> gen_pfx_tree (Fn arg_types) n
>   = let number_args = length arg_types
>         enumed_args = map enumerate arg_types
>         initial_sel = take number_args (repeat Empty)
>         init_tree   = NBranch ((Par n):initial_sel) []
>     in
>         expand_pfx_tree number_args number_args n enumed_args init_tree

@expand_pfx_tree@ expands a tree until there are no Emptys
at the leaves.  Its first parameter is the number of Emptys
in the tree it has been given; when zero, expansion is complete.
The second parameter is the number of Emptys in the original
tree (equal to the arity of the function being enumerated).
Third number is the argument number in the top-level function,
needed to make the initial "Par n" selector.
Also needs to carry around the enumeration of the function's
arguments.

> expand_pfx_tree :: Int -> Int -> Int -> [[CDS]] -> NTree [CDS] -> NTree [CDS]
>
> expand_pfx_tree 0 w i enums tree = tree
>
> expand_pfx_tree n w i enums (NBranch sels [])
>   = let indices = [0 .. w - 1]
>         n_minus_1 = n - 1
>         new_sels = concat (map expand_sel indices)
>         expand_sel n
>           = case sels !! (n+1) of
>                Empty -> map (upd (n+1) sels) (enums !! n)
>                other -> []
>         mk_trivial_tree sel = NBranch sel []
>     in
>         NBranch sels (map (expand_pfx_tree n_minus_1 w i enums . mk_trivial_tree)
>                        new_sels)

> upd :: Int -> [a] -> a -> [a]
> upd 0 (y:ys) x = x:ys
> upd n (y:ys) x = y:upd (n-1) ys x

In the second phase, the prefix trees are traversed to generate
CDS templates (full of Magic, but no Zero or One).
The first arg is the number of arguments, and the
second the prefix trees for each argument.

> traverse :: Int -> [NTree [CDS]] -> [CDS]

Each pfxtree denotes a selector, one for each argument, plus a load
of more specific selectors.  So for each argument, one manufactures
all possible sub-cds using the sub-selectors as the set Z.
You then take this arg's selector, and manufacture a load of CDSs
like this:
\begin{verbatim}
   Case this_selector
      0 -> z | z <- Z
      1 -> z | z <- Z
      Par n -> z | z <- Z for each n in [1 .. length this_selector]
                          satisfying this_selector !! n == Empty
\end{verbatim}

> traverse n pfxtrees
>   = Magic : concat (map doOne [0 .. n - 1])
>     where
>        doOne i = traverse_arg n i pfxtrees (pfxtrees !! i)

@traverse_arg@ makes the CDSs corresponding to descending a
particular argument, the number of which is given as its second
parameter.  It also gets the complete set of pfxtrees and the one
to descend.  Note that having descended in the given argument, we
check its sub-selectors.  If none, (an empty list), this replaced
by [NLeaf] to make everything work out.  A NLeaf selector
is a dummy which generates no CDSs.

> traverse_arg n i pfxtrees NLeaf
>   = []

> traverse_arg n i pfxtrees (NBranch this_selector subsidiary_selectors_init)
>   = let subsidiary_selectors
>            = case subsidiary_selectors_init of
>                 [] -> [NLeaf]; (_:_) -> subsidiary_selectors_init
>         subsidiary_pfxtrees = map (upd i pfxtrees) subsidiary_selectors
>         par_requests = preq 1 [] this_selector
>         preq n acc [] = acc
>         preq n acc (Empty:rest) = preq (n+1) ((RP n):acc) rest
>         preq n acc (other:rest) = preq (n+1)         acc  rest
>         subsidiary_cdss = concat (map (traverse n) subsidiary_pfxtrees)
>         all_poss_rhss = splat (2 + length par_requests) subsidiary_cdss
>         all_poss_returns = [RZero,  ROne] ++ par_requests
>     in
>         [Case this_selector (zip all_poss_returns rhs)
>         | rhs <- all_poss_rhss]
>
> splat :: Int -> [a] -> [[a]]
> splat 0 set = [[]]
> splat n set = [x:xs | x <- set, xs <- splat (n-1) set]

The final stage in the game is to fill in all the @Magic@s
with constants.  A template with $n$ @Magic@s presently generates
@2^n@ CDSs, obtained by all possible combinations of
filling each @Magic@ in with @Zero@ or @One@.  To do this we
first need to count the @Magic@s.

> count_magic :: CDS -> Int
>
> count_magic Magic             = 1
> count_magic (Case sels alts)  = sum (map (count_magic.snd) alts)

We don't expect to see anything else at this stage.
Now make $2^n$ lists, each of length $n$, each with a different
sequence of @Zero@s and @One@s.  Use these to label the
@Magic@s in the template.

> label_cds :: CDS -> [CDS] -> ([CDS], CDS)
>
> label_cds Magic (l:ls) = (ls, l)
> label_cds (Case sels alts) ls
>   = case f ls alts of (l9, alts_done) -> (l9, Case sels alts_done)
>     where
>        f l0 []     = (l0, [])
>        f l0 (a:as) = let (l1, a_done)  = lalt l0 a
>                          (l2, as_done) = f l1 as
>                      in  (l2, a_done:as_done)
>        lalt l0 (ret, cds) = case label_cds cds l0 of
>                               (l1, cds_done) -> (l1, (ret, cds_done))

Finally:

> expand_templates :: [CDS] -> [CDS]
>
> expand_templates ts
>    = concat (map f ts)
>      where
>         f tem = map (snd . label_cds tem)
>                     (splat (count_magic tem) [Zero, One])

--> testq tt = (layn . map show' . nub) (enumerate tt)

> main = putStrLn (show (apply_cds `myElem` (enumerate (Fn [Fn [Two], Two]))))
>
> i `myElem` [] = False
> i `myElem` (x:xs) = if i == x then True else i `myElem` xs

%============================================================
%============================================================


-- This test checks that constructors with strictness annotations
-- at least parse correctly.  In GHC 2.02 they didn't!

module Main where

data Foo1 = Crunch1 ! Int ! Int Int deriving( Show )

data Foo2 = Crunch2 ! Int Int Int   deriving( Show )

main = do
        print (Crunch1 (1+1) (2+2) (3+3))
        print (Crunch2 (1+1) (2+2) (3+3))


{-# LANGUAGE UndecidableInstances, ExistentialQuantification,
              ScopedTypeVariables, Rank2Types #-}

--      Modular arithmetic, due to Dale Thurston

-- Here's a way to mimic dependent types using existential types,
-- illustrated by an implementation of modular arithmetic.  To try it
-- out, load modulus.hs and try something like
--      inModulus (mkModulus (1234567890123::Integer)) (^ 98765432198765) 2
-- to compute 2 to the 98765432198765'th power modulo 1234567890123.

-- The key is the definitions at the top of TypeVal.hs:
--
--   class TypeVal a t | t -> a where
--       -- typeToVal should ignore its argument.
--       typeToVal :: t -> a
--
--   data Wrapper a = forall t . (TypeVal a t) => Wrapper t
--
--   class ValToType a where
--      valToType :: a -> Wrapper a
--
-- `valToType' takes a value `x' and returns a (wrapped version of a)
-- fake value in a new type; from the new type, `x' can be recovered by
-- applying typeToVal.
--
-- This code works under ghc.  It uses existentially quantified data
-- constructors, scoped type variables, and explicit universal
-- quantification.

module Main where

import TypeVal

default (Integer)

main = print (map (inModulus (mkModulus (1234567890123::Integer)) (^98765432198765)) [2..1000])

data Mod s a = Mod {value::a} deriving (Eq, Show)

data Modulus a = forall s. TypeVal a s => Modulus (a -> Mod s a) (Mod s a -> a)

mkModulus :: (ValToType a, Integral a) => a -> Modulus a
mkModulus x = case valToType x of {Wrapper (y :: t) ->
              Modulus normalize (value :: Mod t a -> a)}

normalize :: forall a s. (TypeVal a s, Integral a) => a -> Mod s a
normalize x = (Mod (x `mod` typeToVal (undefined::s)))

inModulus :: Modulus a -> (forall s . TypeVal a s =>  Mod s a -> Mod s a)
                -> a -> a
inModulus (Modulus in_ out) f x = out (f (in_ x))

instance (TypeVal a s, Integral a) => Num (Mod s a) where
    Mod x + Mod y = normalize (x + y)
    Mod x - Mod y = normalize (x - y)
    negate (Mod x) = normalize (negate x)
    Mod x * Mod y = normalize (x * y)
    fromInteger a = normalize (fromInteger a)


{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
             UndecidableInstances, ExistentialQuantification,
             ScopedTypeVariables #-}

-- TypeVal.hs: dependent types, here we come!
module TypeVal where

-- The functional dependency is necessary to get ghc to accept
-- some of the instances below.  Is this a bug?
class TypeVal a t | t -> a where
    -- typeToVal should ignore its argument.
    typeToVal :: t -> a

data Wrapper a = forall t . (TypeVal a t) => Wrapper t
instance Show a => Show (Wrapper a) where
   show x = "valToType " ++ show (getValue x)

class ValToType a where
    valToType :: a -> Wrapper a

getValue :: Wrapper a -> a
getValue (Wrapper p) = case p of {(_::t) -> typeToVal (undefined::t)}

-- Instances of ValToType for standard types.  This would also be a
-- straightforward compiler extension for the general case.
---- ValToType Bool
data TRUE = Dummy1
instance TypeVal Bool TRUE where typeToVal = const True
data FALSE = Dummy2
instance TypeVal Bool FALSE where typeToVal = const False

instance ValToType Bool where
    valToType True = Wrapper (undefined :: TRUE)
    valToType False = Wrapper (undefined :: FALSE)

---- ValToType Int, ValToType Integer
data Zero = Dummy3
instance TypeVal Integer Zero where typeToVal = const 0
data Succ n = Dummy4
instance (TypeVal Integer n) => TypeVal Integer (Succ n)
  where typeToVal = const (typeToVal (undefined :: n) + 1)
data Pred n = Dummy5
instance (TypeVal Integer n) => TypeVal Integer (Pred n)
  where typeToVal = const (typeToVal (undefined :: n) - 1)
data Dbl n = Dummy6
instance (TypeVal Integer n) => TypeVal Integer (Dbl n)
  where typeToVal = const (typeToVal (undefined :: n) * 2)

instance ValToType Integer where
    valToType n | n == 0 = Wrapper (undefined :: Zero)
                | even n    =
                   case valToType (div n 2) of {Wrapper x ->
                   case x of {(_ :: t) ->
                   Wrapper (undefined :: Dbl t)}}
                | n > 0  =
                   case valToType (n-1) of {Wrapper x ->
                   case x of {(_ :: t) ->
                   Wrapper (undefined :: Succ t)}}
                | n < 1  =
                   case valToType (n+1) of {Wrapper x ->
                   case x of {(_ :: t) ->
                   Wrapper (undefined :: Pred t)}}

--- ValToType (a,b)
--- Doesn't work.  Perhaps a bug in ghc?
--- Don't need it yet, anyway.
--instance (TypeVal a1 t1, TypeVal a2 t2) => TypeVal (a1,a2) (t1,t2)
--    where typeToVal (x,y) = (typeToVal x, typeToVal y)

--instance (ValToType a, ValToType b) => ValToType (a,b) where
--    valToType (a,b) = case valToType a of {x ->
--                  case valToType b of {y ->
--                  Wrapper (x,y)}}

data NIL a = Dummy20
instance TypeVal [a] (NIL a)
  where typeToVal = const []
data CONS t r = Dummy21
instance (TypeVal [a] r, TypeVal a t) => TypeVal [a] (CONS t r)
  where typeToVal = const (typeToVal (undefined::t):typeToVal (undefined::r))

instance (ValToType a) => ValToType [a] where
  valToType [] = Wrapper (undefined::NIL a)
  valToType (x:xs) = case valToType x of {Wrapper x' ->
                     case x' of {(_::xt) ->
                     case valToType xs of {Wrapper xs' ->
                     case xs' of {(_::xst) ->
                     Wrapper (undefined::CONS xt xst)}}}}


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
module T14833 where

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

class    (a => b) => Implies a b
instance (a => b) => Implies a b

-- Works ok
iota1 :: (() => a) => Dict a
iota1 = Dict

iota2 :: Implies () a => Dict a
iota2 = Dict

{-
[G] Implies () a
[G] (() => a)      -- By superclass

[W] a
-}


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
module Bug where

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

class    (a => b) => Implies a b
instance (a => b) => Implies a b

curryC1 :: ((a, b) => c) => Dict (Implies a (Implies b c))
curryC1 = Dict

curryC2 :: Implies (a, b) c => Dict (Implies a (Implies b c))
curryC2 = Dict


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
module T14863 where

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

class    (a => b) => Implies a b
instance (a => b) => Implies a b

uncurryCImpredic1 :: forall a b c. Implies a (b => c) => Dict (Implies (a, b) c)
uncurryCImpredic1 = Dict

uncurryCImpredic2 :: forall a b c. a => Implies b c => Dict (Implies (a, b) c)
uncurryCImpredic2 = Dict

uncurryC1 :: forall a b c. (a => b => c) => Dict (Implies (a, b) c)
uncurryC1 = Dict

uncurryC2 :: forall a b c. Implies a (Implies b c) => Dict (Implies (a, b) c)
uncurryC2 = Dict


{-# LANGUAGE ConstraintKinds           #-}
{-# LANGUAGE InstanceSigs              #-}
{-# LANGUAGE FlexibleContexts          #-}
{-# LANGUAGE FlexibleInstances         #-}
{-# LANGUAGE GADTs                     #-}
{-# LANGUAGE MultiParamTypeClasses     #-}
{-# LANGUAGE RankNTypes                #-}
{-# LANGUAGE TypeFamilies              #-}
{-# LANGUAGE TypeFamilyDependencies    #-}
{-# LANGUAGE TypeInType                #-}
{-# LANGUAGE TypeOperators             #-}
{-# LANGUAGE UndecidableInstances      #-}
{-# LANGUAGE QuantifiedConstraints     #-}

module T14961 where

import           Data.Kind

import           Control.Arrow              (left, right, (&&&), (|||))
import           Control.Category
import           Prelude                    hiding (id, (.))

import           Data.Coerce

class    (forall x. f x => g x) => f ~=> g
instance (forall x. f x => g x) => f ~=> g

type family (#) (p :: Type -> Type -> Type) (ab :: (Type, Type))
  = (r :: Type) | r -> p ab where
  p # '(a, b) = p a b

newtype Glass
  :: ((Type -> Type -> Type) -> Constraint)
  -> (Type, Type) -> (Type, Type) -> Type where
  Glass :: (forall p. z p => p # ab -> p # st) -> Glass z st ab

data A_Prism

type family ConstraintOf (tag :: Type)
  = (r :: (Type -> Type -> Type) -> Constraint) where
  ConstraintOf A_Prism = Choice

_Left0
  :: Glass Choice
       '(Either a x, Either b x)
       '(a, b)
_Left0 = Glass left'

_Left1
  :: c ~=> Choice
  => Glass c '(Either a x, Either b x) '(a, b)
_Left1 = Glass left'

-- fails with
-- â€¢ Could not deduce (Choice p)
-- _Left2
--   :: (forall p. c p => ConstraintOf A_Prism p)
--   => Glass c '(Either a x, Either b x) '(a, b)
-- _Left2 = Glass left'

_Left3
  :: d ~ ConstraintOf A_Prism
  => (forall p . c p => d p)
  => Glass c
       '(Either a x, Either b x)
       '(a, b)
_Left3 = Glass left'

-- fails to typecheck unless at least a partial type signature is provided
-- l :: c ~=> Choice => Glass c _ _
-- l = _Left1 . _Left1

newtype Optic o st ab where
  Optic
    :: (forall c d. (d ~ ConstraintOf o, c ~=> d) => Glass c st ab)
    -> Optic o st ab

_Left
  :: Optic A_Prism
       '(Either a x, Either b x)
       '(a, b)
_Left = Optic _Left1

instance Category (Glass z) where
  id :: Glass z a a
  id = Glass id

  (.) :: Glass z uv ab -> Glass z st uv -> Glass z st ab
  Glass abuv . Glass uvst = Glass (uvst . abuv)

class Profunctor (p :: Type -> Type -> Type) where
  dimap :: (a -> b) -> (c -> d) -> p b c -> p a d
  lmap :: (a -> b) -> p b c -> p a c
  rmap :: (b -> c) -> p a b -> p a c

class Profunctor p => Choice (p :: Type -> Type -> Type) where
  left' :: p a b -> p (Either a c) (Either b c)
  right' :: p a b -> p (Either c a) (Either c b)


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE QuantifiedConstraints #-}
module Bug where

import Data.Kind

data ECC :: Constraint -> Type -> Type

class Y a
class Z a

instance  c         => Y (ECC c a)
instance (c => Z a) => Z (ECC c a)


{-# LANGUAGE QuantifiedConstraints, TypeFamilies #-}

module T15244 where
class (forall t . Eq (c t)) => Blah c

-- Unquantified works
foo :: (Eq (a t), Eq (b t), a ~ b) => a t -> b t -> Bool
foo a b = a == b
-- Works

-- Two quantified instances fail with double ambiguity check errors
bar :: (forall t . Eq (a t), forall t . Eq (b t), a ~ b) => a t -> b t -> Bool
bar a b = a == b
-- Minimal.hs:11:8: error:
--     â€¢ Could not deduce (Eq (b t1))
--       from the context: (forall t1. Eq (a t1), forall t1. Eq (b t1),
--                          a ~ b)
--         bound by the type signature for:
--                    bar :: forall (a :: * -> *) (b :: * -> *) t.
--                           (forall t1. Eq (a t1), forall t1. Eq (b t1), a ~ b) =>
--                           a t -> b t -> Bool
--         at Minimal.hs:11:8-78
--     â€¢ In the ambiguity check for â€˜barâ€™
--       To defer the ambiguity check to use sites, enable AllowAmbiguousTypes
--       In the type signature:
--         bar :: (forall t. Eq (a t), forall t. Eq (b t), a ~ b) =>
--                a t -> b t -> Bool
--    |
-- 11 | bar :: (forall t . Eq (a t), forall t . Eq (b t), a ~ b) => a t -> b t -> Bool
--    |
-- [And then another copy of the same error]

-- Two copies from superclass instances fail
baz :: (Blah a, Blah b, a ~ b) => a t -> b t -> Bool
baz a b = a == b
-- Minimal.hs:34:11: error:
--     â€¢ Could not deduce (Eq (b t)) arising from a use of â€˜==â€™
--       from the context: (Blah a, Blah b, a ~ b)
--         bound by the type signature for:
--                    baz :: forall (a :: * -> *) (b :: * -> *) t.
--                           (Blah a, Blah b, a ~ b) =>
--                           a t -> b t -> Bool
--         at Minimal.hs:33:1-52
--     â€¢ In the expression: a == b
--       In an equation for â€˜bazâ€™: baz a b = a == b
--    |
-- 34 | baz a b = a == b
--    |

-- Two copies from superclass from same declaration also fail
mugga :: (Blah a, Blah a) => a t -> a t -> Bool
mugga a b = a == b
--     â€¢ Could not deduce (Eq (a t)) arising from a use of â€˜==â€™
--       from the context: (Blah a, Blah a)
--         bound by the type signature for:
--                    mugga :: forall (a :: * -> *) t.
--                             (Blah a, Blah a) =>
--                             a t -> a t -> Bool
--         at Minimal.hs:50:1-47
--     â€¢ In the expression: a == b
--       In an equation for â€˜muggaâ€™: mugga a b = a == b
--    |
-- 51 | mugga a b = a == b
--    |

-- One copy works
quux :: (Blah a, a ~ b) => a t -> b t -> Bool
quux a b = a == b
-- Works


{-# LANGUAGE TypeApplications, ImpredicativeTypes, ScopedTypeVariables,
             QuantifiedConstraints, StandaloneDeriving, GeneralizedNewtypeDeriving #-}

module T15290 where

import Prelude hiding ( Monad(..) )
import Data.Coerce ( Coercible, coerce )

class Monad m where
  join  :: m (m a) -> m a

newtype StateT s m a = StateT { runStateT :: s -> m (s, a) }

newtype IntStateT m a = IntStateT { runIntStateT :: StateT Int m a }

instance Monad m => Monad (StateT s m) where
  join = error "urk"

instance (Monad m, forall p q. Coercible p q => Coercible (m p) (m q))
      => Monad (IntStateT m) where

--   Fails with the impredicative instantiation of coerce, succeeds without

-- Impredicative version (fails)
--    join = coerce
--          @(forall a. StateT Int m (StateT Int m a) -> StateT Int m a)
--          @(forall a. IntStateT m (IntStateT m a)   -> IntStateT m a)
--          join

-- Predicative version (succeeds)
    join = (coerce
           @(StateT Int m (StateT Int m a) -> StateT Int m a)
           @(IntStateT m (IntStateT m a)   -> IntStateT m a)
           join) :: forall a. IntStateT m (IntStateT m a)   -> IntStateT m a


{-# LANGUAGE TypeApplications, ImpredicativeTypes, ScopedTypeVariables,
             QuantifiedConstraints, StandaloneDeriving, GeneralizedNewtypeDeriving #-}

module T15290a where

import Prelude hiding ( Monad(..) )
import Data.Coerce ( Coercible, coerce )

class Monad m where
  join  :: m (m a) -> m a

newtype StateT s m a = StateT { runStateT :: s -> m (s, a) }

newtype IntStateT m a = IntStateT { runIntStateT :: StateT Int m a }

instance Monad m => Monad (StateT s m) where
  join = error "urk"

instance (Monad m, forall p q. Coercible p q => Coercible (m p) (m q))
      => Monad (IntStateT m) where

--   Fails with the impredicative instantiation of coerce, succeeds without

-- Impredicative version (fails)
    join = coerce
          @(forall a. StateT Int m (StateT Int m a) -> StateT Int m a)
          @(forall a. IntStateT m (IntStateT m a)   -> IntStateT m a)
          join

-- Predicative version (succeeds)
--    join = (coerce
--           @(StateT Int m (StateT Int m a) -> StateT Int m a)
--           @(IntStateT m (IntStateT m a)   -> IntStateT m a)
--           join) :: forall a. IntStateT m (IntStateT m a)   -> IntStateT m a


{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module T15290b where

import Data.Coerce
import Data.Kind

type Representational1 m = (forall a b. Coercible a b => Coercible (m a) (m b) :: Constraint)

class Representational1 f => Functor' f where
  fmap' :: (a -> b) -> f a -> f b

class Functor' f => Applicative' f where
  pure'  :: a -> f a
  (<*>@) :: f (a -> b) -> f a -> f b

class Functor' t => Traversable' t where
  traverse' :: Applicative' f => (a -> f b) -> t a -> f (t b)

-- Typechecks
newtype T1 m a = MkT1 (m a) deriving (Functor', Traversable')


{-# LANGUAGE RankNTypes, QuantifiedConstraints, ConstraintKinds  #-}
-- NB: disabling these if enabled:
{-# LANGUAGE NoUndecidableInstances, NoUndecidableSuperClasses #-}

module T15316 where

import Data.Proxy

{-
class Class a where
         method :: a

subsume :: (Class a => Class b) => Proxy a -> Proxy b -> ((Class a => Class b) => r) -> r
subsume _ _ x = x

value :: Proxy a -> a
value p = subsume p p method
-}

subsume' :: Proxy c -> ((c => c) => r) -> r
subsume' _ x = x


{-# LANGUAGE MultiParamTypeClasses, PolyKinds, QuantifiedConstraints, RankNTypes #-}

module T15334 where

class C m a
class D m a

f :: (forall a. Eq a => (C m a, D m a)) => m a
f = undefined


{-# LANGUAGE MultiParamTypeClasses, GADTs, RankNTypes,
             ConstraintKinds, QuantifiedConstraints #-}

module T15359 where

class C a b

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

foo :: (forall a b. C a b => a ~ b) => Dict (C a b) -> a -> b
foo Dict x = x


{-# LANGUAGE MultiParamTypeClasses, GADTs, RankNTypes,
             ConstraintKinds, QuantifiedConstraints,
             UndecidableInstances #-}

module T15359a where

class C a b
class a ~ b => D a b

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

foo :: (forall a b. C a b => D a b) => Dict (C a b) -> a -> b
foo Dict x = x


{-# Language GADTs, MultiParamTypeClasses, QuantifiedConstraints #-}

module T15625 where

import Data.Coerce

class a ~ b => Equal a b

test1 :: (forall b. a ~ b) => a
test1 = False

test2 :: (forall b. Equal a b) => a
test2 = False

test3 :: (forall b. Coercible a b) => a
test3 = coerce False


{-# Language RankNTypes, ConstraintKinds, QuantifiedConstraints,
             PolyKinds, GADTs, MultiParamTypeClasses,
             DataKinds, FlexibleInstances #-}

module T15625a where

import Data.Kind

type Cat ob = ob -> ob -> Type

data KLEISLI (m :: Type -> Type) :: Cat (KL_kind m) where
  MkKLEISLI :: (a -> m b) -> KLEISLI(m) (KL a) (KL b)

data KL_kind (m :: Type -> Type) = KL Type

class    (a ~ KL xx) => AsKL a xx
instance (a ~ KL xx) => AsKL a xx

ekki__ :: Monad m => (forall xx. AsKL a xx) => KLEISLI m a a
ekki__ = MkKLEISLI undefined


{-# Language PolyKinds             #-}
{-# Language TypeFamilies          #-}
{-# Language ConstraintKinds       #-}
{-# Language FlexibleContexts      #-}
{-# Language QuantifiedConstraints #-}
{-# Language UndecidableInstances  #-}
module T15918 where

import Data.Kind

class Rev f where
  rev :: f a

instance (forall xx. cls xx => Rev xx) => Rev (Build cls) where
  rev = undefined

data Build :: ((k -> Type) -> Constraint) -> (k -> Type)

uu = rev :: Build [] a


{-# LANGUAGE QuantifiedConstraints  #-}

-- Two simple examples that should work

module T2893 where

f :: forall b c. (Eq b, forall a. Eq a => Eq (c a)) => c b -> Bool
{-# NOINLINE f #-}
f x = x==x

g x = f [x]

data Rose f x = Rose x (f (Rose f x))

instance (Eq a, forall b. Eq b => Eq (f b))
      => Eq (Rose f a)  where
  (Rose x1 rs1) == (Rose x2 rs2)
     = x1==x2 && rs1 == rs2


{-# LANGUAGE
    GADTs
  , FlexibleContexts
  , RankNTypes
  , ScopedTypeVariables
  , QuantifiedConstraints #-}

module T2893a where

import Control.Monad.ST
import Data.Array.ST

sortM
  :: forall a s.
     (Ord a, MArray (STUArray s) a (ST s))
  => [a]
  -> ST s [a]
sortM xs = do
  arr <- newListArray (1, length xs) xs
           :: ST s (STUArray s Int a)
  -- do some in-place sorting here
  getElems arr

sortP_3
  :: (Ord a, forall s. MArray (STUArray s) a (ST s))
  => [a] -> [a]
sortP_3 xs = runST (sortM xs)


{-# LANGUAGE QuantifiedConstraints  #-}

module T2893c where

data Rose f x = Rose x (f (Rose f x))

instance Eq a => Eq (Rose f a)  where
  (Rose x1 _) == (Rose x2 _) = x1==x2

-- Needs superclasses
instance (Ord a, forall b. Ord b => Ord (f b))
      => Ord (Rose f a)  where
  (Rose x1 rs1) >= (Rose x2 rs2)
     = x1 >= x2 && rs1 == rs2
  a <= b = False  -- Just to suppress the warning


{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE InstanceSigs, RoleAnnotations  #-}

module T9123 where

import Data.Coerce

type role Wrap representational nominal
newtype Wrap m a = Wrap (m a)

class Monad' m where
  join' :: forall a. m (m a) -> m a

-- Tests the superclass stuff
instance (forall p q. Coercible p q => Coercible (m p) (m q), Monad' m) => Monad' (Wrap m) where
  join' :: forall a. Wrap m (Wrap m a) -> Wrap m a
  join' = coerce @(m (m a) -> m a)
                 @(Wrap m (Wrap m a) -> Wrap m a)
                 join'


{-# LANGUAGE QuantifiedConstraints, PolyKinds, ScopedTypeVariables
           , StandaloneDeriving, RoleAnnotations, TypeApplications
           , UndecidableInstances, InstanceSigs
           , GeneralizedNewtypeDeriving #-}

module T9123a where

import Data.Coerce

class MyMonad m where
  join :: m (m a) -> m a

newtype StateT s m a = StateT (s -> m (a, s))

type role StateT nominal representational nominal   -- as inferred

instance MyMonad m => MyMonad (StateT s m) where
  join = error "urk"  -- A good impl exists, but is not
                      -- of interest for this test case

newtype IntStateT m a = IntStateT (StateT Int m a)

type role IntStateT representational nominal   -- as inferred

instance (MyMonad m, forall p q. Coercible p q => Coercible (m p) (m q))
               => MyMonad (IntStateT m) where
  join :: forall a. IntStateT m (IntStateT m a) -> IntStateT m a
  join = coerce @(StateT Int m (StateT Int m a) -> StateT Int m a)
                @(IntStateT  m (IntStateT  m a) -> IntStateT  m a)
                join


{-# LANGUAGE QuasiQuotes #-}

import T14028Quote

s :: String
s = [here|goes nothing|]

main = putStrLn s


module T14028Quote where
import Language.Haskell.TH
import Language.Haskell.TH.Quote

here :: QuasiQuoter
here = QuasiQuoter { quoteExp  = litE . stringL,
                     quotePat = undefined ,
                     quoteType = undefined,
                     quoteDec = undefined }


{-# LANGUAGE QuasiQuotes #-}

module T3953 where

foo = [notDefinedHere| |]


{-# LANGUAGE CPP, QuasiQuotes #-}

module Main (main) where

import T4150A

myHtmlsTemplate = [multiLineStr|
#include "T4150template.txt"
|]

somethingElse :: NoSuchType
somethingElse = undefined

main :: IO ()
main = print myHtmlsTemplate


module T4150A where

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

multiLineStr :: QuasiQuoter
multiLineStr = QuasiQuoter {
                   quoteExp  = stringE,
                   quotePat  = error "XXX",
                   quoteType = error "XXX",
                   quoteDec  = error "XXX"
               }


{-# LANGUAGE TypeSynonymInstances, TemplateHaskell, QuasiQuotes, MultiParamTypeClasses, FlexibleInstances, DeriveDataTypeable, NamedFieldPuns, ScopedTypeVariables #-}
module Pnm where
import qualified Data.Char as Char
-- import Language.Pads.Padsc
import Control.Monad

_ws = one_or_more Char.isSpace
  where one_or_more = undefined

ws, wsnl, whitechar :: RE

ws   = REd "[ \t\n\r]+" " "                      -- whitespace
wsnl = let REd wplus _ = ws in REd wplus "\n"    -- whitespace output as \n
whitechar = REd "[ \t\n\r]" "\n"                 -- one white character

[pads|

  data PGMx a = PGM "P5" ws Header whitechar (Pixmap a)

  data Header = Header  -- fields should be separated by whitespace
    {      width  :: Int
    ws   , height :: Int
    wsnl , constrain denominator :: Int
                    where <| 0 <= denominator && denominator < 65536 |>
    }

  data Pixmap a (h::Header) = Rows   [Row a h | wsnl] length <| height h |>
  data Row    a (h::Header) = Pixels [a h     | ws]   length <| width h |>

  newtype Greypix (h::Header) =
     G constrain g::Int16 where <| 0 <= g && g <= denominator h |>

  data PGM = PGMx Int16 Greypix

]

pgm file = do (rep, md) <- parseFile file
              return rep


-- | Check the source spans associated with the expansion of quasi-quotes
module Main (main) where

import GHC
import DynFlags
import Outputable
import MonadUtils
import NameSet
import Var

import Data.Data

import System.Environment
import Control.Monad
import Control.Monad.Trans.State
import Data.List
import Data.Ord
import Prelude hiding (traverse)

type Traverse a = State (SrcSpan, [(Name, SrcSpan)]) a

traverse :: Data a => a -> Traverse a
traverse a =
    skipNameSet (cast a) a $ do
      updateLoc  (cast a)
      showVar    (cast a)
      showTyVar  (cast a)
      showPatVar (cast a)
      gmapM traverse a
  where
    showVar :: Maybe (HsExpr GhcTc) -> Traverse ()
    showVar (Just (HsVar _ (L _ v))) =
      modify $ \(loc, ids) -> (loc, (varName v, loc) : ids)
    showVar _ =
      return ()

    showTyVar :: Maybe (HsType GhcRn) -> Traverse ()
    showTyVar (Just (HsTyVar _ _ (L _ v))) =
      modify $ \(loc, ids) -> (loc, (v, loc) : ids)
    showTyVar _ =
      return ()

    showPatVar :: Maybe (Pat GhcTc) -> Traverse ()
    showPatVar (Just (VarPat _ (L _ v))) =
      modify $ \(loc, ids) -> (loc, (varName v, loc) : ids)
    showPatVar _
      = return ()

    -- Updating the location in this way works because we see the SrcSpan
    -- before the associated term due to the definition of GenLocated
    updateLoc :: Maybe SrcSpan -> Traverse ()
    updateLoc (Just loc) = modify $ \(_, ids) -> (loc, ids)
    updateLoc _          = return ()

    skipNameSet :: Monad m => Maybe NameSet -> a -> m a -> m a
    skipNameSet (Just _) a _ = return a
    skipNameSet Nothing  _ f = f

test7918 :: Ghc ()
test7918 = do
  dynFlags <- getSessionDynFlags
  void $ setSessionDynFlags (gopt_set dynFlags Opt_BuildDynamicToo)

  let target = Target {
                   targetId           = TargetFile "T7918B.hs" Nothing
                 , targetAllowObjCode = True
                 , targetContents     = Nothing
                 }
  setTargets [target]
  void $ load LoadAllTargets

  typecheckedB <- getModSummary (mkModuleName "T7918B") >>= parseModule >>= typecheckModule
  let (_loc, ids) = execState (traverse (tm_typechecked_source typecheckedB)) (noSrcSpan, [])
  liftIO . forM_ (sortBy (comparing snd) (reverse ids)) $ putStrLn . showSDoc dynFlags . ppr

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


{-# LANGUAGE TemplateHaskell #-}
module T7918A where

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

qq = QuasiQuoter {
         quoteExp  = \str -> case str of
                                "e1" -> [| True |]
                                "e2" -> [| id True |]
                                "e3" -> [| True || False |]
                                "e4" -> [| False |]
       , quoteType = \str -> case str of
                                "t1" -> [t| Bool |]
                                "t2" -> [t| Maybe Bool |]
                                "t3" -> [t| Either Bool Int |]
                                "t4" -> [t| Int |]
       , quotePat  = let x = VarP (mkName "x")
                         y = VarP (mkName "y")
                     in \str -> case str of
                                  "p1" -> return $ x
                                  "p2" -> return $ ConP 'Just [x]
                                  "p3" -> return $ TupP [x, y]
                                  "p4" -> return $ y
       , quoteDec  = undefined
       }


{-# LANGUAGE QuasiQuotes #-}
module T7918B where

import T7918A

ex1 = [qq|e1|]
ex2 = [qq|e2|]
ex3 = [qq|e3|]
ex4 = [qq|e4|]

tx1 = undefined :: [qq|t1|]
tx2 = undefined :: [qq|t2|]
tx3 = undefined :: [qq|t3|]
tx4 = undefined :: [qq|t4|]

px1 [qq|p1|] = undefined
px2 [qq|p2|] = undefined
px3 [qq|p3|] = undefined
px4 [qq|p4|] = undefined


{-# LANGUAGE QuasiQuotes #-}
module Main where

parse = undefined

main :: IO ()
main = print $ [parse||]


{-# LANGUAGE QuasiQuotes #-}
module Main where

parse = undefined

main :: IO ()
main = case () of
         [parse||] -> return ()
         _ -> return ()


{-# LANGUAGE QuasiQuotes #-}
module Main where

main :: IO ()
main = print $ \parse -> [parse||]


{-# LANGUAGE QuasiQuotes #-}
module Main where

main :: IO ()
main = p undefined
  where
    p = \parse -> case () of
                    [parse||] -> return ()
                    _ -> return ()


{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
module Expr where

import Data.Data
import Data.Typeable
import Language.Haskell.TH as TH
import Language.Haskell.TH.Quote

import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Char

data Expr  =  IntExpr Integer
           |  AntiIntExpr String
           |  BinopExpr BinOp Expr Expr
           |  AntiExpr String
    deriving(Typeable, Data)

data BinOp  =  AddOp
            |  SubOp
            |  MulOp
            |  DivOp
    deriving(Typeable, Data)

eval :: Expr -> Integer
eval (IntExpr n)        = n
eval (BinopExpr op x y) = (opToFun op) (eval x) (eval y)
  where
    opToFun AddOp = (+)
    opToFun SubOp = (-)
    opToFun MulOp = (*)
    opToFun DivOp = (div)

small :: CharParser st Char
small   = lower <|> char '_'
large   = upper
idchar  = small <|> large <|> digit <|> char '\''

lexeme p    = do{ x <- p; spaces; return x  }
symbol name = lexeme (string name)
parens p    = between (symbol "(") (symbol ")") p

_expr :: CharParser st Expr
_expr   = term   `chainl1` mulop

term :: CharParser st Expr
term    = factor `chainl1` addop

factor :: CharParser st Expr
factor  = parens _expr <|> integer <|> anti

mulop   =   do{ symbol "*"; return $ BinopExpr MulOp }
        <|> do{ symbol "/"; return $ BinopExpr DivOp }

addop   =   do{ symbol "+"; return $ BinopExpr AddOp }
        <|> do{ symbol "-"; return $ BinopExpr SubOp }

integer :: CharParser st Expr
integer  = lexeme $ do{ ds <- many1 digit ; return $ IntExpr (read ds) }

anti   = lexeme $
         do  symbol "$"
             c <- small
             cs <- many idchar
             return $ AntiIntExpr (c : cs)

parseExpr :: Monad m => TH.Loc -> String -> m Expr
parseExpr (Loc {loc_filename = file, loc_start = (line,col)}) s =
    case runParser p () "" s of
      Left err  -> fail $ show err
      Right e   -> return e
  where
    p = do  pos <- getPosition
            setPosition $ setSourceName (setSourceLine (setSourceColumn pos col) line) file
            spaces
            e <- _expr
            eof
            return e

expr = QuasiQuoter { quoteExp = parseExprExp, quotePat = parseExprPat,
                     quoteType = undefined, quoteDec = undefined }

parseExprExp :: String -> Q Exp
parseExprExp s =  do  loc <- location
                      expr <- parseExpr loc s
                      dataToExpQ (const Nothing `extQ` antiExprExp) expr

antiExprExp :: Expr -> Maybe (Q Exp)
antiExprExp  (AntiIntExpr v)  = Just $ appE  (conE (mkName "IntExpr"))
                                                (varE (mkName v))
antiExprExp  (AntiExpr v)     = Just $ varE  (mkName v)
antiExprExp  _                = Nothing

parseExprPat :: String -> Q Pat
parseExprPat s =  do  loc <- location
                      expr <- parseExpr loc s
                      dataToPatQ (const Nothing `extQ` antiExprPat) expr

antiExprPat :: Expr -> Maybe (Q Pat)
antiExprPat  (AntiIntExpr v)  = Just $ conP  (mkName "IntExpr")
                                                [varP (mkName v)]
antiExprPat  (AntiExpr v)     = Just $ varP  (mkName v)
antiExprPat  _                = Nothing

-- Copied from syb for the test

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


{-# LANGUAGE QuasiQuotes #-}
module Main where

import Expr

main :: IO ()
main = do  print $ eval [expr|1 + 3 + 5|]
           case [expr|2|] of
             [expr|$n|] -> print n
             _          -> return ()
           case [expr|1 + 2|] of
             [expr|$x + $y|] -> putStrLn $ show x ++ " + " ++ show y
             _               -> return ()


{-# LANGUAGE QuasiQuotes #-}
module Main where

import Expr

main :: IO ()
main = do  case [expr|1 + 2|] of
             [expr|$x + $x|] -> print x
             _               -> return ()


{-# LANGUAGE TemplateHaskell #-}
module QQ where

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

pq = QuasiQuoter { quoteDec = \_ -> [d| f x = x |],
                   quoteType = \_ -> [t| Int -> Int |],
                   quoteExp = \_ -> [| $(varE (mkName "x")) + 1::Int |],
                   quotePat = \_ -> [p| Just x |] }


{-# LANGUAGE QuasiQuotes #-}
module Test where

import QQ

f :: [pq| foo |]    -- Expands to Int -> Int
[pq| blah |]        -- Expands to f x = x

h [pq| foo |] = f [pq| blah |] * 8
        -- Expands to h (Just x) = f (x+1) * 8


{-# LANGUAGE QuasiQuotes #-}
module Test where

import QQ

f :: [pq| foo |]    -- Expands to Int -> Int
[pq| blah |]        -- Expands to f x = x

h [pq| foo |] = f [pq| blah |] * 8
-- Expands to h (Just x) = f (x+1) * 8


{-# LANGUAGE TemplateHaskell #-}
module QQ where

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

pq = QuasiQuoter { quoteDec = \_ -> return [sig],
                   quoteType = \_ -> undefined,
                   quoteExp = \_ -> undefined,
                   quotePat = \_ -> undefined }

sig = SigD (mkName "f") (ArrowT `AppT` int `AppT` int)
int = ConT (mkName "Int")


{-# LANGUAGE QuasiQuotes #-}
module Test where

import QQ

f' = f . (+ 1)

[pq| foo |]         -- Expands to f :: Int -> Int
f x = x + 1


{-# OPTIONS_GHC -Wno-missing-fields#-}
module A where

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

aquoter :: QuasiQuoter
aquoter = QuasiQuoter {quoteType = conT . mkName }


{-# LANGUAGE QuasiQuotes #-}
module B where

import A

foo:: [aquoter|Int|] -> [aquoter|String|]
foo = show


{-# LANGUAGE DeriveDataTypeable #-}

module A where

import Data.Data
import Data.Typeable

data Foo = Foo Int
  deriving (Show, Data, Typeable)


{-# LANGUAGE TemplateHaskell #-}

module Main where

import Language.Haskell.TH.Quote

import qualified A as B

test1 :: [Int]
test1 = $(dataToExpQ (const Nothing) [1 :: Int, 2, 3])

test2 :: ()
test2 = $(dataToExpQ (const Nothing) ())

test3 :: (Int, Int, Int)
test3 = $(dataToExpQ (const Nothing) (1 :: Int, 2 :: Int, 3 :: Int))

test4 :: Rational
test4 = $(dataToExpQ (const Nothing) (5.5 :: Rational))

test5 :: B.Foo
test5 = $(dataToExpQ (const Nothing) (B.Foo 1))

main :: IO ()
main = do
    print test1
    print test2
    print test3
    print test4
    print test5


{-# LANGUAGE TemplateHaskellQuotes, RankNTypes, ScopedTypeVariables #-}
module A where
x = \(y :: forall a. a -> a) -> [|| y ||]


-- Trac #2931

module Foo where
a = 1

-- NB: no newline after the 'a'!
b = 'a


{-# LANGUAGE EmptyDataDecls #-}

-- Trac #3572

module Main where

import Language.Haskell.TH
import Language.Haskell.TH.Ppr

main = putStrLn . pprint =<< runQ [d| data Void |]


{-# LANGUAGE TypeFamilies, RankNTypes, FlexibleContexts #-}

module T4056 where
import Language.Haskell.TH

astTest :: Q [Dec]
astTest = [d|
    class C t where
        op :: [t] -> [t]
        op = undefined
  |]

class D t where
  bop :: [t] -> [t]
  bop = undefined


-- Crashed GHC 6.12

module T4165 where

import Language.Haskell.TH
class Numeric a where
    fromIntegerNum :: a
    fromIntegerNum = undefined

ast :: Q [Dec]
ast = [d|
    instance Numeric Int
    |]


module T4170 where

import Language.Haskell.TH

class LOL a

lol :: Q [Dec]
lol = [d|
    instance LOL Int
    |]

instance LOL Int


{-# LANGUAGE ScopedTypeVariables #-}

module T5371 where
import Language.Haskell.TH

f :: a -> Name
f (x :: a) = ''a


{-# LANGUAGE DataKinds #-}

module T8455 where

ty = [t| 5 |]


module Main where
import Language.Haskell.TH.Syntax

t1 = case mkName "^.." of
    Name (OccName ".")  (NameQ (ModName "^")) -> error "bug0"
    Name (OccName "^..") NameS                -> return ()

t2 = case mkName "Control.Lens.^.." of
    Name (OccName ".")  (NameQ (ModName "Control.Lens.^")) -> error "bug1"
    Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return ()

t3 = case mkName "Data.Bits..&." of
    Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return ()

t4 = case mkName "abcde" of
    Name (OccName "abcde") NameS -> return ()

main :: IO ()
main = do t1; t2; t3; t4


{-# LANGUAGE PatternSynonyms #-}

module T8759a where

foo = [d| pattern Q = False |]


{-# OPTIONS_GHC -fwarn-unused-matches #-}

module T9824 where

foo = [p| (x, y) |]


module TH_abstractFamily where

import Language.Haskell.TH

-- Empty closed type families are okay...
ds1 :: Q [Dec]
ds1 = [d| type family F a where |]

-- ...but abstract ones should result in a type error
ds2 :: Q [Dec]
ds2 = [d| type family G a where .. |]


-- Check that declarations in a bracket shadow the top-level
-- declarations, rather than clashing with them.

module TH_bracket1 where

foo = 1
bar = [d| foo = 1 |]


module TH_bracket2 where

d_show = [d| data A = A

             instance Show A  where
                 show _ = "A"
         |]


{-# LANGUAGE MultiParamTypeClasses #-}

module TH_bracket3 where

d_class = [d| class Classy a b where
                 f :: a -> b

              instance Classy Int Bool where
                 f x = if x == 0 then True else False
           |]


module TH_localname where

x = \y -> [| y |]


{-# LANGUAGE MultiParamTypeClasses #-}

module Main (main) where

import Language.Haskell.TH

u1 :: a
u1 = undefined

u2 :: a
u2 = undefined

f :: a
f = undefined

(.+.) :: a
(.+.) = undefined

main :: IO ()
main = do runQ [| f u1 u2 |] >>= p
          runQ [| u1 `f` u2 |] >>= p
          runQ [| (.+.) u1 u2 |] >>= p
          runQ [| u1 .+. u2 |] >>= p
          runQ [| (:) u1 u2 |] >>= p
          runQ [| u1 : u2 |] >>= p
          runQ [| \((:) x xs) -> x |] >>= p
          runQ [| \(x : xs) -> x |] >>= p
          runQ [d| class Foo a b where
                       foo :: a -> b   |] >>= p
          runQ [| \x -> (x, 1 `x` 2) |] >>= p
          runQ [| \(+) -> ((+), 1 + 2) |] >>= p
          runQ [| (f, 1 `f` 2) |] >>= p
          runQ [| ((.+.), 1 .+. 2) |] >>= p

p :: Ppr a => a -> IO ()
p = putStrLn . pprint


-- test reification of monomorphic types

module TH_reifyType1
where

import Language.Haskell.TH

foo :: Int -> Int
foo x = x + 1

type_foo :: InfoQ
type_foo = reify 'foo


-- test reification of polymorphic types

module TH_reifyType1
where

import Language.Haskell.TH

type_length :: InfoQ
type_length = reify 'length


-- test the representation of literals and also explicit type annotations

module TH_repE1
where

import Language.Haskell.TH

integralExpr :: ExpQ
integralExpr = [| 42 |]

intExpr :: ExpQ
intExpr = [| 42 :: Int |]

integerExpr :: ExpQ
integerExpr = [| 42 :: Integer |]

charExpr :: ExpQ
charExpr = [| 'x' |]

stringExpr :: ExpQ
stringExpr = [| "A String" |]

fractionalExpr :: ExpQ
fractionalExpr = [| 1.2 |]

floatExpr :: ExpQ
floatExpr = [| 1.2 :: Float |]

doubleExpr :: ExpQ
doubleExpr = [| 1.2 :: Double |]


-- test the representation of literals and also explicit type annotations

module TH_repE1
where

import Language.Haskell.TH

emptyListExpr :: ExpQ
emptyListExpr = [| [] |]

singletonListExpr :: ExpQ
singletonListExpr = [| [4] |]

listExpr :: ExpQ
listExpr = [| [4,5,6] |]

consExpr :: ExpQ
consExpr = [| 4:5:6:[] |]


-- Test for Trac #2188

module TH_scope where

f g = [d| f :: Int
          f = g
          g :: Int
          g = 4 |]


{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE AllowAmbiguousTypes #-}  -- 'bar' is ambiguous

module TH_tf2 where

{-
$( [d| class C a where
         data T a
         foo :: Bool -> T a |] )

$( [d| instance C Int where
         data T Int = TInt Bool
         foo b = TInt (b && b) |] )

$( [d| instance C Float where
         data T Float = TFloat {flag :: Bool}
         foo b = TFloat {flag = b && b} |] )
-}

class D a where
         type S a
         bar :: S a -> Int

instance D Int where
         type S Int = Bool
         bar c = if c then 1 else 2


{-# LANGUAGE ViewPatterns #-}
module A where

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

foo :: QuasiQuoter
foo = QuasiQuoter{quotePat = \s -> viewP [|(*2)|] (varP . mkName $ s)}

bar :: QuasiQuoter
bar = QuasiQuoter{quotePat = \_ -> [p|((*3) -> fixed_var)|] }


{-# LANGUAGE QuasiQuotes, ViewPatterns #-}

module Main where

import A

main = do
  case 1 of
    [foo|x|] -> print x
  case 1 of
    [bar|<!anything~|] -> print fixed_var


{-# OPTIONS -XRebindableSyntax #-}
-- Haskell98!

-- Tests of the do-notation for the parameterized monads
-- We demonstrate a variable-type state `monadic' transformer
-- and its phantom-type-state relative to enforce the locking protocol
-- (a lock can be released only if it is being held, and acquired only
-- if it is not being held)
-- The tests are based on the code
-- http://okmij.org/ftp/Computation/monads.html#param-monad

-- Please search for DO-NOT-YET

module DoParamM where

import Prelude (const, String, ($), (.), Maybe(..),
                Int, fromInteger, succ, pred, fromEnum, toEnum,
                (+), Char, (==), Bool(..),
                IO, getLine, putStrLn, read, show)
import qualified Prelude
import qualified Control.Monad.State as State
import qualified Control.Monad.Identity as IdM

-- A parameterized `monad'
class Monadish m where
    return :: a -> m p p a
    fail   :: String -> m p p a
    (>>=)  :: m p q a -> (a -> m q r b) -> m p r b

m1 >> m2 = m1 >>= (const m2)

-- All regular monads are the instances of the parameterized monad

newtype RegularM m p q a = RegularM{unRM :: m a}

instance Prelude.Monad m => Monadish (RegularM m) where
    return = RegularM . Prelude.return
    fail   = RegularM . Prelude.fail
    m >>= f = RegularM ((Prelude.>>=) (unRM m) (unRM . f))

-- As a warm-up, we write the regular State computation, with the same
-- type of state throughout. We thus inject Monad.State into the
-- parameterized monad

test1 = State.runState (unRM c) (0::Int) where
         c = gget >>= (\v -> gput (succ v) >> return v)
         gget :: (State.MonadState s m) => RegularM m s s s
         gget = RegularM State.get
         gput :: (State.MonadState s m) => s -> RegularM m s s ()
         gput = RegularM . State.put
-- (0,1)

-- The same in the do-notation
test1_do = State.runState (unRM c) (0::Int) where
         c = do
             v <- gget
             gput (succ v)
             return v
         gget :: (State.MonadState s m) => RegularM m s s s
         gget = RegularM State.get
         gput :: (State.MonadState s m) => s -> RegularM m s s ()
         gput = RegularM . State.put
-- (0,1)

-- Introduce the variable-type state (transformer)

newtype VST m si so v = VST{runVST:: si -> m (so,v)}

instance Prelude.Monad m => Monadish (VST m) where
  return x = VST (\si -> Prelude.return (si,x))
  fail x   = VST (\si -> Prelude.fail x)
  m >>= f  = VST (\si -> (Prelude.>>=) (runVST m si)
                                       (\ (sm,x) -> runVST (f x) sm))

vsget :: Prelude.Monad m => VST m si si si
vsget = VST (\si -> Prelude.return (si,si))
vsput :: Prelude.Monad m => so -> VST m si so ()
vsput x = VST (\si -> Prelude.return (x,()))

-- Repeat test1 via VST: the type of the state is the same
vsm1 () = vsget >>= (\v -> vsput (succ v) >> return v)

-- The same with the do-notation
vsm1_do () = do
             v <- vsget
             vsput (succ v)
             return v

{-
 *DoParamM> :t vsm1
 vsm1 :: (Monadish (VST m), IdM.Monad m, Prelude.Enum si) =>
         () -> VST m si si si
-}

test2 = IdM.runIdentity (runVST (vsm1 ()) (0::Int))
-- (1,0)

test2_do = IdM.runIdentity (runVST (vsm1_do ()) (0::Int))
-- (1,0)

-- Now, we vary the type of the state, from Int to a Char
vsm2 () = vsget >>= (\v -> vsput ((toEnum (65+v))::Char) >>
                           vsget >>= \v' -> return (v,v'))

{-
 *DoParamM> :t vsm2
 vsm2 :: (Monadish (VST m), IdM.Monad m) => () -> VST m Int Char (Int, Char)
-}

-- The same with the do-notation
 -- the following does not yet work
vsm2_do () = do
             v <- vsget
             vsput ((toEnum (65+v))::Char)
             v' <- vsget
             return (v,v')

test3 = IdM.runIdentity (runVST (vsm2 ()) (0::Int))
-- ('A',(0,'A'))

test3_do = IdM.runIdentity (runVST (vsm2_do ()) (0::Int))
-- ('A',(0,'A'))

{- The following is a deliberate error:

 DoParamM.hs:147:55:
    Couldn't match expected type `Int' against inferred type `Char'
    In the second argument of `(==)', namely `v''
    In the first argument of `return', namely `(v == v')'
    In the expression: return (v == v')

vsm3 () = vsget >>= (\v -> vsput ((toEnum (65+v))::Char) >>
                           vsget >>= \v' -> return (v==v'))
 -}

 -- The following too must report a type error -- the expression
--    return (v == v') must be flagged, rather than something else
vsm3_do () = do
             v <- vsget
             vsput ((toEnum (65+v))::Char)
             v' <- vsget
             return (v==v')

-- Try polymorphic recursion, over the state.
-- crec1 invokes itself, and changes the type of the state from
-- some si to Bool.
crec1 :: (Prelude.Enum si, Prelude.Monad m) => VST m si si Int
crec1 = vsget >>= (\s1 -> case fromEnum s1 of
                      0 -> return 0
                      1 -> vsput (pred s1) >> return 1
                      _ -> vsput True >>
                           crec1 >>= (\v ->
                             (vsput s1 >> -- restore state type to si
                              return (v + 10))))

-- The same in the do-notation
crec1_do :: (Prelude.Enum si, Prelude.Monad m) => VST m si si Int
crec1_do = do
        s1 <- vsget
        case fromEnum s1 of
           0 -> return 0
           1 -> do {vsput (pred s1); return 1}
           _ -> do
                vsput True
                v <- crec1_do
                vsput s1 -- restore state type to si
                return (v + 10)

test4 = IdM.runIdentity (runVST crec1 'a')
-- ('a',11)

test4_do = IdM.runIdentity (runVST crec1_do 'a')
-- ('a',11)

-- Another example, to illustrate locking and static reasoning about
-- the locking state

data Locked = Locked; data Unlocked = Unlocked
newtype LIO p q a = LIO{unLIO::IO a}

instance Monadish LIO where
  return  = LIO . Prelude.return
  m >>= f = LIO ((Prelude.>>=) (unLIO m) (unLIO . f))

lput :: String -> LIO p p ()
lput = LIO . putStrLn
lget :: LIO p p String
lget = LIO getLine

-- In the real program, the following will execute actions to acquire
-- or release the lock. Here, we just print out our intentions.
lock :: LIO Unlocked Locked ()
lock = LIO (putStrLn "Lock")

unlock :: LIO Locked Unlocked ()
unlock = LIO (putStrLn "UnLock")

-- We should start in unlocked state, and finish in the same state
runLIO :: LIO Unlocked Unlocked a -> IO a
runLIO = unLIO

-- User code

tlock1 = lget >>=  (\l ->
         return (read l) >>= (\x ->
         lput (show (x+1))))

tlock1r = runLIO tlock1

-- the same in the do-notation
tlock1_do = do
            l <- lget
            let x = read l
            lput (show (x+1))

{-
  *VarStateM> :t tlock1
  tlock1 :: LIO p p ()
 Inferred type has the same input and output states and is polymorphic:
 tlock1 does not affect the state of the lock.
-}

tlock2 = lget >>= (\l ->
         lock >> (
         return (read l) >>= (\x ->
         lput (show (x+1)))))

tlock2_do = do
            l <- lget
            lock
            let x = read l
            lput (show (x+1))

{-
  *VarStateM> :t tlock2
  tlock2 :: LIO Unlocked Locked ()

The inferred type says that the computation does the locking.
-}

tlock3 = tlock2 >> unlock
tlock3r = runLIO tlock3

{-
  *DoParamM> :t tlock3
  tlock3 :: LIO Unlocked Unlocked ()
-}

{-
*DoParamM> tlock3r
-- user input: 123
Lock
124
UnLock
-}

tlock3_do = do {tlock2_do; unlock}
tlock3r_do = runLIO tlock3_do

-- An attempt to execute the following
-- tlock4 = tlock2 >> tlock2

{-
 gives a type error:
    Couldn't match expected type `Locked'
           against inferred type `Unlocked'
      Expected type: LIO Locked r b
      Inferred type: LIO Unlocked Locked ()
    In the expression: tlock2
    In a lambda abstraction: \ _ -> tlock2

The error message correctly points out an error of acquiring an already
held lock.
-}

-- The following too must be an error: with the SAME error message as above
tlock4_do = do {tlock2_do; tlock2_do}

-- Similarly, the following gives a type error because of an attempt
-- to release a lock twice
-- tlock4' = tlock2 >> unlock >> unlock
{-
DoParamM.hs:298:30:
    Couldn't match expected type `Unlocked'
           against inferred type `Locked'
      Expected type: LIO Unlocked r b
      Inferred type: LIO Locked Unlocked ()
    In the second argument of `(>>)', namely `unlock'
    In the expression: (tlock2 >> unlock) >> unlock
-}

 -- The following too must be an error: with the SAME error message as above
tlock4'_do = do {tlock2_do; unlock; unlock}


{-# LANGUAGE RebindableSyntax, MultiParamTypeClasses,
             FlexibleInstances, FlexibleContexts #-}

-- Tests of the do-notation for the restricted monads
-- We demonstrate that all ordinary monads are restricted monads,
-- and show the frequently requested implementation
-- of MonadPlus in terms of Data.Set.
--
-- The tests are based on the code
-- http://okmij.org/ftp/Haskell/types.html#restricted-datatypes

module DoRestrictedM where

import Data.List
import Prelude (const, String, ($), (.), Maybe(..))
import qualified Prelude
import qualified Data.Set as Set

-- Defining the restricted monad
class MN2 m a where
    return  :: a -> m a
    fail    :: String -> m a

class (MN2 m a, MN2 m b) => MN3 m a b where
    (>>=) :: m a -> (a -> m b) -> m b

m1 >> m2 = m1 >>= (const m2)

-- All regular monads are the instances of the restricted monad

newtype RegularM m a = RegularM{unRM :: m a}

instance Prelude.Monad m => MN2 (RegularM m) a where
    return = RegularM . Prelude.return
    fail   = RegularM . Prelude.fail

instance Prelude.Monad m => MN3 (RegularM m) a b where
    m >>= f = RegularM ((Prelude.>>=) (unRM m) (unRM . f))

-- We try to inject Maybe (as the regular monad) into Restricted Monad

test1s () =  return "a" >>= (\x -> return $ "b" ++ x)
test1f () =  fail ""    >>= (\x -> return $ "b" ++ x)

-- the same with the do-notation

test1s_do () = do
  x <- return "a"
  return $ "b" ++ x

{-
whose inferred type is
   *DoRestrictedM> :t test1s
   test1s :: (MN3 m [Prelude.Char] [Prelude.Char]) => () -> m [Prelude.Char]
-}

test1sr :: Maybe String
test1sr = unRM $ test1s ()
-- Just "ba"

test1fr :: Maybe String
test1fr = unRM $ test1f ()
-- Nothing

test1sr_do :: Maybe String
test1sr_do = unRM $ test1s_do ()
-- Just "ba"

-- As often requested, we implement a MonadPlus `monad'
-- in terms of a Set. Set requires the Ord constraint.

newtype SMPlus a = SMPlus{unSM:: Set.Set a}

instance MN2 SMPlus a where
    return = SMPlus . Set.singleton
    fail x = SMPlus $ Set.empty

instance Prelude.Ord b => MN3 SMPlus a b where
    m >>= f = SMPlus (Set.fold (Set.union . unSM . f) Set.empty (unSM m))

-- We cannot forget the Ord constraint, because the typechecker
-- will complain (and tell us exactly what we have forgotten).

-- Now we can instantiate the previously written test1s and test1d
-- functions for this Set monad:

test2sr :: Set.Set String
test2sr = unSM $ test1s ()
-- fromList ["ba"]

test2fr :: Set.Set String
test2fr = unSM $ test1f ()
-- fromList []

test2sr_do :: Set.Set String
test2sr_do = unSM $ test1s_do ()
-- fromList ["ba"]


{-# OPTIONS_GHC -Wno-missing-monadfail-instances #-}
{-# LANGUAGE RebindableSyntax, NPlusKPatterns, NoMonadFailDesugaring #-}

module RebindableCase1 where
        {
--      import Prelude;
        import Prelude(String,undefined,Maybe(..), (==), (>=) );

        return :: a;
        return = undefined;

        infixl 1 >>=;
        (>>=) :: a;
        (>>=) = undefined;

        infixl 1 >>;
        (>>) :: a;
        (>>) = undefined;

        fail :: a;
        fail = undefined;

        fromInteger :: a;
        fromInteger = undefined;

        fromRational :: a;
        fromRational = undefined;

        negate :: a;
        negate = undefined;

        (-) :: a;
        (-) = undefined;

        test_do f g = do
                {
                f;
                Just a <- g;
                return a;
                };

        test_fromInteger = 1;

        test_fromRational = 0.5;

        test_negate a = - a;

        test_fromInteger_pattern 1 = undefined;
        test_fromInteger_pattern (-1) = undefined;
        test_fromInteger_pattern (a + 7) = a;

        test_fromRational_pattern 0.5 = undefined;
        test_fromRational_pattern (-0.5) = undefined;
        test_fromRational_pattern _ = undefined;
        }


{-# LANGUAGE RebindableSyntax #-}
module Main where
import Prelude

ifThenElse :: Int -> String -> String -> String
ifThenElse a b c = case a > 0 of
    True -> b
    False -> c

main :: IO ()
main = do
     print $ if -5 then "this fails" else "this works"
     print $ if 5 then "this works" else "this fails"


{-# LANGUAGE RebindableSyntax, MonadFailDesugaring #-}
{-# OPTIONS_GHC -Wno-missing-monadfail-instances #-}

-- Test that rebindable clash warnings are not displayed. This program
-- should not generate anything on stderr at compile time.

module Main where

import Prelude

catMaybes xs = do
    Just x <- xs
    return x

main = return ()


{-# LANGUAGE RebindableSyntax, MonadFailDesugaring #-}
{-# OPTIONS_GHC -Wmissing-monadfail-instances #-}

-- Test that rebindable clash warnings are displayed.

module Main where

import Prelude

catMaybes xs = do
    Just x <- xs
    return x

main = return ()


{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-}
{-# OPTIONS -Wno-error=missing-monadfail-instances #-}

module Main where
        {
--      import Prelude;
        import qualified Prelude;
        import Prelude(String,undefined,Maybe(..),IO,putStrLn,
                Integer,(++),Rational, (==), (>=) );

        import Prelude(Monad(..),Applicative(..),Functor(..));
        import Control.Monad(ap, liftM);

        debugFunc :: String -> IO a -> IO a;
        debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>>
                (ioa Prelude.>>= (\a ->
                        (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a)
                ));

        newtype TM a = MkTM {unTM :: IO a};

        instance (Functor TM) where
          {
            fmap = liftM;
          };
        instance (Applicative TM) where
          {
            pure  = return;
            (<*>) = ap;
          };
        instance (Monad TM) where
                {
                return a = MkTM (debugFunc "return" (Prelude.return a));

                (>>=) ma amb = MkTM (debugFunc ">>=" ((Prelude.>>=) (unTM ma) (\a -> unTM (amb a))));

                (>>) ma mb = MkTM (debugFunc ">>" ((Prelude.>>) (unTM ma) (unTM mb)));

                fail s = MkTM (debugFunc "fail" (Prelude.return undefined));
                };

        preturn a = MkTM (Prelude.return a);

        fromInteger :: Integer -> Integer;
        fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times

        fromRational :: Rational -> Rational;
        fromRational a = a Prelude.+ a Prelude.+ a; -- three times

        negate :: a -> a;
        negate a = a; -- don't actually negate

        (-) :: a -> a -> a;
        (-) x y = y; -- changed function

        test_do f g = do
                {
                f;                              -- >>
                Just a <- g;    -- >>= (and fail if g returns Nothing)
                return a;               -- return
                };

        test_fromInteger = 27;

        test_fromRational = 31.5;

        test_negate a = - a;

        test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a);
        test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a);
        test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a;

        test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a);
        test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a);
        test_fromRational_pattern a = "_=" ++ (Prelude.show a);

        tmPutStrLn s = MkTM (putStrLn s);

        doTest :: String -> TM a -> IO ();
        doTest s ioa =
                (putStrLn ("start test " ++ s))
                        Prelude.>>
                (unTM ioa)
                        Prelude.>>
                (putStrLn ("end test " ++ s));

        main :: IO ();
        main =
                (doTest "test_do failure"
                        (test_do (preturn ()) (preturn Nothing))
                )
                        Prelude.>>
                (doTest "test_do success"
                        (test_do (preturn ()) (preturn (Just ())))
                )
                        Prelude.>>
                (doTest "test_fromInteger"
                        (tmPutStrLn (Prelude.show test_fromInteger)) -- 27 * 5 = 135
                )
                        Prelude.>>
                (doTest "test_fromRational"
                        (tmPutStrLn (Prelude.show test_fromRational)) -- 31.5 * 3 = 189%2
                )
                        Prelude.>>
                (doTest "test_negate"
                        (tmPutStrLn (Prelude.show (test_negate 3))) -- 3 * 5 = 15, non-negate
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern 1"
                        (tmPutStrLn (test_fromInteger_pattern 1)) -- 1 * 5 = 5, matches "1"
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern (-2)"
                        (tmPutStrLn (test_fromInteger_pattern (-2))) -- "-2" = 2 * 5 = 10
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern 9"
                        (tmPutStrLn (test_fromInteger_pattern 9)) -- "9" = 45, 45 "-" "7" = "7" = 35
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern 0.5"
                        (tmPutStrLn (test_fromRational_pattern 0.5)) -- "0.5" = 3%2
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern (-0.7)"
                        (tmPutStrLn (test_fromRational_pattern (-0.7))) -- "-0.7" = "0.7" = 21%10
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern 1.7"
                        (tmPutStrLn (test_fromRational_pattern 1.7)) -- "1.7" = 51%10
                );
        }


{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-}
{-# OPTIONS -Wno-error=missing-monadfail-instances #-}

module Main where
        {
--      import Prelude;
        import qualified Prelude;
        import Prelude(String,undefined,Maybe(..),IO,putStrLn,
                Integer,(++),Rational, (==), (>=) );

        debugFunc :: String -> IO a -> IO a;
        debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>>
                (ioa Prelude.>>= (\a ->
                        (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a)
                ));

        return :: a -> IO a;
        return a = debugFunc "return" (Prelude.return a);

        infixl 1 >>=;
        (>>=) :: IO a -> (a -> IO b) -> IO b;
        (>>=) ma amb = debugFunc ">>=" ((Prelude.>>=) ma amb);

        infixl 1 >>;
        (>>) :: IO a -> IO b -> IO b;
        (>>) ma mb = debugFunc ">>" ((Prelude.>>) ma mb);

        fail :: String -> IO a;
        fail s = debugFunc "fail" (Prelude.return undefined);
--      fail s = debugFunc "fail" (Prelude.fail s);

        fromInteger :: Integer -> Integer;
        fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times

        fromRational :: Rational -> Rational;
        fromRational a = a Prelude.+ a Prelude.+ a; -- three times

        negate :: a -> a;
        negate a = a; -- don't actually negate

        (-) :: a -> a -> a;
        (-) x y = y; -- changed function

        test_do f g = do
                {
                f;                              -- >>
                Just a <- g;    -- >>= (and fail if g returns Nothing)
                return a;               -- return
                };

        test_fromInteger = 27;

        test_fromRational = 31.5;

        test_negate a = - a;

        test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a);
        test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a);
        test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a;

        test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a);
        test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a);
        test_fromRational_pattern a = "_=" ++ (Prelude.show a);

        doTest :: String -> IO a -> IO ();
        doTest s ioa =
                (putStrLn ("start test " ++ s))
                        Prelude.>>
                ioa
                        Prelude.>>
                (putStrLn ("end test " ++ s));

        main :: IO ();
        main =
                (doTest "test_do failure"
                        (test_do (Prelude.return ()) (Prelude.return Nothing))
                )
                        Prelude.>>
                (doTest "test_do success"
                        (test_do (Prelude.return ()) (Prelude.return (Just ())))
                )
                        Prelude.>>
                (doTest "test_fromInteger"
                        (putStrLn (Prelude.show test_fromInteger))
                )
                        Prelude.>>
                (doTest "test_fromRational"
                        (putStrLn (Prelude.show test_fromRational))
                )
                        Prelude.>>
                (doTest "test_negate"
                        (putStrLn (Prelude.show (test_negate 3)))
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern 1"
                        (putStrLn (test_fromInteger_pattern 1))
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern (-2)"
                        (putStrLn (test_fromInteger_pattern (-2)))
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern 9"
                        (putStrLn (test_fromInteger_pattern 9))
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern 0.5"
                        (putStrLn (test_fromRational_pattern 0.5))
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern (-0.7)"
                        (putStrLn (test_fromRational_pattern (-0.7)))
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern 1.7"
                        (putStrLn (test_fromRational_pattern 1.7))
                );
        }


{-# LANGUAGE RebindableSyntax, NPlusKPatterns #-}
{-# OPTIONS -Wno-error=missing-monadfail-instances #-}

module Main where
        {
--      import Prelude;
        import qualified Prelude;
        import Prelude(String,undefined,Maybe(..),IO,putStrLn,
                Integer,(++),Rational, (==), (>=) );

        debugFunc :: String -> IO a -> IO a;
        debugFunc s ioa = (putStrLn ("++ " ++ s)) Prelude.>>
                (ioa Prelude.>>= (\a ->
                        (putStrLn ("-- " ++ s)) Prelude.>> (Prelude.return a)
                ));

        infixl 1 >>=;
        infixl 1 >>;

        class MyMonad m where
                {
                return :: a -> m a;
                (>>=) :: m a -> (a -> m b) -> m b;
                (>>) :: m a -> m b -> m b;
                fail :: String -> m a;
                };

        instance MyMonad IO where
                {
                return a = debugFunc "return" (Prelude.return a);

                (>>=) ma amb = debugFunc ">>=" ((Prelude.>>=) ma amb);

                (>>) ma mb = debugFunc ">>" ((Prelude.>>) ma mb);

                fail s = debugFunc "fail" (Prelude.return undefined);
        --      fail s = debugFunc "fail" (Prelude.fail s);
                };

        fromInteger :: Integer -> Integer;
        fromInteger a = a Prelude.+ a Prelude.+ a Prelude.+ a Prelude.+ a; -- five times

        fromRational :: Rational -> Rational;
        fromRational a = a Prelude.+ a Prelude.+ a; -- three times

        negate :: a -> a;
        negate a = a; -- don't actually negate

        (-) :: a -> a -> a;
        (-) x y = y; -- changed function

        test_do f g = do
                {
                f;                              -- >>
                Just a <- g;    -- >>= (and fail if g returns Nothing)
                return a;               -- return
                };

        test_fromInteger = 27;

        test_fromRational = 31.5;

        test_negate a = - a;

        test_fromInteger_pattern a@1 = "1=" ++ (Prelude.show a);
        test_fromInteger_pattern a@(-2) = "(-2)=" ++ (Prelude.show a);
        test_fromInteger_pattern (a + 7) = "(a + 7)=" ++ Prelude.show a;

        test_fromRational_pattern a@0.5 = "0.5=" ++ (Prelude.show a);
        test_fromRational_pattern a@(-0.7) = "(-0.7)=" ++ (Prelude.show a);
        test_fromRational_pattern a = "_=" ++ (Prelude.show a);

        doTest :: String -> IO a -> IO ();
        doTest s ioa =
                (putStrLn ("start test " ++ s))
                        Prelude.>>
                ioa
                        Prelude.>>
                (putStrLn ("end test " ++ s));

        main :: IO ();
        main =
                (doTest "test_do failure"
                        (test_do (Prelude.return ()) (Prelude.return Nothing))
                )
                        Prelude.>>
                (doTest "test_do success"
                        (test_do (Prelude.return ()) (Prelude.return (Just ())))
                )
                        Prelude.>>
                (doTest "test_fromInteger"
                        (putStrLn (Prelude.show test_fromInteger))
                )
                        Prelude.>>
                (doTest "test_fromRational"
                        (putStrLn (Prelude.show test_fromRational))
                )
                        Prelude.>>
                (doTest "test_negate"
                        (putStrLn (Prelude.show (test_negate 3)))
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern 1"
                        (putStrLn (test_fromInteger_pattern 1))
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern (-2)"
                        (putStrLn (test_fromInteger_pattern (-2)))
                )
                        Prelude.>>
                (doTest "test_fromInteger_pattern 9"
                        (putStrLn (test_fromInteger_pattern 9))
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern 0.5"
                        (putStrLn (test_fromRational_pattern 0.5))
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern (-0.7)"
                        (putStrLn (test_fromRational_pattern (-0.7)))
                )
                        Prelude.>>
                (doTest "test_fromRational_pattern 1.7"
                        (putStrLn (test_fromRational_pattern 1.7))
                );
        }