-- |
-- Language.Haskell.TH.Lib.Internal exposes some additional functionality that
-- is used internally in GHC's integration with Template Haskell. This is not a
-- part of the public API, and as such, there are no API guarantees for this
-- module from version to version.

-- Why do we have both Language.Haskell.TH.Lib.Internal and
-- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the
-- former (which are tailored for GHC's use) need different type signatures
-- than the ones in the latter. Syncing up the Internal type signatures would
-- involve a massive amount of breaking changes, so for the time being, we
-- relegate as many changes as we can to just the Internal module, where it
-- is safe to break things.

module Language.Haskell.TH.Lib.Internal where

import Language.Haskell.TH.Syntax hiding (Role, InjectivityAnn)
import qualified Language.Haskell.TH.Syntax as TH
import Control.Monad( liftM, liftM2 )
import Data.Word( Word8 )
import Prelude

----------------------------------------------------------
-- * Type synonyms
----------------------------------------------------------

type InfoQ               = Q Info
type PatQ                = Q Pat
type FieldPatQ           = Q FieldPat
type ExpQ                = Q Exp
type TExpQ a             = Q (TExp a)
type DecQ                = Q Dec
type DecsQ               = Q [Dec]
type ConQ                = Q Con
type TypeQ               = Q Type
type KindQ               = Q Kind
type TyVarBndrQ          = Q TyVarBndr
type TyLitQ              = Q TyLit
type CxtQ                = Q Cxt
type PredQ               = Q Pred
type DerivClauseQ        = Q DerivClause
type MatchQ              = Q Match
type ClauseQ             = Q Clause
type BodyQ               = Q Body
type GuardQ              = Q Guard
type StmtQ               = Q Stmt
type RangeQ              = Q Range
type SourceStrictnessQ   = Q SourceStrictness
type SourceUnpackednessQ = Q SourceUnpackedness
type BangQ               = Q Bang
type BangTypeQ           = Q BangType
type VarBangTypeQ        = Q VarBangType
type StrictTypeQ         = Q StrictType
type VarStrictTypeQ      = Q VarStrictType
type FieldExpQ           = Q FieldExp
type RuleBndrQ           = Q RuleBndr
type TySynEqnQ           = Q TySynEqn
type PatSynDirQ          = Q PatSynDir
type PatSynArgsQ         = Q PatSynArgs
type FamilyResultSigQ    = Q FamilyResultSig
type DerivStrategyQ      = Q DerivStrategy

-- must be defined here for DsMeta to find it
type Role                = TH.Role
type InjectivityAnn      = TH.InjectivityAnn

----------------------------------------------------------
-- * Lowercase pattern syntax functions
----------------------------------------------------------

intPrimL    :: Integer -> Lit
intPrimL    = IntPrimL
wordPrimL    :: Integer -> Lit
wordPrimL    = WordPrimL
floatPrimL  :: Rational -> Lit
floatPrimL  = FloatPrimL
doublePrimL :: Rational -> Lit
doublePrimL = DoublePrimL
integerL    :: Integer -> Lit
integerL    = IntegerL
charL       :: Char -> Lit
charL       = CharL
charPrimL   :: Char -> Lit
charPrimL   = CharPrimL
stringL     :: String -> Lit
stringL     = StringL
stringPrimL :: [Word8] -> Lit
stringPrimL = StringPrimL
rationalL   :: Rational -> Lit
rationalL   = RationalL

litP :: Lit -> PatQ
litP l = return (LitP l)

varP :: Name -> PatQ
varP v = return (VarP v)

tupP :: [PatQ] -> PatQ
tupP ps = do { ps1 <- sequence ps; return (TupP ps1)}

unboxedTupP :: [PatQ] -> PatQ
unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)}

unboxedSumP :: PatQ -> SumAlt -> SumArity -> PatQ
unboxedSumP p alt arity = do { p1 <- p; return (UnboxedSumP p1 alt arity) }

conP :: Name -> [PatQ] -> PatQ
conP n ps = do ps' <- sequence ps
               return (ConP n ps')
infixP :: PatQ -> Name -> PatQ -> PatQ
infixP p1 n p2 = do p1' <- p1
                    p2' <- p2
                    return (InfixP p1' n p2')
uInfixP :: PatQ -> Name -> PatQ -> PatQ
uInfixP p1 n p2 = do p1' <- p1
                     p2' <- p2
                     return (UInfixP p1' n p2')
parensP :: PatQ -> PatQ
parensP p = do p' <- p
               return (ParensP p')

tildeP :: PatQ -> PatQ
tildeP p = do p' <- p
              return (TildeP p')
bangP :: PatQ -> PatQ
bangP p = do p' <- p
             return (BangP p')
asP :: Name -> PatQ -> PatQ
asP n p = do p' <- p
             return (AsP n p')
wildP :: PatQ
wildP = return WildP
recP :: Name -> [FieldPatQ] -> PatQ
recP n fps = do fps' <- sequence fps
                return (RecP n fps')
listP :: [PatQ] -> PatQ
listP ps = do ps' <- sequence ps
              return (ListP ps')
sigP :: PatQ -> TypeQ -> PatQ
sigP p t = do p' <- p
              t' <- t
              return (SigP p' t')
viewP :: ExpQ -> PatQ -> PatQ
viewP e p = do e' <- e
               p' <- p
               return (ViewP e' p')

fieldPat :: Name -> PatQ -> FieldPatQ
fieldPat n p = do p' <- p
                  return (n, p')

-------------------------------------------------------------------------------
-- *   Stmt

bindS :: PatQ -> ExpQ -> StmtQ
bindS p e = liftM2 BindS p e

letS :: [DecQ] -> StmtQ
letS ds = do { ds1 <- sequence ds; return (LetS ds1) }

noBindS :: ExpQ -> StmtQ
noBindS e = do { e1 <- e; return (NoBindS e1) }

parS :: [[StmtQ]] -> StmtQ
parS sss = do { sss1 <- mapM sequence sss; return (ParS sss1) }

recS :: [StmtQ] -> StmtQ
recS ss = do { ss1 <- sequence ss; return (RecS ss1) }

-------------------------------------------------------------------------------
-- *   Range

fromR :: ExpQ -> RangeQ
fromR x = do { a <- x; return (FromR a) }

fromThenR :: ExpQ -> ExpQ -> RangeQ
fromThenR x y = do { a <- x; b <- y; return (FromThenR a b) }

fromToR :: ExpQ -> ExpQ -> RangeQ
fromToR x y = do { a <- x; b <- y; return (FromToR a b) }

fromThenToR :: ExpQ -> ExpQ -> ExpQ -> RangeQ
fromThenToR x y z = do { a <- x; b <- y; c <- z;
                         return (FromThenToR a b c) }
-------------------------------------------------------------------------------
-- *   Body

normalB :: ExpQ -> BodyQ
normalB e = do { e1 <- e; return (NormalB e1) }

guardedB :: [Q (Guard,Exp)] -> BodyQ
guardedB ges = do { ges' <- sequence ges; return (GuardedB ges') }

-------------------------------------------------------------------------------
-- *   Guard

normalG :: ExpQ -> GuardQ
normalG e = do { e1 <- e; return (NormalG e1) }

normalGE :: ExpQ -> ExpQ -> Q (Guard, Exp)
normalGE g e = do { g1 <- g; e1 <- e; return (NormalG g1, e1) }

patG :: [StmtQ] -> GuardQ
patG ss = do { ss' <- sequence ss; return (PatG ss') }

patGE :: [StmtQ] -> ExpQ -> Q (Guard, Exp)
patGE ss e = do { ss' <- sequence ss;
                  e'  <- e;
                  return (PatG ss', e') }

-------------------------------------------------------------------------------
-- *   Match and Clause

-- | Use with 'caseE'
match :: PatQ -> BodyQ -> [DecQ] -> MatchQ
match p rhs ds = do { p' <- p;
                      r' <- rhs;
                      ds' <- sequence ds;
                      return (Match p' r' ds') }

-- | Use with 'funD'
clause :: [PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause ps r ds = do { ps' <- sequence ps;
                      r' <- r;
                      ds' <- sequence ds;
                      return (Clause ps' r' ds') }

---------------------------------------------------------------------------
-- *   Exp

-- | Dynamically binding a variable (unhygenic)
dyn :: String -> ExpQ
dyn s = return (VarE (mkName s))

varE :: Name -> ExpQ
varE s = return (VarE s)

conE :: Name -> ExpQ
conE s =  return (ConE s)

litE :: Lit -> ExpQ
litE c = return (LitE c)

appE :: ExpQ -> ExpQ -> ExpQ
appE x y = do { a <- x; b <- y; return (AppE a b)}

appTypeE :: ExpQ -> TypeQ -> ExpQ
appTypeE x t = do { a <- x; s <- t; return (AppTypeE a s) }

parensE :: ExpQ -> ExpQ
parensE x = do { x' <- x; return (ParensE x') }

uInfixE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
                     return (UInfixE x' s' y') }

infixE :: Maybe ExpQ -> ExpQ -> Maybe ExpQ -> ExpQ
infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
                                  return (InfixE (Just a) s' (Just b))}
infixE Nothing  s (Just y) = do { s' <- s; b <- y;
                                  return (InfixE Nothing s' (Just b))}
infixE (Just x) s Nothing  = do { a <- x; s' <- s;
                                  return (InfixE (Just a) s' Nothing)}
infixE Nothing  s Nothing  = do { s' <- s; return (InfixE Nothing s' Nothing) }

infixApp :: ExpQ -> ExpQ -> ExpQ -> ExpQ
infixApp x y z = infixE (Just x) y (Just z)
sectionL :: ExpQ -> ExpQ -> ExpQ
sectionL x y = infixE (Just x) y Nothing
sectionR :: ExpQ -> ExpQ -> ExpQ
sectionR x y = infixE Nothing x (Just y)

lamE :: [PatQ] -> ExpQ -> ExpQ
lamE ps e = do ps' <- sequence ps
               e' <- e
               return (LamE ps' e')

-- | Single-arg lambda
lam1E :: PatQ -> ExpQ -> ExpQ
lam1E p e = lamE [p] e

lamCaseE :: [MatchQ] -> ExpQ
lamCaseE ms = sequence ms >>= return . LamCaseE

tupE :: [ExpQ] -> ExpQ
tupE es = do { es1 <- sequence es; return (TupE es1)}

unboxedTupE :: [ExpQ] -> ExpQ
unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)}

unboxedSumE :: ExpQ -> SumAlt -> SumArity -> ExpQ
unboxedSumE e alt arity = do { e1 <- e; return (UnboxedSumE e1 alt arity) }

condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
condE x y z =  do { a <- x; b <- y; c <- z; return (CondE a b c)}

multiIfE :: [Q (Guard, Exp)] -> ExpQ
multiIfE alts = sequence alts >>= return . MultiIfE

letE :: [DecQ] -> ExpQ -> ExpQ
letE ds e = do { ds2 <- sequence ds; e2 <- e; return (LetE ds2 e2) }

caseE :: ExpQ -> [MatchQ] -> ExpQ
caseE e ms = do { e1 <- e; ms1 <- sequence ms; return (CaseE e1 ms1) }

doE :: [StmtQ] -> ExpQ
doE ss = do { ss1 <- sequence ss; return (DoE ss1) }

mdoE :: [StmtQ] -> ExpQ
mdoE ss = do { ss1 <- sequence ss; return (MDoE ss1) }

compE :: [StmtQ] -> ExpQ
compE ss = do { ss1 <- sequence ss; return (CompE ss1) }

arithSeqE :: RangeQ -> ExpQ
arithSeqE r = do { r' <- r; return (ArithSeqE r') }

listE :: [ExpQ] -> ExpQ
listE es = do { es1 <- sequence es; return (ListE es1) }

sigE :: ExpQ -> TypeQ -> ExpQ
sigE e t = do { e1 <- e; t1 <- t; return (SigE e1 t1) }

recConE :: Name -> [Q (Name,Exp)] -> ExpQ
recConE c fs = do { flds <- sequence fs; return (RecConE c flds) }

recUpdE :: ExpQ -> [Q (Name,Exp)] -> ExpQ
recUpdE e fs = do { e1 <- e; flds <- sequence fs; return (RecUpdE e1 flds) }

stringE :: String -> ExpQ
stringE = litE . stringL

fieldExp :: Name -> ExpQ -> Q (Name, Exp)
fieldExp s e = do { e' <- e; return (s,e') }

-- | @staticE x = [| static x |]@
staticE :: ExpQ -> ExpQ
staticE = fmap StaticE

unboundVarE :: Name -> ExpQ
unboundVarE s = return (UnboundVarE s)

labelE :: String -> ExpQ
labelE s = return (LabelE s)

implicitParamVarE :: String -> ExpQ
implicitParamVarE n = return (ImplicitParamVarE n)

-- ** 'arithSeqE' Shortcuts
fromE :: ExpQ -> ExpQ
fromE x = do { a <- x; return (ArithSeqE (FromR a)) }

fromThenE :: ExpQ -> ExpQ -> ExpQ
fromThenE x y = do { a <- x; b <- y; return (ArithSeqE (FromThenR a b)) }

fromToE :: ExpQ -> ExpQ -> ExpQ
fromToE x y = do { a <- x; b <- y; return (ArithSeqE (FromToR a b)) }

fromThenToE :: ExpQ -> ExpQ -> ExpQ -> ExpQ
fromThenToE x y z = do { a <- x; b <- y; c <- z;
                         return (ArithSeqE (FromThenToR a b c)) }

-------------------------------------------------------------------------------
-- *   Dec

valD :: PatQ -> BodyQ -> [DecQ] -> DecQ
valD p b ds =
  do { p' <- p
     ; ds' <- sequence ds
     ; b' <- b
     ; return (ValD p' b' ds')
     }

funD :: Name -> [ClauseQ] -> DecQ
funD nm cs =
 do { cs1 <- sequence cs
    ; return (FunD nm cs1)
    }

tySynD :: Name -> [TyVarBndrQ] -> TypeQ -> DecQ
tySynD tc tvs rhs =
  do { tvs1 <- sequenceA tvs
     ; rhs1 <- rhs
     ; return (TySynD tc tvs1 rhs1)
     }

dataD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> [ConQ]
      -> [DerivClauseQ] -> DecQ
dataD ctxt tc tvs ksig cons derivs =
  do
    ctxt1   <- ctxt
    tvs1    <- sequenceA tvs
    ksig1   <- sequenceA ksig
    cons1   <- sequence cons
    derivs1 <- sequence derivs
    return (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)

newtypeD :: CxtQ -> Name -> [TyVarBndrQ] -> Maybe KindQ -> ConQ
         -> [DerivClauseQ] -> DecQ
newtypeD ctxt tc tvs ksig con derivs =
  do
    ctxt1   <- ctxt
    tvs1    <- sequenceA tvs
    ksig1   <- sequenceA ksig
    con1    <- con
    derivs1 <- sequence derivs
    return (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)

classD :: CxtQ -> Name -> [TyVarBndrQ] -> [FunDep] -> [DecQ] -> DecQ
classD ctxt cls tvs fds decs =
  do
    tvs1  <- sequenceA tvs
    decs1 <- sequenceA decs
    ctxt1 <- ctxt
    return $ ClassD ctxt1 cls tvs1 fds decs1

instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceD = instanceWithOverlapD Nothing

instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ
instanceWithOverlapD o ctxt ty decs =
  do
    ctxt1 <- ctxt
    decs1 <- sequence decs
    ty1   <- ty
    return $ InstanceD o ctxt1 ty1 decs1

sigD :: Name -> TypeQ -> DecQ
sigD fun ty = liftM (SigD fun) $ ty

forImpD :: Callconv -> Safety -> String -> Name -> TypeQ -> DecQ
forImpD cc s str n ty
 = do ty' <- ty
      return $ ForeignD (ImportF cc s str n ty')

infixLD :: Int -> Name -> DecQ
infixLD prec nm = return (InfixD (Fixity prec InfixL) nm)

infixRD :: Int -> Name -> DecQ
infixRD prec nm = return (InfixD (Fixity prec InfixR) nm)

infixND :: Int -> Name -> DecQ
infixND prec nm = return (InfixD (Fixity prec InfixN) nm)

pragInlD :: Name -> Inline -> RuleMatch -> Phases -> DecQ
pragInlD name inline rm phases
  = return $ PragmaD $ InlineP name inline rm phases

pragSpecD :: Name -> TypeQ -> Phases -> DecQ
pragSpecD n ty phases
  = do
      ty1    <- ty
      return $ PragmaD $ SpecialiseP n ty1 Nothing phases

pragSpecInlD :: Name -> TypeQ -> Inline -> Phases -> DecQ
pragSpecInlD n ty inline phases
  = do
      ty1    <- ty
      return $ PragmaD $ SpecialiseP n ty1 (Just inline) phases

pragSpecInstD :: TypeQ -> DecQ
pragSpecInstD ty
  = do
      ty1    <- ty
      return $ PragmaD $ SpecialiseInstP ty1

pragRuleD :: String -> Maybe [TyVarBndrQ] -> [RuleBndrQ] -> ExpQ -> ExpQ
          -> Phases -> DecQ
pragRuleD n ty_bndrs tm_bndrs lhs rhs phases
  = do
      ty_bndrs1 <- traverse sequence ty_bndrs
      tm_bndrs1 <- sequence tm_bndrs
      lhs1   <- lhs
      rhs1   <- rhs
      return $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases

pragAnnD :: AnnTarget -> ExpQ -> DecQ
pragAnnD target expr
  = do
      exp1 <- expr
      return $ PragmaD $ AnnP target exp1

pragLineD :: Int -> String -> DecQ
pragLineD line file = return $ PragmaD $ LineP line file

pragCompleteD :: [Name] -> Maybe Name -> DecQ
pragCompleteD cls mty = return $ PragmaD $ CompleteP cls mty

dataInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> [ConQ]
          -> [DerivClauseQ] -> DecQ
dataInstD ctxt mb_bndrs ty ksig cons derivs =
  do
    ctxt1   <- ctxt
    mb_bndrs1 <- traverse sequence mb_bndrs
    ty1    <- ty
    ksig1   <- sequenceA ksig
    cons1   <- sequenceA cons
    derivs1 <- sequenceA derivs
    return (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)

newtypeInstD :: CxtQ -> (Maybe [TyVarBndrQ]) -> TypeQ -> Maybe KindQ -> ConQ
             -> [DerivClauseQ] -> DecQ
newtypeInstD ctxt mb_bndrs ty ksig con derivs =
  do
    ctxt1   <- ctxt
    mb_bndrs1 <- traverse sequence mb_bndrs
    ty1    <- ty
    ksig1   <- sequenceA ksig
    con1    <- con
    derivs1 <- sequence derivs
    return (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)

tySynInstD :: TySynEqnQ -> DecQ
tySynInstD eqn =
  do
    eqn1 <- eqn
    return (TySynInstD eqn1)

dataFamilyD :: Name -> [TyVarBndrQ] -> Maybe KindQ -> DecQ
dataFamilyD tc tvs kind =
  do tvs'  <- sequenceA tvs
     kind' <- sequenceA kind
     return $ DataFamilyD tc tvs' kind'

openTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
                -> Maybe InjectivityAnn -> DecQ
openTypeFamilyD tc tvs res inj =
  do tvs' <- sequenceA tvs
     res' <- res
     return $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)

closedTypeFamilyD :: Name -> [TyVarBndrQ] -> FamilyResultSigQ
                  -> Maybe InjectivityAnn -> [TySynEqnQ] -> DecQ
closedTypeFamilyD tc tvs result injectivity eqns =
  do tvs1    <- sequenceA tvs
     result1 <- result
     eqns1   <- sequenceA eqns
     return (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)

roleAnnotD :: Name -> [Role] -> DecQ
roleAnnotD name roles = return $ RoleAnnotD name roles

standaloneDerivD :: CxtQ -> TypeQ -> DecQ
standaloneDerivD = standaloneDerivWithStrategyD Nothing

standaloneDerivWithStrategyD :: Maybe DerivStrategyQ -> CxtQ -> TypeQ -> DecQ
standaloneDerivWithStrategyD mdsq ctxtq tyq =
  do
    mds  <- sequenceA mdsq
    ctxt <- ctxtq
    ty   <- tyq
    return $ StandaloneDerivD mds ctxt ty

defaultSigD :: Name -> TypeQ -> DecQ
defaultSigD n tyq =
  do
    ty <- tyq
    return $ DefaultSigD n ty

-- | Pattern synonym declaration
patSynD :: Name -> PatSynArgsQ -> PatSynDirQ -> PatQ -> DecQ
patSynD name args dir pat = do
  args'    <- args
  dir'     <- dir
  pat'     <- pat
  return (PatSynD name args' dir' pat')

-- | Pattern synonym type signature
patSynSigD :: Name -> TypeQ -> DecQ
patSynSigD nm ty =
  do ty' <- ty
     return $ PatSynSigD nm ty'

-- | Implicit parameter binding declaration. Can only be used in let
-- and where clauses which consist entirely of implicit bindings.
implicitParamBindD :: String -> ExpQ -> DecQ
implicitParamBindD n e =
  do
    e' <- e
    return $ ImplicitParamBindD n e'

tySynEqn :: (Maybe [TyVarBndrQ]) -> TypeQ -> TypeQ -> TySynEqnQ
tySynEqn mb_bndrs lhs rhs =
  do
    mb_bndrs1 <- traverse sequence mb_bndrs
    lhs1 <- lhs
    rhs1 <- rhs
    return (TySynEqn mb_bndrs1 lhs1 rhs1)

cxt :: [PredQ] -> CxtQ
cxt = sequence

derivClause :: Maybe DerivStrategyQ -> [PredQ] -> DerivClauseQ
derivClause mds p = do mds' <- sequenceA mds
                       p'   <- cxt p
                       return $ DerivClause mds' p'

stockStrategy :: DerivStrategyQ
stockStrategy = pure StockStrategy

anyclassStrategy :: DerivStrategyQ
anyclassStrategy = pure AnyclassStrategy

newtypeStrategy :: DerivStrategyQ
newtypeStrategy = pure NewtypeStrategy

viaStrategy :: TypeQ -> DerivStrategyQ
viaStrategy = fmap ViaStrategy

normalC :: Name -> [BangTypeQ] -> ConQ
normalC con strtys = liftM (NormalC con) $ sequence strtys

recC :: Name -> [VarBangTypeQ] -> ConQ
recC con varstrtys = liftM (RecC con) $ sequence varstrtys

infixC :: Q (Bang, Type) -> Name -> Q (Bang, Type) -> ConQ
infixC st1 con st2 = do st1' <- st1
                        st2' <- st2
                        return $ InfixC st1' con st2'

forallC :: [TyVarBndrQ] -> CxtQ -> ConQ -> ConQ
forallC ns ctxt con = do
  ns'   <- sequenceA ns
  ctxt' <- ctxt
  con'  <- con
  pure $ ForallC ns' ctxt' con'

gadtC :: [Name] -> [StrictTypeQ] -> TypeQ -> ConQ
gadtC cons strtys ty = liftM2 (GadtC cons) (sequence strtys) ty

recGadtC :: [Name] -> [VarStrictTypeQ] -> TypeQ -> ConQ
recGadtC cons varstrtys ty = liftM2 (RecGadtC cons) (sequence varstrtys) ty

-------------------------------------------------------------------------------
-- *   Type

forallT :: [TyVarBndrQ] -> CxtQ -> TypeQ -> TypeQ
forallT tvars ctxt ty = do
    tvars1 <- sequenceA tvars
    ctxt1  <- ctxt
    ty1    <- ty
    return $ ForallT tvars1 ctxt1 ty1

forallVisT :: [TyVarBndrQ] -> TypeQ -> TypeQ
forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty

varT :: Name -> TypeQ
varT = return . VarT

conT :: Name -> TypeQ
conT = return . ConT

infixT :: TypeQ -> Name -> TypeQ -> TypeQ
infixT t1 n t2 = do t1' <- t1
                    t2' <- t2
                    return (InfixT t1' n t2')

uInfixT :: TypeQ -> Name -> TypeQ -> TypeQ
uInfixT t1 n t2 = do t1' <- t1
                     t2' <- t2
                     return (UInfixT t1' n t2')

parensT :: TypeQ -> TypeQ
parensT t = do t' <- t
               return (ParensT t')

appT :: TypeQ -> TypeQ -> TypeQ
appT t1 t2 = do
           t1' <- t1
           t2' <- t2
           return $ AppT t1' t2'

appKindT :: TypeQ -> KindQ -> TypeQ
appKindT ty ki = do
               ty' <- ty
               ki' <- ki
               return $ AppKindT ty' ki'

arrowT :: TypeQ
arrowT = return ArrowT

listT :: TypeQ
listT = return ListT

litT :: TyLitQ -> TypeQ
litT l = fmap LitT l

tupleT :: Int -> TypeQ
tupleT i = return (TupleT i)

unboxedTupleT :: Int -> TypeQ
unboxedTupleT i = return (UnboxedTupleT i)

unboxedSumT :: SumArity -> TypeQ
unboxedSumT arity = return (UnboxedSumT arity)

sigT :: TypeQ -> KindQ -> TypeQ
sigT t k
  = do
      t' <- t
      k' <- k
      return $ SigT t' k'

equalityT :: TypeQ
equalityT = return EqualityT

wildCardT :: TypeQ
wildCardT = return WildCardT

implicitParamT :: String -> TypeQ -> TypeQ
implicitParamT n t
  = do
      t' <- t
      return $ ImplicitParamT n t'

{-# DEPRECATED classP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please use 'conT' and 'appT'." #-}
classP :: Name -> [Q Type] -> Q Pred
classP cla tys
  = do
      tysl <- sequence tys
      return (foldl AppT (ConT cla) tysl)

{-# DEPRECATED equalP "As of template-haskell-2.10, constraint predicates (Pred) are just types (Type), in keeping with ConstraintKinds. Please see 'equalityT'." #-}
equalP :: TypeQ -> TypeQ -> PredQ
equalP tleft tright
  = do
      tleft1  <- tleft
      tright1 <- tright
      eqT <- equalityT
      return (foldl AppT eqT [tleft1, tright1])

promotedT :: Name -> TypeQ
promotedT = return . PromotedT

promotedTupleT :: Int -> TypeQ
promotedTupleT i = return (PromotedTupleT i)

promotedNilT :: TypeQ
promotedNilT = return PromotedNilT

promotedConsT :: TypeQ
promotedConsT = return PromotedConsT

noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: SourceUnpackednessQ
noSourceUnpackedness = return NoSourceUnpackedness
sourceNoUnpack       = return SourceNoUnpack
sourceUnpack         = return SourceUnpack

noSourceStrictness, sourceLazy, sourceStrict :: SourceStrictnessQ
noSourceStrictness = return NoSourceStrictness
sourceLazy         = return SourceLazy
sourceStrict       = return SourceStrict

{-# DEPRECATED isStrict
    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
     "Example usage: 'bang noSourceUnpackedness sourceStrict'"] #-}
{-# DEPRECATED notStrict
    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
     "Example usage: 'bang noSourceUnpackedness noSourceStrictness'"] #-}
{-# DEPRECATED unpacked
    ["Use 'bang'. See https://ghc.haskell.org/trac/ghc/wiki/Migration/8.0. ",
     "Example usage: 'bang sourceUnpack sourceStrict'"] #-}
isStrict, notStrict, unpacked :: Q Strict
isStrict = bang noSourceUnpackedness sourceStrict
notStrict = bang noSourceUnpackedness noSourceStrictness
unpacked = bang sourceUnpack sourceStrict

bang :: SourceUnpackednessQ -> SourceStrictnessQ -> BangQ
bang u s = do u' <- u
              s' <- s
              return (Bang u' s')

bangType :: BangQ -> TypeQ -> BangTypeQ
bangType = liftM2 (,)

varBangType :: Name -> BangTypeQ -> VarBangTypeQ
varBangType v bt = do (b, t) <- bt
                      return (v, b, t)

{-# DEPRECATED strictType
               "As of @template-haskell-2.11.0.0@, 'StrictType' has been replaced by 'BangType'. Please use 'bangType' instead." #-}
strictType :: Q Strict -> TypeQ -> StrictTypeQ
strictType = bangType

{-# DEPRECATED varStrictType
               "As of @template-haskell-2.11.0.0@, 'VarStrictType' has been replaced by 'VarBangType'. Please use 'varBangType' instead." #-}
varStrictType :: Name -> StrictTypeQ -> VarStrictTypeQ
varStrictType = varBangType

-- * Type Literals

numTyLit :: Integer -> TyLitQ
numTyLit n = if n >= 0 then return (NumTyLit n)
                       else fail ("Negative type-level number: " ++ show n)

strTyLit :: String -> TyLitQ
strTyLit s = return (StrTyLit s)

-------------------------------------------------------------------------------
-- *   Kind

plainTV :: Name -> TyVarBndrQ
plainTV = pure . PlainTV

kindedTV :: Name -> KindQ -> TyVarBndrQ
kindedTV n = fmap (KindedTV n)

varK :: Name -> Kind
varK = VarT

conK :: Name -> Kind
conK = ConT

tupleK :: Int -> Kind
tupleK = TupleT

arrowK :: Kind
arrowK = ArrowT

listK :: Kind
listK = ListT

appK :: Kind -> Kind -> Kind
appK = AppT

starK :: KindQ
starK = pure StarT

constraintK :: KindQ
constraintK = pure ConstraintT

-------------------------------------------------------------------------------
-- *   Type family result

noSig :: FamilyResultSigQ
noSig = pure NoSig

kindSig :: KindQ -> FamilyResultSigQ
kindSig = fmap KindSig

tyVarSig :: TyVarBndrQ -> FamilyResultSigQ
tyVarSig = fmap TyVarSig

-------------------------------------------------------------------------------
-- *   Injectivity annotation

injectivityAnn :: Name -> [Name] -> InjectivityAnn
injectivityAnn = TH.InjectivityAnn

-------------------------------------------------------------------------------
-- *   Role

nominalR, representationalR, phantomR, inferR :: Role
nominalR          = NominalR
representationalR = RepresentationalR
phantomR          = PhantomR
inferR            = InferR

-------------------------------------------------------------------------------
-- *   Callconv

cCall, stdCall, cApi, prim, javaScript :: Callconv
cCall      = CCall
stdCall    = StdCall
cApi       = CApi
prim       = Prim
javaScript = JavaScript

-------------------------------------------------------------------------------
-- *   Safety

unsafe, safe, interruptible :: Safety
unsafe = Unsafe
safe = Safe
interruptible = Interruptible

-------------------------------------------------------------------------------
-- *   FunDep

funDep :: [Name] -> [Name] -> FunDep
funDep = FunDep

-------------------------------------------------------------------------------
-- *   RuleBndr
ruleVar :: Name -> RuleBndrQ
ruleVar = return . RuleVar

typedRuleVar :: Name -> TypeQ -> RuleBndrQ
typedRuleVar n ty = ty >>= return . TypedRuleVar n

-------------------------------------------------------------------------------
-- *   AnnTarget
valueAnnotation :: Name -> AnnTarget
valueAnnotation = ValueAnnotation

typeAnnotation :: Name -> AnnTarget
typeAnnotation = TypeAnnotation

moduleAnnotation :: AnnTarget
moduleAnnotation = ModuleAnnotation

-------------------------------------------------------------------------------
-- * Pattern Synonyms (sub constructs)

unidir, implBidir :: PatSynDirQ
unidir    = return Unidir
implBidir = return ImplBidir

explBidir :: [ClauseQ] -> PatSynDirQ
explBidir cls = do
  cls' <- sequence cls
  return (ExplBidir cls')

prefixPatSyn :: [Name] -> PatSynArgsQ
prefixPatSyn args = return $ PrefixPatSyn args

recordPatSyn :: [Name] -> PatSynArgsQ
recordPatSyn sels = return $ RecordPatSyn sels

infixPatSyn :: Name -> Name -> PatSynArgsQ
infixPatSyn arg1 arg2 = return $ InfixPatSyn arg1 arg2

--------------------------------------------------------------
-- * Useful helper function

appsE :: [ExpQ] -> ExpQ
appsE [] = error "appsE []"
appsE [x] = x
appsE (x:y:zs) = appsE ( (appE x y) : zs )

-- | Return the Module at the place of splicing.  Can be used as an
-- input for 'reifyModule'.
thisModule :: Q Module
thisModule = do
  loc <- location
  return $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)


{-# LANGUAGE BangPatterns #-}

-- This is a non-exposed internal module
--
-- The code in this module has been ripped from containers-0.5.5.1:Data.Map.Base [1] almost
-- verbatimely to avoid a dependency of 'template-haskell' on the containers package.
--
-- [1] see https://hackage.haskell.org/package/containers-0.5.5.1
--
-- The original code is BSD-licensed and copyrighted by Daan Leijen, Andriy Palamarchuk, et al.

module Language.Haskell.TH.Lib.Map
    ( Map
    , empty
    , insert
    , Language.Haskell.TH.Lib.Map.lookup
    ) where

import Prelude

data Map k a  = Bin {-# UNPACK #-} !Size !k a !(Map k a) !(Map k a)
              | Tip

type Size     = Int

empty :: Map k a
empty = Tip
{-# INLINE empty #-}

singleton :: k -> a -> Map k a
singleton k x = Bin 1 k x Tip Tip
{-# INLINE singleton #-}

size :: Map k a -> Int
size Tip              = 0
size (Bin sz _ _ _ _) = sz
{-# INLINE size #-}

lookup :: Ord k => k -> Map k a -> Maybe a
lookup = go
  where
    go _ Tip = Nothing
    go !k (Bin _ kx x l r) = case compare k kx of
      LT -> go k l
      GT -> go k r
      EQ -> Just x
{-# INLINABLE lookup #-}

insert :: Ord k => k -> a -> Map k a -> Map k a
insert = go
  where
    go :: Ord k => k -> a -> Map k a -> Map k a
    go !kx x Tip = singleton kx x
    go !kx x (Bin sz ky y l r) =
        case compare kx ky of
            LT -> balanceL ky y (go kx x l) r
            GT -> balanceR ky y l (go kx x r)
            EQ -> Bin sz kx x l r
{-# INLINABLE insert #-}

balanceL :: k -> a -> Map k a -> Map k a -> Map k a
balanceL k x l r = case r of
  Tip -> case l of
           Tip -> Bin 1 k x Tip Tip
           (Bin _ _ _ Tip Tip) -> Bin 2 k x l Tip
           (Bin _ lk lx Tip (Bin _ lrk lrx _ _)) -> Bin 3 lrk lrx (Bin 1 lk lx Tip Tip) (Bin 1 k x Tip Tip)
           (Bin _ lk lx ll@(Bin _ _ _ _ _) Tip) -> Bin 3 lk lx ll (Bin 1 k x Tip Tip)
           (Bin ls lk lx ll@(Bin lls _ _ _ _) lr@(Bin lrs lrk lrx lrl lrr))
             | lrs < ratio*lls -> Bin (1+ls) lk lx ll (Bin (1+lrs) k x lr Tip)
             | otherwise -> Bin (1+ls) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+size lrr) k x lrr Tip)

  (Bin rs _ _ _ _) -> case l of
           Tip -> Bin (1+rs) k x Tip r

           (Bin ls lk lx ll lr)
              | ls > delta*rs  -> case (ll, lr) of
                   (Bin lls _ _ _ _, Bin lrs lrk lrx lrl lrr)
                     | lrs < ratio*lls -> Bin (1+ls+rs) lk lx ll (Bin (1+rs+lrs) k x lr r)
                     | otherwise -> Bin (1+ls+rs) lrk lrx (Bin (1+lls+size lrl) lk lx ll lrl) (Bin (1+rs+size lrr) k x lrr r)
                   (_, _) -> error "Failure in Data.Map.balanceL"
              | otherwise -> Bin (1+ls+rs) k x l r
{-# NOINLINE balanceL #-}

balanceR :: k -> a -> Map k a -> Map k a -> Map k a
balanceR k x l r = case l of
  Tip -> case r of
           Tip -> Bin 1 k x Tip Tip
           (Bin _ _ _ Tip Tip) -> Bin 2 k x Tip r
           (Bin _ rk rx Tip rr@(Bin _ _ _ _ _)) -> Bin 3 rk rx (Bin 1 k x Tip Tip) rr
           (Bin _ rk rx (Bin _ rlk rlx _ _) Tip) -> Bin 3 rlk rlx (Bin 1 k x Tip Tip) (Bin 1 rk rx Tip Tip)
           (Bin rs rk rx rl@(Bin rls rlk rlx rll rlr) rr@(Bin rrs _ _ _ _))
             | rls < ratio*rrs -> Bin (1+rs) rk rx (Bin (1+rls) k x Tip rl) rr
             | otherwise -> Bin (1+rs) rlk rlx (Bin (1+size rll) k x Tip rll) (Bin (1+rrs+size rlr) rk rx rlr rr)

  (Bin ls _ _ _ _) -> case r of
           Tip -> Bin (1+ls) k x l Tip

           (Bin rs rk rx rl rr)
              | rs > delta*ls  -> case (rl, rr) of
                   (Bin rls rlk rlx rll rlr, Bin rrs _ _ _ _)
                     | rls < ratio*rrs -> Bin (1+ls+rs) rk rx (Bin (1+ls+rls) k x l rl) rr
                     | otherwise -> Bin (1+ls+rs) rlk rlx (Bin (1+ls+size rll) k x l rll) (Bin (1+rrs+size rlr) rk rx rlr rr)
                   (_, _) -> error "Failure in Data.Map.balanceR"
              | otherwise -> Bin (1+ls+rs) k x l r
{-# NOINLINE balanceR #-}

delta,ratio :: Int
delta = 3
ratio = 2


{-# LANGUAGE TemplateHaskell #-}

module Foo where

import Language.Haskell.TH
import Language.Haskell.TH.Quote
import System.IO

$( do u1 <- runQ (dataToExpQ (const Nothing) ())
      u2 <- runQ [| () |]
      runIO $ print (u1 == u2)
      runIO $ hFlush stdout
      return []
 )


import System.Environment
import System.Process
import Data.Maybe

main = do
  [ghc] <- getArgs

  info <- readProcess ghc ["+RTS", "--info"] ""
  let fields = read info :: [(String,String)]
  getGhcFieldOrFail fields "HostOS" "Host OS"
  getGhcFieldOrFail fields "WORDSIZE" "Word size"
  getGhcFieldOrFail fields "TARGETPLATFORM" "Target platform"
  getGhcFieldOrFail fields "TargetOS_CPP" "Target OS"
  getGhcFieldOrFail fields "TargetARCH_CPP" "Target architecture"

  info <- readProcess ghc ["--info"] ""
  let fields = read info :: [(String,String)]

  getGhcFieldOrFail fields "GhcStage" "Stage"
  getGhcFieldOrFail fields "GhcDebugged" "Debug on"
  getGhcFieldOrFail fields "GhcWithNativeCodeGen" "Have native code generator"
  getGhcFieldOrFail fields "GhcWithInterpreter" "Have interpreter"
  getGhcFieldOrFail fields "GhcUnregisterised" "Unregisterised"
  getGhcFieldOrFail fields "GhcWithSMP" "Support SMP"
  getGhcFieldOrFail fields "GhcRTSWays" "RTS ways"
  getGhcFieldOrDefault fields "GhcDynamicByDefault" "Dynamic by default" "NO"
  getGhcFieldOrDefault fields "GhcDynamic" "GHC Dynamic" "NO"
  getGhcFieldOrDefault fields "GhcProfiled" "GHC Profiled" "NO"
  getGhcFieldProgWithDefault fields "AR" "ar command" "ar"
  getGhcFieldProgWithDefault fields "CLANG" "LLVM clang command" "clang"
  getGhcFieldProgWithDefault fields "LLC" "LLVM llc command" "llc"
  getGhcFieldProgWithDefault fields "TEST_CC" "C compiler command" "gcc"

  let pkgdb_flag = case lookup "Project version" fields of
        Just v
          | parseVersion v >= [7,5] -> "package-db"
        _ -> "package-conf"
  putStrLn $ "GhcPackageDbFlag" ++ '=':pkgdb_flag

  let minGhcVersion711 = case lookup "Project version" fields of
        Just v
          | parseVersion v >= [7,11] -> "YES"
        _ -> "NO"
  putStrLn $ "MinGhcVersion711" ++ '=':minGhcVersion711

  let minGhcVersion801 = case lookup "Project version" fields of
        Just v
          | parseVersion v >= [8,1] -> "YES"
        _ -> "NO"
  putStrLn $ "MinGhcVersion801" ++ '=':minGhcVersion801

getGhcFieldOrFail :: [(String,String)] -> String -> String -> IO ()
getGhcFieldOrFail fields mkvar key
   = getGhcField fields mkvar key id (fail ("No field: " ++ key))

getGhcFieldOrDefault :: [(String,String)] -> String -> String -> String -> IO ()
getGhcFieldOrDefault fields mkvar key deflt
  = getGhcField fields mkvar key id on_fail
  where
    on_fail = putStrLn (mkvar ++ '=' : deflt)

getGhcFieldProgWithDefault
   :: [(String,String)]
   -> String -> String -> String
   -> IO ()
getGhcFieldProgWithDefault fields mkvar key deflt
  = getGhcField fields mkvar key fix on_fail
  where
    fix val = fixSlashes (fixTopdir topdir val)
    topdir = fromMaybe "" (lookup "LibDir" fields)
    on_fail = putStrLn (mkvar ++ '=' : deflt)

getGhcField
   :: [(String,String)] -> String -> String
   -> (String -> String)
   -> IO ()
   -> IO ()
getGhcField fields mkvar key fix on_fail =
   case lookup key fields of
      Nothing  -> on_fail
      Just val -> putStrLn (mkvar ++ '=' : fix val)

fixTopdir :: String -> String -> String
fixTopdir t "" = ""
fixTopdir t ('$':'t':'o':'p':'d':'i':'r':s) = t ++ s
fixTopdir t (c:s) = c : fixTopdir t s

fixSlashes :: FilePath -> FilePath
fixSlashes = map f
    where f '\\' = '/'
          f c    = c

parseVersion :: String -> [Int]
parseVersion v = case break (== '.') v of
  (n, rest) -> read n : case rest of
    [] -> []
    ('.':v') -> parseVersion v'
    _ -> error "bug in parseVersion"


{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-}
{-# OPTIONS_GHC -foptimal-applicative-do #-}
module Main where

import Control.Applicative
import Text.PrettyPrint as PP

(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]

-- This one requires -foptimal-applicative-do to find the best solution
-- ((a; b) | (c; d)); e
test1 :: M ()
test1 = do
  x1 <- a
  x2 <- const b x1
  x3 <- c
  x4 <- const d x3
  x5 <- const e (x1,x4)
  return (const () x5)

-- (a | c); (b | d); e
test2 :: M ()
test2 = do
  x1 <- a
  x3 <- c
  x2 <- const b x1
  x4 <- const d x3
  x5 <- const e (x1,x4)
  return (const () x5)

main = mapM_ run
 [ test1
 , test2
 ]

-- Testing code, prints out the structure of a monad/applicative expression

newtype M a = M (Bool -> (Maybe Doc, a))

maybeParen True d = parens d
maybeParen _ d = d

run :: M a -> IO ()
run (M m) = print d where (Just d,_) = m False

instance Functor M where
  fmap f m = m >>= return . f

instance Applicative M where
  pure a = M $ \_ -> (Nothing, a)
  M f <*> M a = M $ \p ->
    let (Just d1, f') = f True
        (Just d2, a') = a True
    in
        (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')

instance Monad M where
  return = pure
  M m >>= k = M $ \p ->
    let (d1, a) = m True
        (d2, b) = case k a of M f -> f True
    in
    case (d1,d2) of
      (Nothing,Nothing) -> (Nothing, b)
      (Just d, Nothing) -> (Just d, b)
      (Nothing, Just d) -> (Just d, b)
      (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b)

doc :: String -> M ()
doc d = M $ \_ -> (Just (text d), ())


{-# LANGUAGE ScopedTypeVariables, ExistentialQuantification, ApplicativeDo #-}
module Main where

import Control.Applicative
import Text.PrettyPrint as PP

(a:b:c:d:e:f:g:h:_) = map (\c -> doc [c]) ['a'..]

-- a | b
test1 :: M ()
test1 = do
  x1 <- a
  x2 <- b
  const (return ()) (x1,x2)

-- no parallelism
test2 :: M ()
test2 = do
  x1 <- a
  x2 <- const g x1
  const (return ()) (x1,x2)

-- a | (b;g) | e
test3 :: M ()
test3 = do
  x1 <- a
  x2 <- b
  x3 <- const g x2
  x4 <- e
  return () `const` (x1,x2,x3,x4)

-- (a ; (b | g)) | c
-- or
-- ((a | b); g) | c
test4 :: M ()
test4 = do
  x1 <- a
  x2 <- b
  x3 <- const g x1
  x4 <- c
  return () `const` (x2,x3,x4)

-- (a | b | c); (g | h)
test5 :: M ()
test5 = do
  x1 <- a
  x2 <- b
  x3 <- c
  x4 <- const g x1
  x5 <- const h x3
  return () `const` (x3,x4,x5)

-- b/c in parallel, e/f in parallel
-- a; (b | (c; (d; (e | (f; g)))))
test6 :: M ()
test6 = do
  x1 <- a
  x2 <- const b x1
  x3 <- const c x1
  x4 <- const d x3
  x5 <- const e x4
  x6 <- const f x4
  x7 <- const g x6
  return () `const` (x1,x2,x3,x4,x5,x6,x7)

-- (a | b); (c | d)
test7 :: M ()
test7 = do
  x1 <- a
  x2 <- b
  x3 <- const c x1
  x4 <- const d x2
  return () `const` (x3,x4)

-- a; (b | c | d)
--
-- alternative (but less good):
-- ((a;b) | c); d
test8 :: M ()
test8 = do
  x1 <- a
  x2 <- const b x1
  x3 <- c
  x4 <- const d x1
  return () `const` (x2,x3,x4)

-- test that Lets don't get in the way
-- ((a | (b; c)) | d) | e
test9 :: M ()
test9 = do
  x1 <- a
  let x = doc "x"  -- this shouldn't get in the way of grouping a/b
  x2 <- b
  x3 <- const c x2
  x4 <- d
  x5 <- e
  let y = doc "y"
  return ()

-- ((a | b) ; (c | d)) | e
test10 :: M ()
test10 = do
  x1 <- a
  x2 <- b
  let z1 = (x1,x2)
  x3 <- const c x1
  let z2 = (x1,x2)
  x4 <- const d z1
  x5 <- e
  return (const () (x3,x4,x5))

-- (a | b)
-- This demonstrated a bug in RnExpr.segments (#11612)
test11 :: M ()
test11 = do
  x1 <- a
  let x2 = x1
  x3 <- b
  let x4 = c
      x5 = x4
  return (const () (x1,x2,x3,x4))

-- (a | (b ; c))
-- The strict pattern match forces (b;c), but a can still be parallel (#13875)
test12 :: M ()
test12 = do
  x1 <- a
  () <- b
  x2 <- c
  return (const () (x1,x2))

main = mapM_ run
 [ test1
 , test2
 , test3
 , test4
 , test5
 , test6
 , test7
 , test8
 , test9
 , test10
 , test11
 , test12
 ]

-- Testing code, prints out the structure of a monad/applicative expression

newtype M a = M (Bool -> (Maybe Doc, a))

maybeParen True d = parens d
maybeParen _ d = d

run :: M a -> IO ()
run (M m) = print d where (Just d,_) = m False

instance Functor M where
  fmap f m = m >>= return . f

instance Applicative M where
  pure a = M $ \_ -> (Nothing, a)
  M f <*> M a = M $ \p ->
    let (Just d1, f') = f True
        (Just d2, a') = a True
    in
        (Just (maybeParen p (d1 <+> char '|' <+> d2)), f' a')

instance Monad M where
  return = pure
  M m >>= k = M $ \p ->
    let (d1, a) = m True
        (d2, b) = case k a of M f -> f True
    in
    case (d1,d2) of
      (Nothing,Nothing) -> (Nothing, b)
      (Just d, Nothing) -> (Just d, b)
      (Nothing, Just d) -> (Just d, b)
      (Just d1, Just d2) -> (Just (maybeParen p (d1 PP.<> semi <+> d2)), b)

doc :: String -> M ()
doc d = M $ \_ -> (Just (text d), ())


{-# LANGUAGE ApplicativeDo,ScopedTypeVariables #-}
module Test where

-- Test that type errors aren't affected by ApplicativeDo
f :: IO Int
f = do
  x <- getChar
  y <- getChar 'a' -- type error
  print (x,y)

g :: IO (Int,Int)
g = do
  x <- getChar
  y <- getChar
  return (y,x)

h :: IO (Int,Int)
h = do
  x1 <- getChar
  x2 <- getChar
  x3 <- const (return ()) x1
  x4 <- getChar
  x5 <- getChar x4
  return (x2,x4)


{-# LANGUAGE ApplicativeDo #-}
module ShouldFail where

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


{-# LANGUAGE ApplicativeDo #-}
{-# OPTIONS_GHC -ddump-types #-}
module Test where

-- This is a do expression that typechecks with only an Applicative constraint
test1 :: Applicative f => (Int -> f Int) -> f Int
test1 f = do
  x <- f 3
  y <- f 4
  return (x + y)

-- The same using $
test1a :: Applicative f => (Int -> f Int) -> f Int
test1a f = do
  x <- f 3
  y <- f 4
  return $ x + y

-- When one of the statements is a BodyStmt
test1b :: Applicative f => (Int -> f Int) -> f Int
test1b f = do
  x <- f 3
  f 4
  return x

test1c :: Applicative f => (Int -> f Int) -> f Int
test1c f = do
  f 3
  x <- f 4
  return x

-- Test we can also infer the Applicative version of the type
test2 f = do
  x <- f 3
  y <- f 4
  return (x + y)

-- Test we can also infer the Functor version of the type
test2a f = do
  x <- f 3
  return (x + 1)

-- The same using $
test2c f = do
  x <- f 3
  return $ x + 1

-- with a BodyStmt
test2d f = do
  f 3
  return 4

-- Test for just one statement
test2b f = do
  return (f 3)

-- This one will use join
test3 f g = do
  x <- f 3
  y <- f 4
  g y x

-- This one needs a tuple
test4 f g = do
  x <- f 3
  y <- f 4
  let r = g y x
  r

-- This one used to need a big tuple, now it compiles to ApplicativeLastStmt
test5 f g = do
  x01 <- f 01
  x02 <- f 02
  x03 <- f 03
  x04 <- f 04
  x05 <- f 05
  x06 <- f 06
  x07 <- f 07
  x08 <- f 08
  x09 <- f 09
  x11 <- f 11
  x12 <- f 12
  x13 <- f 13
  x14 <- f 14
  x15 <- f 15
  x16 <- f 16
  x17 <- f 17
  x18 <- f 18
  x19 <- f 19
  x20 <- f 20
  x21 <- f 21
  x22 <- f 22
  x23 <- f 23
  x24 <- f 24
  x25 <- f 25
  x26 <- f 26
  x27 <- f 27
  x28 <- f 28
  x29 <- f 29
  x30 <- f 30
  x31 <- f 31
  x32 <- f 32
  x33 <- f 33
  x34 <- f 34
  x35 <- f 35
  x36 <- f 36
  x37 <- f 37
  x38 <- f 38
  x39 <- f 39
  x40 <- f 40
  x41 <- f 41
  x42 <- f 42
  x43 <- f 43
  x44 <- f 44
  x45 <- f 45
  x46 <- f 46
  x47 <- f 47
  x48 <- f 48
  x49 <- f 49
  x50 <- f 50
  x51 <- f 51
  x52 <- f 52
  x53 <- f 53
  x54 <- f 54
  x55 <- f 55
  x56 <- f 56
  x57 <- f 57
  x58 <- f 58
  x59 <- f 59
  x60 <- f 60
  x61 <- f 61
  x62 <- f 62
  x63 <- f 63
  x64 <- f 64
  x65 <- f 65
  x66 <- f 66
  x67 <- f 67
  x68 <- f 68
  x69 <- f 69
  x70 <- f 70
  let r = g x70 x01
  r

-- This one needs a big tuple
test6 f g = do
  x01 <- f 01
  x02 <- f 02
  x03 <- f 03
  x04 <- f 04
  x05 <- f 05
  x06 <- f 06
  x07 <- f 07
  x08 <- f 08
  x09 <- f 09
  x11 <- f 11
  x12 <- f 12
  x13 <- f 13
  x14 <- f 14
  x15 <- f 15
  x16 <- f 16
  x17 <- f 17
  x18 <- f 18
  x19 <- f 19
  x20 <- f 20
  x21 <- f 21
  x22 <- f 22
  x23 <- f 23
  x24 <- f 24
  x25 <- f 25
  x26 <- f 26
  x27 <- f 27
  x28 <- f 28
  x29 <- f 29
  x30 <- f 30
  x31 <- f 31
  x32 <- f 32
  x33 <- f 33
  x34 <- f 34
  x35 <- f 35
  x36 <- f 36
  x37 <- f 37
  x38 <- f 38
  x39 <- f 39
  x40 <- f 40
  x41 <- f 41
  x42 <- f 42
  x43 <- f 43
  x44 <- f 44
  x45 <- f 45
  x46 <- f 46
  x47 <- f 47
  x48 <- f 48
  x49 <- f 49
  x50 <- f 50
  x51 <- f 51
  x52 <- f 52
  x53 <- f 53
  x54 <- f 54
  x55 <- f 55
  x56 <- f 56
  x57 <- f 57
  x58 <- f 58
  x59 <- f 59
  x60 <- f 60
  x61 <- f 61
  x62 <- f 62
  x63 <- f 63
  x64 <- f 64
  x65 <- f 65
  x66 <- f 66
  x67 <- f 67
  x68 <- f 68
  x69 <- f 69
  x70 <- f x01
  x71 <- f 70
  x71 `const`
   [ x01
   , x02
   , x03
   , x04
   , x05
   , x06
   , x07
   , x08
   , x09
   , x11
   , x12
   , x13
   , x14
   , x15
   , x16
   , x17
   , x18
   , x19
   , x20
   , x21
   , x22
   , x23
   , x24
   , x25
   , x26
   , x27
   , x28
   , x29
   , x30
   , x31
   , x32
   , x33
   , x34
   , x35
   , x36
   , x37
   , x38
   , x39
   , x40
   , x41
   , x42
   , x43
   , x44
   , x45
   , x46
   , x47
   , x48
   , x49
   , x50
   , x51
   , x52
   , x53
   , x54
   , x55
   , x56
   , x57
   , x58
   , x59
   , x60
   , x61
   , x62
   , x63
   , x64
   , x65
   , x66
   , x67
   , x68
   , x69
   , x70
   , x71 ]


{-# LANGUAGE ApplicativeDo #-}
{-# OPTIONS_GHC -ddump-types #-}
module Test where

-- This should fail to typecheck because it needs Monad
test :: Applicative f => (Int -> f Int) -> f Int
test f = do
  x <- f 3
  y <- f x
  return (x + y)


{-# LANGUAGE ApplicativeDo #-}
module Test where

-- This exposed a bug in zonking ApplicativeLastStmt
test :: IO Int
test
  = do
      x <- return ()
      h <- return (\_ -> 3)
      return (h ())


{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE RebindableSyntax #-}
module Test where

import Control.Applicative
import Control.Monad
import Prelude

-- Caused a -dcore-lint failure with an earlier version of
-- ApplicativeDo due to the polymorphic let binding.
test :: IO [Char]
test = do
  x <- return 'a'
  y <- return 'b'
  let f | y == 'c' = id | otherwise = id
  return (map f [])


{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

newtype MaybeA a = MaybeA (Maybe a)
                 deriving (Show, Functor, Applicative)

main :: IO ()
main = print $ do
    x <- MaybeA $ Just 42
    pure x


{-# LANGUAGE RebindableSyntax #-}
{-# LANGUAGE ApplicativeDo #-}

module T12490 where

import Prelude (Int, String, Functor(..), ($), undefined, (+))

join :: Monad f => f (f a) -> f a
join = undefined

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

class Applicative f => Monad f where
    return :: a -> f a
    (>>=) :: f a -> (a -> f b) -> f b
    fail :: String -> f a

f_app :: Applicative f => f Int -> f Int -> f Int
f_app a b = do
    a' <- a
    b' <- b
    pure (a' + b')

f_monad :: Monad f => f Int -> f Int -> f Int
f_monad a b = do
    a' <- a
    b' <- b
    return $ a' + b'


{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
module T13242 where

import Data.STRef
import Control.Monad.ST

data A = forall a. A a

st :: ST s ()
st = do
      A _ <- pure $ A True
      ref <- newSTRef 1
      readSTRef ref
      pure ()


{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
module T13242a where

data T where A :: forall a . Eq a => a -> T

test :: IO Bool
test = do
  A x <- undefined
  _ <- return 'a'
  _ <- return 'b'
  return (x == x)


{-# LANGUAGE ApplicativeDo #-}
module Main where

import Control.Exception
import Control.Monad
import Data.Maybe
import System.Exit

test0 :: Maybe ()
test0 = do
  () <- Just undefined
  () <- Just undefined
  return ()

test1 :: Maybe ()
test1 = do
  (_,_) <- Just undefined
  return ()

test2 :: Maybe (Int,Int)
test2 = do
  x <- return 1
  () <- Just undefined
  y <- return 2
  return (x,y)

main = do
  b <- (print (isJust test0) >> return True)
   `catch` \ErrorCall{} -> return False
  when b $ die "failed0"
  b <- (print (isJust test1) >> return True)
   `catch` \ErrorCall{} -> return False
  when b $ die "failed1"
  b <- (print (isJust test2) >> return True)
   `catch` \ErrorCall{} -> return False
  when b $ die "failed2"


{-# language ApplicativeDo #-}

import GHC.Exts

readIt :: IO (Int, Int)
readIt = readLn

main :: IO ()
main = do
  (_, _) <- readIt
  (_, _) <- readIt
  (_, _) <- readIt
  print "Done"


{-# LANGUAGE TemplateHaskell #-}

module Ann01 where

{-# ANN module (1 :: Int) #-}
{-# ANN module (1 :: Integer) #-}
{-# ANN module (1 :: Double) #-}
{-# ANN module $([| 1 :: Int |]) #-}
{-# ANN module "Hello" #-}
{-# ANN module (Just (1 :: Int)) #-}
{-# ANN module [1 :: Int, 2, 3] #-}
{-# ANN module ([1..10] :: [Integer]) #-}
{-# ANN module ''Foo #-}
{-# ANN module (-1 :: Int) #-}

{-# ANN type Foo (1 :: Int) #-}
{-# ANN type Foo (1 :: Integer) #-}
{-# ANN type Foo (1 :: Double) #-}
{-# ANN type Foo $([| 1 :: Int |]) #-}
{-# ANN type Foo "Hello" #-}
{-# ANN type Foo (Just (1 :: Int)) #-}
{-# ANN type Foo [1 :: Int, 2, 3] #-}
{-# ANN type Foo ([1..10] :: [Integer]) #-}
{-# ANN type Foo ''Foo #-}
{-# ANN type Foo (-1 :: Int) #-}
data Foo = Bar Int

{-# ANN f (1 :: Int) #-}
{-# ANN f (1 :: Integer) #-}
{-# ANN f (1 :: Double) #-}
{-# ANN f $([| 1 :: Int |]) #-}
{-# ANN f "Hello" #-}
{-# ANN f (Just (1 :: Int)) #-}
{-# ANN f [1 :: Int, 2, 3] #-}
{-# ANN f ([1..10] :: [Integer]) #-}
{-# ANN f 'f #-}
{-# ANN f (-1 :: Int) #-}
f x = x


module T14129 where

{-# ANN module "KABOOM" #-}


{-# LANGUAGE DeriveDataTypeable #-}
module A where

import Data.Typeable
import Data.Data

data FromA = FromA
  deriving (Typeable, Data)


module B where

import A

{-# ANN module FromA #-}


module AnnHelper where

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

traverseModuleAnnotations :: Q [String]
traverseModuleAnnotations = do
  ModuleInfo children <- reifyModule =<< thisModule
  go children [] []
  where
    go []     _visited acc = return acc
    go (x:xs) visited  acc | x `elem` visited = go xs visited acc
                           | otherwise = do
                             ModuleInfo newMods <- reifyModule x
                             newAnns <- reifyAnnotations $ AnnLookupModule x
                             go (newMods ++ xs) (x:visited) (newAnns ++ acc)


{-# LANGUAGE TemplateHaskell #-}

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

import AnnHelper
import TestModule
import TestModuleTH
import System.IO

main = do
  $(do
    anns <- traverseModuleAnnotations
    runIO $ print (anns :: [String])
    anns <- reifyAnnotations (AnnLookupName 'testValue)
    runIO $ print (anns :: [String])
    anns <- reifyAnnotations (AnnLookupName 'testValueTH)
    runIO $ print (anns :: [String])
    anns <- reifyAnnotations (AnnLookupName ''TestType)
    runIO $ print (anns :: [String])
    anns <- reifyAnnotations (AnnLookupName ''TestTypeTH)
    runIO $ print (anns :: [String])
    anns <- reifyAnnotations (AnnLookupName 'TestType)
    runIO $ print (anns :: [String])
    anns <- reifyAnnotations (AnnLookupName 'TestTypeTH)
    runIO $ print (anns :: [String])
    [| return () |] )
  hFlush stdout


module TestModule where

{-# ANN module "Module annotation" #-}

{-# ANN type TestType "Type annotation" #-}
{-# ANN TestType "Constructor annotation" #-}
data TestType = TestType

{-# ANN testValue "Value annotation" #-}
testValue :: Int
testValue = 42


{-# LANGUAGE TemplateHaskell #-}

module TestModuleTH where

import Language.Haskell.TH
import Language.Haskell.TH.Syntax (addTopDecls)

$(do
     modAnn <- pragAnnD ModuleAnnotation
                        (stringE "TH module annotation")
     modAnn' <- pragAnnD ModuleAnnotation
                         (stringE "addTopDecls module annotation")
     [typ] <- [d| data TestTypeTH = TestTypeTH |]
     conAnn <- pragAnnD (ValueAnnotation $ mkName "TestTypeTH")
                        (stringE "TH Constructor annotation")
     conAnn' <- pragAnnD (ValueAnnotation $ mkName "TestTypeTH")
                         (stringE "addTopDecls Constructor annotation")
     typAnn <- pragAnnD (TypeAnnotation $ mkName "TestTypeTH")
                        (stringE "TH Type annotation")
     typAnn' <- pragAnnD (TypeAnnotation $ mkName "TestTypeTH")
                         (stringE "addTopDecls Type annotation")
     valAnn <- pragAnnD (ValueAnnotation $ mkName "testValueTH")
                        (stringE "TH Value annotation")
     valAnn' <- pragAnnD (ValueAnnotation $ mkName "testValueTH")
                         (stringE "addTopDecls value annotation")
     [val] <- [d| testValueTH = (42 :: Int) |]
     addTopDecls [modAnn', conAnn', typAnn', valAnn']
     return [modAnn, conAnn, typAnn, typ, valAnn, val] )


module Annfail01 where
-- Testing annotating things that don't exist

{-# ANN type Foo (1 :: Int) #-}
{-# ANN f (1 :: Int) #-}


module Annfail02 where
-- Testing annotating things that don't exist in the right namespace

data Foo = Bar

{-# ANN Foo (1 :: Int) #-}
{-# ANN type Bar (2 :: Int) #-}


{-# LANGUAGE DeriveDataTypeable #-}

module Annfail03 where
-- Testing annotating something with a value defined + Typeabled / Dataed in same module

import Data.Data
import Data.Typeable

data InModule = InModule
              deriving (Typeable, Data)

{-# ANN module InModule #-}

{-# ANN type Foo InModule #-}
data Foo = Bar

{-# ANN f InModule #-}
f x = x


module Annfail04 where

import Annfail04_Help
-- Testing that we detect the use of instances defined in the same module

instance Thing Int where
  thing = 1

{-# ANN module (thing :: Int) #-}

{-# ANN type Foo (thing :: Int) #-}
data Foo = Bar

{-# ANN f (thing :: Int) #-}
f x = x


module Annfail04_Help where

class Thing a where
  thing :: a


module Annfail05 where

import Annfail05_Help
-- Testing annotating with a value that is not Typeable or Data-able

{-# ANN module NoInstances #-}

{-# ANN type Foo NoInstances #-}
data Foo = Bar

{-# ANN f NoInstances #-}
f x = x


module Annfail05_Help where

data NoInstances = NoInstances


{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}

module Annfail06 where
-- Testing that we don't accept Typeable or Data instances defined in the same module

import Annfail06_Help

import Data.Data
import Data.Typeable

deriving instance Typeable InstancesInWrongModule

instance Data InstancesInWrongModule where
    gfoldl = undefined
    gunfold = undefined

{-# ANN module InstancesInWrongModule #-}

{-# ANN type Foo InstancesInWrongModule #-}
data Foo = Bar

{-# ANN f InstancesInWrongModule #-}
f x = x


module Annfail06_Help where

data InstancesInWrongModule = InstancesInWrongModule


module Annfail07 where
-- Testing normal type errors in annotations

{-# ANN module (head True) #-}

{-# ANN type Foo (head True) #-}
data Foo = Bar

{-# ANN f (head True) #-}
f x = x


module Annfail08 where
-- Testing instance type errors in annotations

{-# ANN module (id + 1) #-}

{-# ANN type Foo (id + 1) #-}
data Foo = Bar

{-# ANN f (id + 1) #-}
f x = x


module Annfail09 where
-- Testing that we detect references to ids defined in module being compiled in annotations

g = 10

{-# ANN module g #-}

{-# ANN type Foo g #-}
data Foo = Bar

{-# ANN f g #-}
f x = x


module Annfail10 where
-- Testing ambiguity in annotations

{-# ANN module 1 #-}

{-# ANN type Foo 1 #-}
data Foo = Bar

{-# ANN f 1 #-}
f x = x


module Annfail11 where

{-# ANN length "Cannot annotate other modules yet" #-}
{-# ANN type Integer "Cannot annotate other modules yet" #-}


module Annfail12 where

-- Testing errors hidden in annotations

{-# ANN f (error "You were meant to see this error!" :: Int) #-}
f x = x


module Annfail13 where
-- Testing that brackets are mandatory in the ANN syntax

{-# ANN f id 1 #-}
{-# ANN f 1 :: Int #-}
f x = x


{-# LANGUAGE Safe #-}
module Test (hook) where

import System.IO.Unsafe

{-# ANN hook (unsafePerformIO (putStrLn "Woops.")) #-}
hook = undefined


{-# LANGUAGE ScopedTypeVariables #-}

module Main where

import GHC
import MonadUtils  ( liftIO )
import Data.Maybe
import DynFlags    ( defaultFatalMessager, defaultFlushOut )
import Annotations ( AnnTarget(..), CoreAnnTarget )
import GHC.Serialized  ( deserializeWithData )
import Panic

import Config
import Annrun01_Help

import qualified Language.Haskell.TH as TH
import Data.List
import Data.Function

main :: IO ()
main = defaultErrorHandler defaultFatalMessager defaultFlushOut
     $ runGhc (Just cTop) $ do
    liftIO $ putStrLn "Initializing Package Database"
    dflags <- getSessionDynFlags
    let dflags' = dflags
    setSessionDynFlags dflags'

    let mod_nm = mkModuleName "Annrun01_Help"

    liftIO $ putStrLn "Setting Target"
    setTargets [Target (TargetModule mod_nm) True Nothing]
    liftIO $ putStrLn "Loading Targets"
    load LoadAllTargets

    liftIO $ putStrLn "Finding Module"
    mod <- findModule mod_nm Nothing
    liftIO $ putStrLn "Getting Module Info"
    mod_info <- fromJust <$> getModuleInfo mod

    liftIO $ putStrLn "Showing Details For Module"
    showTargetAnns (ModuleTarget mod)
    liftIO $ putStrLn "Showing Details For Exports"
    let exports = sortBy (compare `on` getOccName) $ modInfoExports mod_info
    mapM_ (showTargetAnns . NamedTarget) exports

showTargetAnns :: CoreAnnTarget -> Ghc ()
showTargetAnns target = do
    (int_anns     :: [Int])        <- findGlobalAnns deserializeWithData target
    (mb_bool_anns :: [Maybe Bool]) <- findGlobalAnns deserializeWithData target
    (string_anns  :: [String])     <- findGlobalAnns deserializeWithData target
    (name_anns    :: [TH.Name])    <- findGlobalAnns deserializeWithData target
    liftIO $ print (int_anns, mb_bool_anns, string_anns, name_anns)


{-# LANGUAGE TemplateHaskell #-}

module Annrun01_Help where

{-# ANN module "Module" #-}
{-# ANN module "Annotations" #-}
{-# ANN module (10 :: Int) #-}
{-# ANN module "Rock!!!!" #-}

{-# ANN foo "Hello" #-}
{-# ANN foo "World!" #-}
{-# ANN bar 'foo #-}
foo = "Never seen"

{-# ANN bar "Hello World Again!" #-}
{-# ANN bar (1 :: Int) #-}
{-# ANN bar 'bar #-}
bar = "Also never seen"

baz = "Especially never seen"

{-# ANN type Baz "Type Annotation" #-}
{-# ANN type Baz (Just True) #-}
{-# ANN type Baz ''Baz #-}
data Baz = Spqr


module F0 where

f0 :: Int -> Int -> Int -> Int
f0 x y = if (x>0) then let v = x + y
                       in \z -> v+z
                  else \z-> 1


module F1 where

f1 = let h1 n x = if x<n then let v = h1 n (x+1)
                              in \y -> v (x+y)
                         else \y -> y
     in h1 5 1 5

g = \x1-> \x2-> \x3-> \x4-> \x5-> x1+x2+x3+x4+x5
s f = f 3
h = s g 6 7 8


module F11 where

fib 0 = 1
fib 1 = 1
fib n = fib (n-1) + fib (n-2)

f11f = \z -> let x = fib 1000
             in \y -> x+y

f11 = (f11f 5 6, f11f 7 8)


module F12 where

f12 = let f g x = g x
          h = (+)
      in f h 4 5


module F13 where

f13 x y = let f13f = if (x>0) then \z -> z x y
                                else \z -> y
              f13h = let v = f13f 5
                     in \w -> w + v
          in \u -> f13h u


module F14 where

f14 n x = if x<n then let v = f14 n (x+1)
                      in \y -> v (x+y)
               else \y -> y


module F15 where

f15f = \h -> h 1
f15g = \x -> x+1
f15 = f15f f15g


module F2 where

f2f = \h -> \x -> h x 0
f2 = let g = \x -> \y -> if (x > 0)
                                then g (x-1) (x+y)
                                else y
     in f2f g 5


module F3 where

fac :: Int -> Int
fac x = if (x==0) then 1
                  else x*fac (x-1)

f3 = let v = fac
     in \y -> v y


module F4 where

f4h :: (Int -> Int) -> Int -> Int
f4h f x = if x==0 then (f x)
                 else f4h f (x-1) -- + (f x)
f4g = \y->y+1
f4 = f4h f4g 9


module F5 where

-- result not satisfiable
f5g h z = (h z) + 1
f5h f x g = f x + f5g g x -- + (f (x+1))
f5y = (\y -> y+1)
f5 = f5h f5y 0 f5y


module F6 where

f6f = \h -> \x -> h x 0
f6t = \y -> \z -> y + z
f6 = f6f f6t 3


module F7 where

f7f = \x -> x
f7g = \z -> \y -> z+y
f7 = f7f f7g 2 3


module F8 where

f8f b x y = let g = \z -> x+y+z
            in if b then y else g (x*x)
f8 = f8f True 1 2


module F9 where

f91 = let f = \n -> if n<=100 then f (f (n+11)) else n-10
      in f 10


module Prim where

map2 f [] = []
map2 f (x:xs) = f x : map2 f xs

zipWith2 f [] [] = []
zipWith2 f (a:x) (b:y) = (f a b):zipWith2 f x y


-- !!! Simple array creation

import Data.Array

main =
 let a1 = array (1,3) (zip [2,3,1] ['a'..'d']) in
 print a1

-- Result:


-- !!! Array creation, (index,value) list with duplicates.
--
-- Haskell library report 1.3 (and earlier) specifies
-- that `array' values created with lists containing dups,
-- are undefined ( _|_ ).
--
-- GHC-2.02 (and earlier) does not flag this as such, the
-- last (index,value) is instead used.
--
-- The report also specifies `array' is spine strict in
-- the (index,value) list argument and to check the
-- validity of the index values upon creation, it also
-- strict for the indices. To test this, we do (a!1)
-- twice, expecting to see the same value..
--
import Data.Array

main =
 let a1 = array (1,3) (zip (1:[1..3]) ['a'..'d']) in
 print (a1!1) >>
 print a1     >>
 print (a1!1)


-- !!! Array creation, (index,value) list with out of bound index.
--
-- Haskell library report 1.3 (and earlier) specifies
-- that `array' values created with lists containing out-of-bounds indices,
-- are undefined ( _|_ ).
--
-- GHC implementation of `array' catches this (or, rather,
-- `index' does) - the argument list to `array' is defined
-- to have its spine be evaluated - so the indexing below
-- should cause a failure.
--
import Data.Array

main =
 let a1 = array (1::Int,3) (zip ([1..4]) ['a'..'d']) in
 print (a1!2)


-- !!! Array - accessing undefined element
--
-- Sample Haskell implementation in the 1.3 Lib report defines
-- this as being undefined/error.

import Data.Array

main =
 let a1 = array (1,3) (zip ([1,2]) ['a'..'d']) in
 print (a1!3)

-- output: Fail: (Array.!): undefined array element


-- !!! Array - recurrences
--
-- array does not evaluate the elements.
--
import Data.Array

main =
 let
  a1 = array (1,100) ((1,1::Integer):[(i,i*a1!(i-1))|i<-[2..100]])
 in
 print a1

--


-- !!! Array - empty arrays
--
-- print a couple of them to try to expose empty arrays
-- to a GC or two.
import Data.Array

main =
 let
  a1 = array (1,0) []
 in
 print (take 300 $ repeat (a1 :: Array Int Int))


-- !!! Array - accessing empty arrays
--
-- empty arrays are legal, but indexing them is undefined!
--
import Data.Array

main =
 let
  a1 = array (1::Int,0) [(1,'a')]
 in
 print (a1!0)


-- !!! Array - out-of-range (index,value) pairs
--
-- supplying a list containing one or more pairs
-- with out-of-range index is undefined.
--
--
import Data.Array

main =
 let
  a1 = array (1::Int,0) []
  a2 = array (0::Int,1) (zip [0..] ['a'..'z'])
 in
 print (a1::Array Int Int) >> print a2


-- !!! Array - derived ops
--
-- testing the well-behavedness of
-- derived ops for empty and non-empty arrays
--
import Data.Array

main =
 let
  a1 = array (1,0) ([]::[(Int,Int)])
  a2 = array (1,26) (zip [1..] ['a'..'z'])

  dump a = (bounds a, indices a, elems a, assocs a)
 in
 print (dump a1) >>
 print (dump a2)


-- !!! Array - accumulated arrays
--
--
module Main(main) where

import Data.Array
import Data.Ix

hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b
hist bnds is = accumArray (+) 0 bnds [(i,1) | i <- is , inRange bnds i]

main =
 let
  a1 = hist (0,10) (concat $ take 2 $ repeat [1..20])
 in
 print a1


-- !!! Array - array difference operator
--
--
module Main(main) where

import Data.Array
import Data.Ix

hist :: (Ix a, Num b) => (a,a) -> [a] -> Array a b
hist bnds is = accumArray (+) 0 bnds [(i,1) | i <- is , inRange bnds i]

main =
 let
  a1 = hist (0,10) (concat $ take 2 $ repeat [1..20])
 in
 print a1 >>
 print (a1 // [ (i,0) | i<-[0..10], odd i])


-- !!! Array map operations
--
--
module Main(main) where

import Data.Array
import Data.Char

main =
 let
  a1 = array (0,10) (zip [0..10] ['a'..'z'])
 in
 print a1 >>
 print (fmap (toUpper) a1) >>
 print (ixmap (3,8) (+1) a1)


import Data.Ratio -- 1.3
import Data.Array -- 1.3
infix 1 =:
(=:) a b = (a,b)

main = putStr (shows sub_b "\n")
    where
        sub_b :: Array Int Double
        sub_b = ixmap (102, 113) id b

        b :: Array Int Double
        b = fmap ( \ r -> fromRational r / pi )
                 (ixmap (101,200) (\ i -> toInteger i - 100) a)

        a :: Array Integer (Ratio Integer)
        a = array (1,100) ((1 =: 1) : [i =: fromInteger i * a!(i-1)
                                        | i <- [2..100]])


-- !!! multi-dimensional arrays

module Main ( main ) where
import Control.Monad.ST
import Data.Array.ST

type TwoD s = STArray s Int (STArray s Int Int)

setup :: ST s (TwoD s)
setup = let isz = 10
            imax = isz - 1
            osz = 2
            omax = osz - 1 in
        do
            -- gives : undefined reference to `IOBase_error_closure'
--          x <- newArray (0, omax) (error "uninitialised")
            dmy <- newArray (0, imax) 0
            x <- newArray (0, omax) dmy
            as <- (sequence . replicate osz) (newArray (0, imax) 6)
            mapM_ (\(i,v) -> writeArray x i v) (zip [0..omax] as)
            return x

main :: IO ()
main = do
         a <- stToIO setup
         return ()


-- !!! Array test
-- This one fails in Hugs (Feb 2001)

module Main where

import Data.Array

-- All in main is only to show the strange behaviour.
--
-- arrS is the array that foo (NB (1.0,1)) shows in Hugs.
-- But (foo (NB (1.0,1)))==arrS is False.

-- If I write NB (f,p) -> hCMt [(p,listArray ((1,1),(1,1)) [f])] instead of line 16
-- the bug disappears. That is also the reason why I have to keep the data declaration RD.
-- If I put the type signature of line 18 in scope the bug also disappears.
-- If I write hCMt po_arL = (accumArray (\a _-> a) ZM ((1,1),(1,2)) []) //
--                          (map (\(po,ar) -> ((1,po),M ar)) po_arL)
-- instead of line 19 and 20 it also vanishes.

data CM a = ZM | M (Array (Int,Int) a)  deriving (Show,Eq)

data RD =    NB !(Double,Int)

main  = do
  let arr = foo (NB (1.0,1))
        -- arr = { (1,1) -> M { (1,1) -> 1.0 }, (1,2) -> ZM }

        -- All these should return True
  putStr ("arr==arrS "++show (arr==arrS)++"\n")
  putStr ("arrS==arr "++show (arrS==arr)++"\n")
  putStr ("bnds arr arrS "++show ((bounds arr)==(bounds arrS))++"\n")
  putStr ("bnds +id arr arrS "++show (((bounds.id) arr)==((bounds) arrS))++"\n")
  putStr ("id +bnds arr arrS "++show (((id.bounds) arr)==((bounds) arrS))++"\n")

foo :: RD -> Array (Int,Int) (CM Double)
foo rd = case rd of
    NB (f,p) -> h where h = hCMt [(p,listArray ((1,1),(1,1)) [f])]
                        -- h = { (1,p) -> M { (1,1) -> f }, other -> ZM }
   where
   --h0CMt :: Array (Int, Int) (CM Double)
   -- h0CMt = { (1,1) -> ZM, (1,2) -> ZM }
   h0CMt = accumArray (\a _-> a) ZM ((1,1),(1,2)) []

   hCMt prs = h0CMt // (map (\(po,ar) -> ((1,po),M ar)) prs)
                        -- [ (1,p), M { (1,1) -> f } ]

arrS :: Array (Int,Int) (CM Double)
arrS = listArray ((1,1),(1,2)) [M (listArray ((1,1),(1,1)) [1.0]),ZM]


{-# LANGUAGE ScopedTypeVariables #-}

module Main where

{-
 - This is a test framework for Arrays, using QuickCheck
 -
 -}

import qualified Data.Array as Array
import Data.List
import Control.Monad ( liftM2, liftM3, liftM4 )
import System.Random

import Data.Ix
import Data.List( (\\) )

infixl 9  !, //
infixr 0 ==>
infix  1 `classify`

prop_array =
    forAll genBounds       $ \ (b :: (Int,Int))     ->
    forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
    Array.array b vs
         `same_arr`
    array b vs
prop_listArray =
    forAll genBounds       $ \ (b :: (Int,Int))     ->
    forAll (vector (length [fst b..snd b]))
                           $ \ (vs :: [Bool]) ->
    Array.listArray b vs == Array.array b (zipWith (\ a b -> (a,b))
                                                   (Array.range b) vs)

prop_indices =
    forAll genBounds       $ \ (b :: (Int,Int))     ->
    forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
    let arr = Array.array b vs
    in Array.indices arr == ((Array.range . Array.bounds) arr)

prop_elems =
    forAll genBounds       $ \ (b :: (Int,Int))     ->
    forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
    let arr = Array.array b vs
    in Array.elems arr == [arr Array.! i | i <- Array.indices arr]

prop_assocs =
    forAll genBounds       $ \ (b :: (Int,Int))     ->
    forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
    let arr = Array.array b vs
    in Array.assocs arr == [(i, arr Array.! i) | i <- Array.indices arr]

prop_slashslash =
    forAll genBounds       $ \ (b :: (Int,Int))     ->
    forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)])  ->
    let arr = Array.array b vs
        us = []
    in arr Array.// us == Array.array (Array.bounds arr)
                          ([(i,arr Array.! i)
                            | i <- Array.indices arr \\ [i | (i,_) <- us]]
                             ++ us)
prop_accum =
    forAll genBounds          $ \ (b :: (Int,Int))    ->
    forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->

    forAll (genIVPs b 10)     $ \ (us :: [(Int,Int)]) ->
    forAll (choose (0,length us))
                           $ \ n ->
    let us' = take n us in
    forAll arbitrary       $ \ (fn :: Int -> Int -> Int) ->
    let arr = Array.array b vs
    in Array.accum fn arr us'
        == foldl (\a (i,v) -> a Array.// [(i,fn (a Array.! i) v)]) arr us'

prop_accumArray =
    forAll arbitrary          $ \ (f :: Int -> Int -> Int) ->
    forAll arbitrary          $ \ (z :: Int) ->
    forAll genBounds          $ \ (b :: (Int,Int))    ->
    forAll (genIVPs b 10)     $ \ (vs :: [(Int,Int)]) ->
    Array.accumArray f z b vs == Array.accum f
                (Array.array b [(i,z) | i <- Array.range b]) vs

same_arr :: (Eq b) => Array.Array Int b -> Array Int b -> Bool
same_arr a1 a2 = a == c && b == d
                 && all (\ n -> (a1 Array.! n) == (a2 ! n)) [a..b]
    where (a,b) = Array.bounds a1 :: (Int,Int)
          (c,d) = bounds a2 :: (Int,Int)

genBounds :: Gen (Int,Int)
genBounds = do m <- choose (0,20)
               n <- choose (minBound,maxBound-m)
               return (n,n+m-1)

genIVP :: Arbitrary a => (Int,Int) -> Gen (Int,a)
genIVP b = do { i <- choose b
              ; v <- arbitrary
              ; return (i,v)
              }

genIVPs :: Arbitrary a => (Int,Int) -> Int -> Gen [(Int,a)]
genIVPs b@(low,high) s
  = do { let is = [low..high]
       ; vs <- vector (length is)
       ; shuffle s (zip is vs)
       }

prop_id = forAll genBounds $ \ (b :: (Int,Int)) ->
          forAll (genIVPs b 10) $ \ (ivps :: [(Int,Int)])  ->
          label (show (ivps :: [(Int,Int)])) True

-- rift takes a list, split it (using an Int argument),
-- and then rifts together the split lists into one.
-- Think: rifting a pack of cards.
rift :: Int -> [a] -> [a]
rift n xs = comb (drop n xs) (take n xs)
   where
      comb (a:as) (b:bs) = a : b : comb as bs
      comb (a:as) []     = a : as
      comb []     (b:bs) = b : bs
      comb []     []     = []

-- suffle makes n random rifts. Typically after
-- log n rifts, the list is in a pretty random order.
-- (where n is the number of elements in the list)

shuffle :: Int -> [a] -> Gen [a]
shuffle 0 m = return m
shuffle n m = do { r <- choose (1,length m)
                 ; shuffle (n-1) (rift r m)
                 }
prop_shuffle =
    forAll (shuffle 10 [1..10::Int]) $ \ lst ->
    label (show lst) True

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

main = do test prop_array
          test prop_listArray
          test prop_indices
          test prop_elems
          test prop_assocs
          test prop_slashslash
          test prop_accum
          test prop_accumArray

instance Show (a -> b) where { show _ = "<FN>" }

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

data Array a b = MkArray (a,a) (a -> b) deriving ()

array       :: (Ix a) => (a,a) -> [(a,b)] -> Array a b
array b ivs =
    if and [inRange b i | (i,_) <- ivs]
        then MkArray b
                     (\j -> case [v | (i,v) <- ivs, i == j] of
                            [v]   -> v
                            []    -> error "Array.!: \
                                           \undefined array element"
                            _     -> error "Array.!: \
                                           \multiply defined array element")
        else error "Array.array: out-of-range array association"

listArray             :: (Ix a) => (a,a) -> [b] -> Array a b
listArray b vs        =  array b (zipWith (\ a b -> (a,b)) (range b) vs)

(!)                   :: (Ix a) => Array a b -> a -> b
(!) (MkArray _ f)     =  f

bounds                :: (Ix a) => Array a b -> (a,a)
bounds (MkArray b _)  =  b

indices               :: (Ix a) => Array a b -> [a]
indices               =  range . bounds

elems                 :: (Ix a) => Array a b -> [b]
elems a               =  [a!i | i <- indices a]

assocs                :: (Ix a) => Array a b -> [(a,b)]
assocs a              =  [(i, a!i) | i <- indices a]

(//)                  :: (Ix a) => Array a b -> [(a,b)] -> Array a b
a // us               =  array (bounds a)
                            ([(i,a!i) | i <- indices a \\ [i | (i,_) <- us]]
                             ++ us)

accum                 :: (Ix a) => (b -> c -> b) -> Array a b -> [(a,c)]
                                   -> Array a b
accum f               =  foldl (\a (i,v) -> a // [(i,f (a!i) v)])

accumArray            :: (Ix a) => (b -> c -> b) -> b -> (a,a) -> [(a,c)]
                                   -> Array a b
accumArray f z b      =  accum f (array b [(i,z) | i <- range b])

ixmap                 :: (Ix a, Ix b) => (a,a) -> (a -> b) -> Array b c
                                         -> Array a c
ixmap b f a           = array b [(i, a ! f i) | i <- range b]

instance  (Ix a)          => Functor (Array a) where
    fmap fn (MkArray b f) =  MkArray b (fn . f)

instance  (Ix a, Eq b)  => Eq (Array a b)  where
    a == a'             =  assocs a == assocs a'

instance  (Ix a, Ord b) => Ord (Array a b)  where
    a <=  a'            =  assocs a <=  assocs a'

instance  (Ix a, Show a, Show b) => Show (Array a b)  where
    showsPrec p a = showParen (p > 9) (
                    showString "array " .
                    shows (bounds a) . showChar ' ' .
                    shows (assocs a)                  )

instance  (Ix a, Read a, Read b) => Read (Array a b)  where
    readsPrec p = readParen (p > 9)
           (\r -> [(array b as, u) | ("array",s) <- lex r,
                                     (b,t)       <- reads s,
                                     (as,u)      <- reads t   ])
--------------------------------------------------------------------

-- QuickCheck v.0.2
-- DRAFT implementation; last update 000104.
-- Koen Claessen, John Hughes.
-- This file represents work in progress, and might change at a later date.

--------------------------------------------------------------------
-- Generator

newtype Gen a
  = Gen (Int -> StdGen -> a)

sized :: (Int -> Gen a) -> Gen a
sized fgen = Gen (\n r -> let Gen m = fgen n in m n r)

resize :: Int -> Gen a -> Gen a
resize n (Gen m) = Gen (\_ r -> m n r)

rand :: Gen StdGen
rand = Gen (\n r -> r)

promote :: (a -> Gen b) -> Gen (a -> b)
promote f = Gen (\n r -> \a -> let Gen m = f a in m n r)

variant :: Int -> Gen a -> Gen a
variant v (Gen m) = Gen (\n r -> m n (rands r !! (v+1)))
 where
  rands r0 = r1 : rands r2 where (r1, r2) = split r0

generate :: Int -> StdGen -> Gen a -> a
generate n rnd (Gen m) = m size rnd'
 where
  (size, rnd') = randomR (0, n) rnd

instance Functor Gen where
  fmap f m = m >>= return . f

instance Applicative Gen where
  pure  = return
  (<*>) = liftM2 id

instance Monad Gen where
  return a    = Gen (\n r -> a)
  Gen m >>= k =
    Gen (\n r0 -> let (r1,r2) = split r0
                      Gen m'  = k (m n r1)
                   in m' n r2)

-- derived

--choose :: Random a => (a, a) -> Gen a
choose bounds = ((fst . randomR bounds) `fmap` rand)

elements :: [a] -> Gen a
elements xs = (xs !!) `fmap` choose (0, length xs - 1)

vector :: Arbitrary a => Int -> Gen [a]
vector n = sequence [ arbitrary | i <- [1..n] ]

oneof :: [Gen a] -> Gen a
oneof gens = elements gens >>= id

frequency :: [(Int, Gen a)] -> Gen a
frequency xs = choose (1, tot) >>= (`pick` xs)
 where
  tot = sum (map fst xs)

  pick n ((k,x):xs)
    | n <= k    = x
    | otherwise = pick (n-k) xs

-- general monadic

two :: Monad m => m a -> m (a, a)
two m = liftM2 (,) m m

three :: Monad m => m a -> m (a, a, a)
three m = liftM3 (,,) m m m

four :: Monad m => m a -> m (a, a, a, a)
four m = liftM4 (,,,) m m m m

--------------------------------------------------------------------
-- Arbitrary

class Arbitrary a where
  arbitrary   :: Gen a
  coarbitrary :: a -> Gen b -> Gen b

instance Arbitrary () where
  arbitrary     = return ()
  coarbitrary _ = variant 0

instance Arbitrary Bool where
  arbitrary     = elements [True, False]
  coarbitrary b = if b then variant 0 else variant 1

instance Arbitrary Int where
  arbitrary     = sized $ \n -> choose (-n,n)
  coarbitrary n = variant (if n >= 0 then 2*n else 2*(-n) + 1)

instance Arbitrary Integer where
  arbitrary     = sized $ \n -> choose (-fromIntegral n,fromIntegral n)
  coarbitrary n = variant (fromInteger (if n >= 0 then 2*n else 2*(-n) + 1))

instance Arbitrary Float where
  arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
  coarbitrary x = coarbitrary (decodeFloat x)

instance Arbitrary Double where
  arbitrary     = liftM3 fraction arbitrary arbitrary arbitrary
  coarbitrary x = coarbitrary (decodeFloat x)

fraction a b c = fromInteger a + (fromInteger b / (abs (fromInteger c) + 1))

instance (Arbitrary a, Arbitrary b) => Arbitrary (a, b) where
  arbitrary          = liftM2 (,) arbitrary arbitrary
  coarbitrary (a, b) = coarbitrary a . coarbitrary b

instance (Arbitrary a, Arbitrary b, Arbitrary c) => Arbitrary (a, b, c) where
  arbitrary             = liftM3 (,,) arbitrary arbitrary arbitrary
  coarbitrary (a, b, c) = coarbitrary a . coarbitrary b . coarbitrary c

instance (Arbitrary a, Arbitrary b, Arbitrary c, Arbitrary d)
      => Arbitrary (a, b, c, d)
 where
  arbitrary = liftM4 (,,,) arbitrary arbitrary arbitrary arbitrary
  coarbitrary (a, b, c, d) =
    coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d

instance Arbitrary a => Arbitrary [a] where
  arbitrary          = sized (\n -> choose (0,n) >>= vector)
  coarbitrary []     = variant 0
  coarbitrary (a:as) = coarbitrary a . variant 1 . coarbitrary as

instance (Arbitrary a, Arbitrary b) => Arbitrary (a -> b) where
  arbitrary         = promote (`coarbitrary` arbitrary)
  coarbitrary f gen = arbitrary >>= ((`coarbitrary` gen) . f)

--------------------------------------------------------------------
-- Testable

data Result
  = Result { ok :: Maybe Bool, stamp :: [String], arguments :: [String] }

nothing :: Result
nothing = Result{ ok = Nothing, stamp = [], arguments = [] }

newtype Property
  = Prop (Gen Result)

result :: Result -> Property
result res = Prop (return res)

evaluate :: Testable a => a -> Gen Result
evaluate a = gen where Prop gen = property a

class Testable a where
  property :: a -> Property

instance Testable () where
  property _ = result nothing

instance Testable Bool where
  property b = result (nothing{ ok = Just b })

instance Testable Result where
  property res = result res

instance Testable Property where
  property prop = prop

instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
  property f = forAll arbitrary f

forAll :: (Show a, Testable b) => Gen a -> (a -> b) -> Property
forAll gen body = Prop $
  do a   <- gen
     res <- evaluate (body a)
     return (argument a res)
 where
  argument a res = res{ arguments = show a : arguments res }

(==>) :: Testable a => Bool -> a -> Property
True  ==> a = property a
False ==> a = property ()

label :: Testable a => String -> a -> Property
label s a = Prop (add `fmap` evaluate a)
 where
  add res = res{ stamp = s : stamp res }

classify :: Testable a => Bool -> String -> a -> Property
classify True  name = label name
classify False _    = property

trivial :: Testable a => Bool -> a -> Property
trivial = (`classify` "trivial")

collect :: (Show a, Testable b) => a -> b -> Property
collect v = label (show v)

--------------------------------------------------------------------
-- Testing

data Config = Config
  { configMaxTest :: Int
  , configMaxFail :: Int
  , configSize    :: Int -> Int
  , configEvery   :: Int -> [String] -> String
  }

quick :: Config
quick = Config
  { configMaxTest = 100
  , configMaxFail = 1000
  , configSize    = (+ 3) . (`div` 2)
  , configEvery   = \n args -> let s = show n in s ++ ","
  }

verbose :: Config
verbose = quick
  { configEvery = \n args -> show n ++ ":\n" ++ unlines args
  }

test, quickCheck, verboseCheck :: Testable a => a -> IO ()
test         = check quick
quickCheck   = check quick
verboseCheck = check verbose

check :: Testable a => Config -> a -> IO ()
check config a =
  do rnd <- newStdGen
     tests config (evaluate a) rnd 0 0 []

tests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO ()
tests config gen rnd0 ntest nfail stamps
  | ntest == configMaxTest config = do done "OK, passed" ntest stamps
  | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps
  | otherwise               =
      do putStr (configEvery config ntest (arguments result))
         case ok result of
           Nothing    ->
             tests config gen rnd1 ntest (nfail+1) stamps
           Just True  ->
             tests config gen rnd1 (ntest+1) nfail (stamp result:stamps)
           Just False ->
             putStr ( "Falsifiable, after "
                   ++ show ntest
                   ++ " tests:\n"
                   ++ unlines (arguments result)
                    )
     where
      result      = generate (configSize config ntest) rnd2 gen
      (rnd1,rnd2) = split rnd0

done :: String -> Int -> [[String]] -> IO ()
done mesg ntest stamps =
  do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table )
 where
  table = display
        . map entry
        . reverse
        . sort
        . map pairLength
        . group
        . sort
        . filter (not . null)
        $ stamps

  display []  = ".\n"
  display [x] = " (" ++ x ++ ").\n"
  display xs  = ".\n" ++ unlines (map (++ ".") xs)

  pairLength xss@(xs:_) = (length xss, xs)
  entry (n, xs)         = percentage n ntest
                       ++ " "
                       ++ concat (intersperse ", " xs)

  percentage n m        = show ((100 * n) `div` m) ++ "%"

--------------------------------------------------------------------
-- the end.

{-
instance Observable StdGen where { observer = observeBase }

instance Observable a => Observable (Gen a) where
  observer (Gen a) = send "Gen" (return (Gen) << a)

-}


-- Caused a crash in GHC 6.4 when optimising, due to inlining of runST too early.

-- Spectral Norm benchmark

import Data.Array
import System.Environment (getArgs)

main = do
        --[arg] <- getArgs
        --let n = (read arg) - 1
        let n = 80
        let init = listArray (0,n) (repeat 1.0)
        let (v:u:rest) = drop 19 $ iterate (eval_AtA_times_u n) init
        let vBv = sum [(u!i)*(v!i) |i<-[0..n]]
        let vv  = sum [(v!i)*(v!i) |i<-[0..n]]
        print $ sqrt (vBv/vv)

eval_AtA_times_u n u = eval_At_times_u n v
    where v = eval_A_times_u n u

eval_A x y = 1.0/((i+j)*(i+j+1)/2+i+1)
    where i = fromIntegral x
          j = fromIntegral y

eval_A_times_u n u = accumArray (+) 0 (0,n)
                     [(i,(eval_A i j) * u!j)|i<-[0..n], j<-[0..n]]

eval_At_times_u n u = accumArray (+) 0 (0,n)
                      [(i,(eval_A j i) * u!j)|i<-[0..n], j<-[0..n]]


-- test for #1131
import Control.Monad.ST
import Data.Array.ST
import Data.Array
import System.Mem

tickle :: Int
tickle = runST (do {
     x <- newArray_ (0,100) ;
     (readArray :: STUArray s Int Int -> Int -> ST s Int) x 3
   })

main :: IO ()
main = do print $ length (replicate 100000 'a')
          performGC
          print tickle


-- Test for trac #2158

import Data.Array

data Pos = Pos Integer Integer
    deriving (Show, Eq, Ord, Ix)

myBounds :: (Pos, Pos)
myBounds = (Pos 0 0, Pos 2 3)

main :: IO ()
main = do print $ range myBounds
          print $ index myBounds (Pos 0 0)
          print $ index myBounds (Pos 0 1)
          print $ index myBounds (Pos 0 2)
          print $ index myBounds (Pos 0 3)
          print $ index myBounds (Pos 1 0)
          print $ index myBounds (Pos 1 1)
          print $ index myBounds (Pos 1 2)
          print $ index myBounds (Pos 1 3)
          print $ index myBounds (Pos 2 0)
          print $ index myBounds (Pos 2 1)
          print $ index myBounds (Pos 2 2)
          print $ index myBounds (Pos 2 3)
          print $ listArray myBounds [(123 :: Integer) ..]


{-# LANGUAGE MagicHash, UnboxedTuples, ScopedTypeVariables #-}

module Main where

import GHC.Prim
import GHC.Base
import GHC.ST
import GHC.Word
import Control.Monad
import System.Mem

data MutableByteArray s = MutableByteArray (MutableByteArray# s)

data ByteArray e = ByteArray ByteArray#

newByteArray :: Int -> ST s (MutableByteArray s)
newByteArray (I# n#)
  = ST $ \s# -> case newByteArray# n# s# of
           (# s'#, arr# #) -> (# s'#, MutableByteArray arr# #)

writeByteArray :: MutableByteArray s -> Int -> Word32 -> ST s ()
writeByteArray (MutableByteArray mba#) (I# i#) (W32# w#)
  = ST $ \s# -> case writeWord32Array# mba# i# w# s# of
           s'# -> (# s'#, () #)

indexArray :: ByteArray Word32 -> Int -> Word32
indexArray (ByteArray arr#) (I# i#)
  = W32# (indexWord32Array# arr# i#)

unsafeFreezeByteArray :: MutableByteArray s -> ST s (ByteArray e)
unsafeFreezeByteArray (MutableByteArray mba#)
  = ST $ \s# -> case unsafeFreezeByteArray# mba# s# of
           (# s'#, ba# #)  -> (# s'#, ByteArray ba# #)

data MutableArrayArray s e = MutableArrayArray (MutableArrayArray# s)

data ArrayArray e = ArrayArray ArrayArray#

newArrayArray :: Int -> ST s (MutableArrayArray s e)
newArrayArray (I# n#)
  = ST $ \s# -> case newArrayArray# n# s# of
           (# s'#, arr# #) -> (# s'#, MutableArrayArray arr# #)

writeArrayArrayMut :: MutableArrayArray s (MutableByteArray s) -> Int -> MutableByteArray s
                -> ST s ()
writeArrayArrayMut (MutableArrayArray arrs#) (I# i#) (MutableByteArray mba#)
  = ST $ \s# -> case writeMutableByteArrayArray# arrs# i# mba# s# of
           s'# -> (# s'#, () #)

writeArrayArray :: MutableArrayArray s (ByteArray s) -> Int -> ByteArray s
                -> ST s ()
writeArrayArray (MutableArrayArray arrs#) (I# i#) (ByteArray ba#)
  = ST $ \s# -> case writeByteArrayArray# arrs# i# ba# s# of
           s'# -> (# s'#, () #)

readArrayArray :: MutableArrayArray s (MutableByteArray s) -> Int -> ST s (MutableByteArray s)
readArrayArray (MutableArrayArray arrs#) (I# i#)
  = ST $ \s# -> case readMutableByteArrayArray# arrs# i# s# of
           (# s'#, mba# #) -> (# s'#, MutableByteArray mba# #)

indexArrayArray :: ArrayArray (ByteArray e) -> Int -> ByteArray e
indexArrayArray (ArrayArray arrs#) (I# i#)
  = ByteArray (indexByteArrayArray# arrs# i#)

unsafeFreezeArrayArray :: MutableArrayArray s e -> ST s (ArrayArray e)
unsafeFreezeArrayArray (MutableArrayArray marrs#)
  = ST $ \s# -> case unsafeFreezeArrayArray# marrs# s# of
           (# s'#, arrs# #)  -> (# s'#, ArrayArray arrs# #)

unsafeDeepFreezeArrayArray :: forall s e
                           .  MutableArrayArray s (MutableByteArray s)
                           -> ST s (ArrayArray (ByteArray e))
unsafeDeepFreezeArrayArray marrs@(MutableArrayArray marrs#)
  = do { let n = I# (sizeofMutableArrayArray# marrs#)
             marrs_halfFrozen = MutableArrayArray marrs#  -- :: MutableArrayArray s (ByteArray e)
       ; mapM_ (freezeSubArray marrs_halfFrozen) [0..n - 1]
       ; unsafeFreezeArrayArray marrs_halfFrozen
       }
  where
    freezeSubArray marrs_halfFrozen i
      = do { mba <- readArrayArray marrs i
           ; ba  <- unsafeFreezeByteArray mba
           ; writeArrayArray marrs_halfFrozen i ba
           }

newByteArrays :: [Int] -> ST s (MutableArrayArray s (MutableByteArray s))
newByteArrays ns
  = do { arrs <- newArrayArray (length ns)
       ; zipWithM_ (writeNewByteArray arrs) ns [0..]
       ; return arrs
       }
  where
    writeNewByteArray arrs n i
      = do { mba <- newByteArray (n * 4)    -- we store 32-bit words
           ; writeArrayArrayMut arrs i mba
           }

type UnboxedArray2D e = ArrayArray (ByteArray e)

newUnboxedArray2D :: [[Word32]] -> UnboxedArray2D Word32
newUnboxedArray2D values
  = runST $
    do { marrs <- newByteArrays (map length values)
       ; zipWithM_ (fill marrs) values [0..]
       ; arrs <- unsafeDeepFreezeArrayArray marrs
       ; return arrs
       }
  where
    fill marrs vs i
      = do { mba <- readArrayArray marrs i
           ; zipWithM_ (writeByteArray mba) [0..] vs
           }

unboxedArray2D :: UnboxedArray2D Word32
unboxedArray2D
  = newUnboxedArray2D
    [ [1..10]
    , [11..200]
    , []
    , [1..1000] ++ [42] ++ [1001..2000]
    , [1..100000]
    ]

indexUnboxedArray2D :: UnboxedArray2D Word32 -> (Int, Int) -> Word32
indexUnboxedArray2D arr (i, j)
  = indexArrayArray arr i `indexArray` j

main
  = do { print $ unboxedArray2D `indexUnboxedArray2D` (3, 1000)
       ; performGC
       ; print $ unboxedArray2D `indexUnboxedArray2D` (3, 1000)
       }


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

f :: Arrow a => a (Int,Int,Int) Int
f = proc (x,y,z) -> returnA -< x+y


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

f :: ArrowApply a => a (a Int Int,Int,Int) Int
f = proc (x,y,z) -> x -<< 2+y

g :: ArrowApply a => Int -> a (a Int Int,Int) Int
g y = proc (x,z) -> x -<< 2+y


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

g :: Arrow a => a Int c -> a Int c
g f = proc b -> f -< b+2


{-# LANGUAGE Arrows #-}

module ShouldCompile where

-- variables bound inside the left argument of -< should be in scope

import Control.Arrow

f :: (Num b, Arrow a) => a b b
f = proc x -> arr (\y -> y-1) -< x

g :: (Num b, Arrow a) => a b b
g = proc x -> (proc y -> returnA -< y-1) -< x


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

h :: ArrowChoice a => Int -> a (Int,Int) Int
h x = proc (y,z) -> case compare x y of
        LT -> returnA -< x
        EQ -> returnA -< y+z
        GT -> returnA -< z+x

g :: ArrowChoice a => Int -> a (Int,Int) Int
g x = proc (y,z) -> (case compare x y of
        LT -> \ a -> returnA -< x+a
        EQ -> \ b -> returnA -< y+z+b
        GT -> \ c -> returnA -< z+x
    ) 1


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

f :: Arrow a => a (Int,Int,Int) Int
f = proc (x,y,z) -> returnA -< x+y

g :: Arrow a => Int -> a Int Int
g x = proc y -> returnA -< x*y

h :: Arrow a => Int -> a (Int,Int) Int
h x = proc (y,z) -> do
        a <- f -< (x,y,3)
        b <- g (2+x) -< y+a
        returnA -< a*b+z


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

f :: Arrow a => a (Int,Int) Int
f = proc (x,y) -> do
        let z = x*y
        returnA -< y+z


{-# LANGUAGE Arrows #-}

-- test for out-size tuples: takes a _long_ time to compile

module ShouldCompile where

import Control.Arrow

data T1 = C1
data T2 = C2
data T3 = C3
data T4 = C4
data T5 = C5
data T6 = C6
data T7 = C7
data T8 = C8
data T9 = C9
data T10 = C10
data T11 = C11
data T12 = C12
data T13 = C13
data T14 = C14
data T15 = C15
data T16 = C16
data T17 = C17
data T18 = C18
data T19 = C19
data T20 = C20
data T21 = C21
data T22 = C22
data T23 = C23
data T24 = C24
data T25 = C25
data T26 = C26
data T27 = C27
data T28 = C28
data T29 = C29
data T30 = C30
data T31 = C31
data T32 = C32
data T33 = C33
data T34 = C34
data T35 = C35
data T36 = C36
data T37 = C37
data T38 = C38
data T39 = C39
data T40 = C40
data T41 = C41
data T42 = C42
data T43 = C43
data T44 = C44
data T45 = C45
data T46 = C46
data T47 = C47
data T48 = C48
data T49 = C49
data T50 = C50
data T51 = C51
data T52 = C52
data T53 = C53
data T54 = C54
data T55 = C55
data T56 = C56
data T57 = C57
data T58 = C58
data T59 = C59
data T60 = C60
data T61 = C61
data T62 = C62
data T63 = C63
data T64 = C64
data T65 = C65
data T66 = C66
data T67 = C67
data T68 = C68
data T69 = C69
data T70 = C70

f :: Arrow a => a Int Int
f = proc x0 -> do
        x1 <- returnA -< C1
        x2 <- returnA -< C2
        x3 <- returnA -< C3
        x4 <- returnA -< C4
        x5 <- returnA -< C5
        x6 <- returnA -< C6
        x7 <- returnA -< C7
        x8 <- returnA -< C8
        x9 <- returnA -< C9
        x10 <- returnA -< C10
        x11 <- returnA -< C11
        x12 <- returnA -< C12
        x13 <- returnA -< C13
        x14 <- returnA -< C14
        x15 <- returnA -< C15
        x16 <- returnA -< C16
        x17 <- returnA -< C17
        x18 <- returnA -< C18
        x19 <- returnA -< C19
        x20 <- returnA -< C20
        x21 <- returnA -< C21
        x22 <- returnA -< C22
        x23 <- returnA -< C23
        x24 <- returnA -< C24
        x25 <- returnA -< C25
        x26 <- returnA -< C26
        x27 <- returnA -< C27
        x28 <- returnA -< C28
        x29 <- returnA -< C29
        x30 <- returnA -< C30
        x31 <- returnA -< C31
        x32 <- returnA -< C32
        x33 <- returnA -< C33
        x34 <- returnA -< C34
        x35 <- returnA -< C35
        x36 <- returnA -< C36
        x37 <- returnA -< C37
        x38 <- returnA -< C38
        x39 <- returnA -< C39
        x40 <- returnA -< C40
        x41 <- returnA -< C41
        x42 <- returnA -< C42
        x43 <- returnA -< C43
        x44 <- returnA -< C44
        x45 <- returnA -< C45
        x46 <- returnA -< C46
        x47 <- returnA -< C47
        x48 <- returnA -< C48
        x49 <- returnA -< C49
        x50 <- returnA -< C50
        x51 <- returnA -< C51
        x52 <- returnA -< C52
        x53 <- returnA -< C53
        x54 <- returnA -< C54
        x55 <- returnA -< C55
        x56 <- returnA -< C56
        x57 <- returnA -< C57
        x58 <- returnA -< C58
        x59 <- returnA -< C59
        x60 <- returnA -< C60
        x61 <- returnA -< C61
        x62 <- returnA -< C62
        x63 <- returnA -< C63
        x64 <- returnA -< C64
        x65 <- returnA -< C65
        x66 <- returnA -< C66
        x67 <- returnA -< C67
        x68 <- returnA -< C68
        x69 <- returnA -< C69
        x70 <- returnA -< C70
        returnA -< x70
        returnA -< x69
        returnA -< x68
        returnA -< x67
        returnA -< x66
        returnA -< x65
        returnA -< x64
        returnA -< x63
        returnA -< x62
        returnA -< x61
        returnA -< x60
        returnA -< x59
        returnA -< x58
        returnA -< x57
        returnA -< x56
        returnA -< x55
        returnA -< x54
        returnA -< x53
        returnA -< x52
        returnA -< x51
        returnA -< x50
        returnA -< x49
        returnA -< x48
        returnA -< x47
        returnA -< x46
        returnA -< x45
        returnA -< x44
        returnA -< x43
        returnA -< x42
        returnA -< x41
        returnA -< x40
        returnA -< x39
        returnA -< x38
        returnA -< x37
        returnA -< x36
        returnA -< x35
        returnA -< x34
        returnA -< x33
        returnA -< x32
        returnA -< x31
        returnA -< x30
        returnA -< x29
        returnA -< x28
        returnA -< x27
        returnA -< x26
        returnA -< x25
        returnA -< x24
        returnA -< x23
        returnA -< x22
        returnA -< x21
        returnA -< x20
        returnA -< x19
        returnA -< x18
        returnA -< x17
        returnA -< x16
        returnA -< x15
        returnA -< x14
        returnA -< x13
        returnA -< x12
        returnA -< x11
        returnA -< x10
        returnA -< x9
        returnA -< x8
        returnA -< x7
        returnA -< x6
        returnA -< x5
        returnA -< x4
        returnA -< x3
        returnA -< x2
        returnA -< x1
        returnA -< x0


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

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

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

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

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


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

f :: ArrowChoice a => a (Int,Int,Int) Int
f = proc (x,y,z) -> if x < y then returnA -< x+y else returnA -< x+z

g :: ArrowChoice a => Int -> a (Int,Int) Int
g x = proc (y,z) -> if x < y then returnA -< x+y else returnA -< x+z


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow

f :: Arrow a => a (Int,Int) Int
f = proc (x,y) -> let z = x*y in returnA -< y+z


{-# LANGUAGE Arrows #-}
{-# OPTIONS -fno-warn-redundant-constraints #-}

-- Test for Trac #1662

module Arrow where

import Control.Arrow

expr' :: Arrow a => a Int Int
expr' = error "urk"

term :: Arrow a => a () Int
term = error "urk"

expr1 :: Arrow a => a () Int
expr1 = proc () -> do
          x <- term -< ()
          expr' -< x

expr2 :: Arrow a => a () Int
expr2 = proc y -> do
          x <- term -< y
          expr' -< x


{-# LANGUAGE Arrows #-}

module ShouldCompile where

import Control.Arrow
import Data.Char

f :: ArrowLoop a => a Char Int
f = proc x -> do
        a <- returnA -< ord x
        rec     b <- returnA -< ord c - ord x
                c <- returnA -< chr a
        returnA -< b + ord c


{-# LANGUAGE Arrows, ViewPatterns #-}

module T3964 where

import Control.Arrow

testF :: Eq a => a -> (Maybe (Maybe a)) -> Maybe a
testF v = proc x -> case x of
     Just (Just ((==v) -> True)) -> returnA -< Just v
     _                           -> returnA -< Nothing


{-# LANGUAGE Arrows #-}
module T5022 ( pIterate ) where

import Prelude hiding ( init )

returnA :: b -> b
returnA = id

------------
newtype State s a = State { unState :: [a] }

------------
pIterate :: a -> [a]
pIterate =
    proc x -> do
      rec
        as <- unState -< s
        let s = State (x:as)
      returnA -< as


{-# LANGUAGE Arrows, GeneralizedNewtypeDeriving #-}

module T5267 where

import Prelude
import Control.Arrow
import Control.Category

newtype A a b c = A { unA :: a b c }
    deriving (Category, Arrow)

ite :: ArrowChoice a
    => a env Bool -> A a env d -> A a env d -> A a env d
ite iA tA eA = A $ proc env ->
  do i <- iA -< env
     if i then unA tA -< env else unA eA -< env

ite_perm tA eA i = ite i tA eA

-- In 6.12, this worked:
ite' cA tA eA = proc x ->
  do c <- cA -< x
     (| (ite_perm tA eA) (returnA -< c) |)

-- but this didn't:
ite'' cA tA eA = proc x ->
  do c <- cA -< x
     (| ite_perm' (returnA -< c) |)
  where ite_perm' i = ite i tA eA


{-# LANGUAGE Arrows #-}
-- Failed in ghci

module T where

import Prelude
import Control.Arrow

mapAC :: Arrow arr => Int -> arr (env, (b,())) c -> arr (env, ([b],())) [c]
mapAC n farr = go 0
  where
    go i | i == n = arr (\(_env, ([], ())) -> [])
         | otherwise = proc ~(env, (b : bs, ())) ->
             do c  <- farr -< (env, (b, ()))
                cs <- go (i+1) -< (env, (bs, ()))
                returnA -< c : cs

t :: Arrow arr => arr [a] [a]
t = proc ys ->
     (| (mapAC 3) (\y -> returnA -< y) |) ys