summaryrefslogtreecommitdiff
path: root/tests/examples
diff options
context:
space:
mode:
authorAlanZimmerman <>2019-05-26 18:43:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-05-26 18:43:00 (GMT)
commit8b58806da36a60014c8441056e950947ed633c2c (patch)
treefdcda98051bde50f428f90d14aacfabd33299fd0 /tests/examples
parentc5a4f67e2083afdb74d66c1f985def080409bf1f (diff)
version 0.6.1HEAD0.6.1master
Diffstat (limited to 'tests/examples')
-rwxr-xr-xtests/examples/failing/dsrun010.hs25
-rwxr-xr-xtests/examples/ghc88/ClassParens.hs11
-rwxr-xr-xtests/examples/ghc88/DumpParsedAst.hs20
-rwxr-xr-xtests/examples/ghc88/EmptyCase008.hs55
-rwxr-xr-xtests/examples/ghc88/Exp.hs203
-rwxr-xr-xtests/examples/ghc88/ExplicitForAllRules1.hs46
-rwxr-xr-xtests/examples/ghc88/Internal.hs342
-rwxr-xr-xtests/examples/ghc88/PersistUniqueTest.hs45
-rwxr-xr-xtests/examples/ghc88/StarBinder.hs7
-rwxr-xr-xtests/examples/ghc88/T12045TH1.hs18
-rwxr-xr-xtests/examples/ghc88/T12045TH2.hs31
-rwxr-xr-xtests/examples/ghc88/T12045a.hs84
-rwxr-xr-xtests/examples/ghc88/T13087.hs9
-rwxr-xr-xtests/examples/ghc88/T15365.hs32
-rwxr-xr-xtests/examples/ghc88/T4437.hs57
-rwxr-xr-xtests/examples/ghc88/TH_recover_warns.hs11
-rwxr-xr-xtests/examples/ghc88/TH_recursiveDoImport.hs25
-rwxr-xr-xtests/examples/ghc88/TH_reifyDecl1.hs94
-rwxr-xr-xtests/examples/ghc88/Utils.hs1056
-rwxr-xr-xtests/examples/ghc88/hie010.hs24
20 files changed, 2195 insertions, 0 deletions
diff --git a/tests/examples/failing/dsrun010.hs b/tests/examples/failing/dsrun010.hs
new file mode 100755
index 0000000..1d4fc48
--- /dev/null
+++ b/tests/examples/failing/dsrun010.hs
@@ -0,0 +1,25 @@
+-- Check that pattern match failure in do-notation
+-- is reflected by calling the monadic 'fail', not by a
+-- runtime exception
+
+{-# LANGUAGE NoMonadFailDesugaring #-}
+{-# OPTIONS -Wno-missing-monadfail-instances #-}
+
+import Control.Monad
+import Data.Maybe
+
+test :: (MonadPlus m) => [a] -> m Bool
+test xs
+ = do
+ (_:_) <- return xs
+ -- Should fail here
+ return True
+ `mplus`
+ -- Failure in LH arg should trigger RH arg
+ do
+ return False
+
+main :: IO ()
+main
+ = do let x = fromJust (test [])
+ putStrLn (show x)
diff --git a/tests/examples/ghc88/ClassParens.hs b/tests/examples/ghc88/ClassParens.hs
new file mode 100755
index 0000000..4292fcc
--- /dev/null
+++ b/tests/examples/ghc88/ClassParens.hs
@@ -0,0 +1,11 @@
+module ClassParens where
+
+class LiftingMonad (trans :: MTrans) where
+ proof :: Monad m :- Monad (trans m)
+
+class LiftingMonad2 ((trans :: MTrans)) where
+ proof :: Monad m :- Monad (trans m)
+
+data Nat (t :: NatKind) where
+ ZeroNat :: Nat Zero
+ SuccNat :: Nat t -> Nat (Succ t)
diff --git a/tests/examples/ghc88/DumpParsedAst.hs b/tests/examples/ghc88/DumpParsedAst.hs
new file mode 100755
index 0000000..6c6684a
--- /dev/null
+++ b/tests/examples/ghc88/DumpParsedAst.hs
@@ -0,0 +1,20 @@
+{-# LANGUAGE DataKinds, PolyKinds, TypeOperators, TypeFamilies
+ , TypeApplications, TypeInType #-}
+
+module DumpParsedAst where
+import Data.Kind
+
+data Peano = Zero | Succ Peano
+
+type family Length (as :: [k]) :: Peano where
+ Length (a : as) = Succ (Length as)
+ Length '[] = Zero
+
+-- vis kind app
+data T f (a :: k) = MkT (f a)
+
+type family F1 (a :: k) (f :: k -> Type) :: Type where
+ F1 @Peano a f = T @Peano f a
+
+main = putStrLn "hello"
+
diff --git a/tests/examples/ghc88/EmptyCase008.hs b/tests/examples/ghc88/EmptyCase008.hs
new file mode 100755
index 0000000..359e757
--- /dev/null
+++ b/tests/examples/ghc88/EmptyCase008.hs
@@ -0,0 +1,55 @@
+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
+{-# LANGUAGE TypeFamilies, GADTs, EmptyCase, LambdaCase #-}
+
+-- Check interaction between Newtypes and DataFamilies
+module EmptyCase008 where
+
+import Data.Kind (Type)
+
+data family DA a
+
+newtype Foo3 a = Foo3 (DA a)
+
+data instance DA Int = MkDA1 Char | MkDA2
+
+-- Non-exhaustive. Missing: MkDA1 Char, MkDA2
+f11 :: Foo3 Int -> ()
+f11 = \case
+
+-- Non-exhaustive. (no info about a)
+f12 :: Foo3 a -> ()
+f12 = \case
+
+data instance DA () -- Empty data type
+
+-- Exhaustive.
+f13 :: Foo3 () -> ()
+f13 = \case
+
+-- ----------------
+data family DB a :: Type -> Type
+
+data instance DB Int a where
+ MkDB1 :: DB Int ()
+ MkDB2 :: DB Int Bool
+
+newtype Foo4 a b = Foo4 (DB a b)
+
+-- Non-exhaustive. Missing: Foo4 MkDB1
+f14 :: Foo4 Int () -> ()
+f14 = \case
+
+-- Exhaustive
+f15 :: Foo4 Int [a] -> ()
+f15 = \case
+
+-- Non-exhaustive. Missing: (_ :: Foo4 a b) (no information about a or b)
+f16 :: Foo4 a b -> ()
+f16 = \case
+
+data instance DB Char Bool -- Empty data type
+
+-- Exhaustive (empty data type)
+f17 :: Foo4 Char Bool -> ()
+f17 = \case
+
diff --git a/tests/examples/ghc88/Exp.hs b/tests/examples/ghc88/Exp.hs
new file mode 100755
index 0000000..5f91a36
--- /dev/null
+++ b/tests/examples/ghc88/Exp.hs
@@ -0,0 +1,203 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Data.Array.Accelerate.Utility.Lift.Exp (
+ Unlift,
+ Unlifted,
+ Tuple,
+ unlift,
+ modify,
+ modify2,
+ modify3,
+ modify4,
+ Exp(Exp), expr, atom,
+ unliftPair,
+ unliftTriple,
+ unliftQuadruple,
+ asExp,
+ mapFst,
+ mapSnd,
+ fst3,
+ snd3,
+ thd3,
+ indexCons,
+ ) where
+
+import qualified Data.Array.Accelerate.Data.Complex as Complex
+import qualified Data.Array.Accelerate as A
+import Data.Complex (Complex((:+)))
+import Data.Array.Accelerate ((:.)((:.)))
+
+import qualified Data.Tuple.HT as Tuple
+import Data.Tuple.HT (mapTriple)
+
+
+{- |
+This class simplifies untupling of expressions.
+If you have a function
+
+> g :: ((Exp a, Exp b), Exp (c,d)) -> (Exp e, Exp f)
+
+you cannot apply it to an array @arr :: Array sh ((a,b),(c,d))@ using 'A.map'.
+Here, the 'modify' function helps:
+
+> modify ((expr,expr),expr) g :: Exp ((a,b),(c,d)) -> Exp (e,f)
+
+The 'expr'-pattern tells, how deep the tuple shall be unlifted.
+This way you can write:
+
+> A.map
+> (Exp.modify ((expr,expr),expr) $ \((a,b), cd) -> g ((a,b), cd))
+> arr
+
+'modify' is based on 'unlift'.
+In contrast to 'A.unlift' it does not only unlift one level of tupels,
+but is guided by an 'expr'-pattern.
+In the example I have demonstrated,
+how the pair @(a,b)@ is unlifted, but the pair @(c,d)@ is not.
+For the result tuple, 'modify' simply calls 'A.lift'.
+In contrast to 'A.unlift',
+'A.lift' lifts over all tupel levels until it obtains a single 'Exp'.
+-}
+class
+ (A.Elt (Tuple pattern), A.Plain (Unlifted pattern) ~ Tuple pattern) =>
+ Unlift pattern where
+ type Unlifted pattern
+ type Tuple pattern
+ unlift :: pattern -> A.Exp (Tuple pattern) -> Unlifted pattern
+
+modify ::
+ (A.Lift A.Exp a, Unlift pattern) =>
+ pattern ->
+ (Unlifted pattern -> a) ->
+ A.Exp (Tuple pattern) -> A.Exp (A.Plain a)
+modify p f = A.lift . f . unlift p
+
+modify2 ::
+ (A.Lift A.Exp a, Unlift patternA, Unlift patternB) =>
+ patternA ->
+ patternB ->
+ (Unlifted patternA -> Unlifted patternB -> a) ->
+ A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) -> A.Exp (A.Plain a)
+modify2 pa pb f a b = A.lift $ f (unlift pa a) (unlift pb b)
+
+modify3 ::
+ (A.Lift A.Exp a, Unlift patternA, Unlift patternB, Unlift patternC) =>
+ patternA ->
+ patternB ->
+ patternC ->
+ (Unlifted patternA -> Unlifted patternB -> Unlifted patternC -> a) ->
+ A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) ->
+ A.Exp (Tuple patternC) -> A.Exp (A.Plain a)
+modify3 pa pb pc f a b c =
+ A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c)
+
+modify4 ::
+ (A.Lift A.Exp a,
+ Unlift patternA, Unlift patternB, Unlift patternC, Unlift patternD) =>
+ patternA ->
+ patternB ->
+ patternC ->
+ patternD ->
+ (Unlifted patternA -> Unlifted patternB ->
+ Unlifted patternC -> Unlifted patternD -> a) ->
+ A.Exp (Tuple patternA) -> A.Exp (Tuple patternB) ->
+ A.Exp (Tuple patternC) -> A.Exp (Tuple patternD) -> A.Exp (A.Plain a)
+modify4 pa pb pc pd f a b c d =
+ A.lift $ f (unlift pa a) (unlift pb b) (unlift pc c) (unlift pd d)
+
+
+instance (A.Elt a) => Unlift (Exp a) where
+ type Unlifted (Exp a) = A.Exp a
+ type Tuple (Exp a) = a
+ unlift _ = id
+
+data Exp e = Exp
+
+expr :: Exp e
+expr = Exp
+
+{-# DEPRECATED atom "use expr instead" #-}
+-- | for compatibility with accelerate-utility-0.0
+atom :: Exp e
+atom = expr
+
+
+instance (Unlift pa, Unlift pb) => Unlift (pa,pb) where
+ type Unlifted (pa,pb) = (Unlifted pa, Unlifted pb)
+ type Tuple (pa,pb) = (Tuple pa, Tuple pb)
+ unlift (pa,pb) ab =
+ (unlift pa $ A.fst ab, unlift pb $ A.snd ab)
+
+instance
+ (Unlift pa, Unlift pb, Unlift pc) =>
+ Unlift (pa,pb,pc) where
+ type Unlifted (pa,pb,pc) = (Unlifted pa, Unlifted pb, Unlifted pc)
+ type Tuple (pa,pb,pc) = (Tuple pa, Tuple pb, Tuple pc)
+ unlift (pa,pb,pc) =
+ mapTriple (unlift pa, unlift pb, unlift pc) . A.unlift
+
+
+instance (Unlift pa, A.Slice (Tuple pa), int ~ Exp Int) => Unlift (pa :. int) where
+ type Unlifted (pa :. int) = Unlifted pa :. A.Exp Int
+ type Tuple (pa :. int) = Tuple pa :. Int
+ unlift (pa:.pb) ab =
+ (unlift pa $ A.indexTail ab) :. (unlift pb $ A.indexHead ab)
+
+
+instance (Unlift p) => Unlift (Complex p) where
+ type Unlifted (Complex p) = Complex (Unlifted p)
+ type Tuple (Complex p) = Complex (Tuple p)
+ unlift (preal:+pimag) z =
+ unlift preal (Complex.real z)
+ :+
+ unlift pimag (Complex.imag z)
+
+
+unliftPair :: (A.Elt a, A.Elt b) => A.Exp (a,b) -> (A.Exp a, A.Exp b)
+unliftPair = A.unlift
+
+unliftTriple ::
+ (A.Elt a, A.Elt b, A.Elt c) => A.Exp (a,b,c) -> (A.Exp a, A.Exp b, A.Exp c)
+unliftTriple = A.unlift
+
+unliftQuadruple ::
+ (A.Elt a, A.Elt b, A.Elt c, A.Elt d) =>
+ A.Exp (a,b,c,d) -> (A.Exp a, A.Exp b, A.Exp c, A.Exp d)
+unliftQuadruple = A.unlift
+
+asExp :: A.Exp a -> A.Exp a
+asExp = id
+
+mapFst ::
+ (A.Elt a, A.Elt b, A.Elt c) =>
+ (A.Exp a -> A.Exp b) -> A.Exp (a,c) -> A.Exp (b,c)
+mapFst f = modify (expr,expr) $ \(a,c) -> (f a, c)
+
+mapSnd ::
+ (A.Elt a, A.Elt b, A.Elt c) =>
+ (A.Exp b -> A.Exp c) -> A.Exp (a,b) -> A.Exp (a,c)
+mapSnd f = modify (expr,expr) $ \(a,b) -> (a, f b)
+
+
+fst3 ::
+ (A.Elt a, A.Elt b, A.Elt c) =>
+ A.Exp (a,b,c) -> A.Exp a
+fst3 = modify (expr,expr,expr) Tuple.fst3
+
+snd3 ::
+ (A.Elt a, A.Elt b, A.Elt c) =>
+ A.Exp (a,b,c) -> A.Exp b
+snd3 = modify (expr,expr,expr) Tuple.snd3
+
+thd3 ::
+ (A.Elt a, A.Elt b, A.Elt c) =>
+ A.Exp (a,b,c) -> A.Exp c
+thd3 = modify (expr,expr,expr) Tuple.thd3
+
+
+
+indexCons ::
+ (A.Slice ix) => A.Exp ix -> A.Exp Int -> A.Exp (ix :. Int)
+indexCons ix n = A.lift $ ix:.n
+
diff --git a/tests/examples/ghc88/ExplicitForAllRules1.hs b/tests/examples/ghc88/ExplicitForAllRules1.hs
new file mode 100755
index 0000000..f771735
--- /dev/null
+++ b/tests/examples/ghc88/ExplicitForAllRules1.hs
@@ -0,0 +1,46 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeInType #-}
+{-# LANGUAGE TypeApplications #-}
+
+module ExplicitForAllRules1 where
+
+import Data.Proxy
+import Data.Kind
+
+-- From Proposal 0007 (w/ fix to "example")
+
+{-# RULES
+"example" forall a b. forall. map @a @b f = f
+"example2" forall a. forall (x :: a). id x = x
+ #-}
+
+{-# NOINLINE f #-}
+f :: a -> b
+f = undefined
+
+-- More tests
+
+{-# RULES
+"example3" forall (a :: Type -> Type) (b :: a Int) c. forall x y. g @(Proxy b) @(Proxy c) x y = ()
+"example4" forall (a :: Bool) (b :: Proxy a). forall x. g @(Proxy b) @() x = id @()
+"example5" forall (a :: Type). forall. h @a = id @a
+"example5" forall k (c :: k). forall (x :: Proxy c). id @(Proxy c) x = x
+ #-}
+
+{-# NOINLINE g #-}
+g :: a -> b -> ()
+g _ _ = ()
+
+{-# NOINLINE h #-}
+h :: a -> a
+h x = x
+
+-- Should NOT have a parse error :(
+{-# RULES "example6" forall a forall. g a forall = () #-}
+
+-- Should generate a warning
+{-# RULES "example7" forall a b. forall (x :: a). id x = x #-}
+
diff --git a/tests/examples/ghc88/Internal.hs b/tests/examples/ghc88/Internal.hs
new file mode 100755
index 0000000..c848e03
--- /dev/null
+++ b/tests/examples/ghc88/Internal.hs
@@ -0,0 +1,342 @@
+{-# language GADTs, RankNTypes #-}
+{-# language FlexibleContexts, DefaultSignatures #-}
+{-# language TypeOperators #-}
+{-# language LambdaCase #-}
+{-# language EmptyCase #-}
+module Hedgehog.Function.Internal where
+
+import Control.Monad.Trans.Maybe (MaybeT(..))
+import Data.Bifunctor (first)
+import Data.Functor.Contravariant (Contravariant(..))
+import Data.Functor.Contravariant.Divisible (Divisible(..), Decidable(..))
+import Data.Functor.Identity (Identity(..))
+import Data.Int (Int8, Int16, Int32, Int64)
+import Data.Maybe (fromJust)
+import Data.Void (Void, absurd)
+import Data.Word (Word8, Word64)
+import Hedgehog.Internal.Gen (GenT(..), Gen, runGenT)
+import Hedgehog.Internal.Seed (Seed(..))
+import Hedgehog.Internal.Tree (Tree(..), Node(..))
+import Hedgehog.Internal.Property (PropertyT, forAll)
+
+import GHC.Generics
+
+import qualified Hedgehog.Internal.Tree as Tree
+
+infixr 5 :->
+
+-- | Shrinkable, showable functions
+--
+-- Claessen, K. (2012, September). Shrinking and showing functions:(functional pearl).
+-- In ACM SIGPLAN Notices (Vol. 47, No. 12, pp. 73-80). ACM.
+data a :-> c where
+ Unit :: c -> () :-> c
+ Nil :: a :-> c
+ Pair :: a :-> b :-> c -> (a, b) :-> c
+ Sum :: a :-> c -> b :-> c -> Either a b :-> c
+ Map :: (a -> b) -> (b -> a) -> b :-> c -> a :-> c
+
+instance Functor ((:->) r) where
+ fmap f (Unit c) = Unit $ f c
+ fmap _ Nil = Nil
+ fmap f (Pair a) = Pair $ fmap (fmap f) a
+ fmap f (Sum a b) = Sum (fmap f a) (fmap f b)
+ fmap f (Map a b c) = Map a b (fmap f c)
+
+-- | Tabulate the function
+table :: a :-> c -> [(a, c)]
+table (Unit c) = [((), c)]
+table Nil = []
+table (Pair f) = do
+ (a, bc) <- table f
+ (b, c) <- table bc
+ pure ((a, b), c)
+table (Sum a b) =
+ [(Left x, c) | (x, c) <- table a] ++
+ [(Right x, c) | (x, c) <- table b]
+table (Map _ g a) = first g <$> table a
+
+class GArg a where
+ gbuild' :: (a x -> c) -> a x :-> c
+
+-- | Reify a function whose domain has an instance of 'Generic'
+gbuild :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c
+gbuild = gvia from to
+
+-- | @instance Arg A where@ allows functions which take @A@s to be reified
+class Arg a where
+ build :: (a -> c) -> a :-> c
+ default build :: (Generic a, GArg (Rep a)) => (a -> c) -> a :-> c
+ build = gbuild
+
+variant :: Word64 -> GenT m b -> GenT m b
+variant n (GenT f) = GenT $ \sz sd -> f sz (sd { seedValue = seedValue sd + n})
+
+variant' :: Word64 -> CoGenT m b -> CoGenT m b
+variant' n (CoGenT f) =
+ CoGenT $ \a -> variant n . f a
+
+class GVary a where
+ gvary' :: CoGenT m (a x)
+
+instance GVary V1 where
+ gvary' = conquer
+
+instance GVary U1 where
+ gvary' = conquer
+
+instance (GVary a, GVary b) => GVary (a :+: b) where
+ gvary' =
+ choose
+ (\case; L1 a -> Left a; R1 a -> Right a)
+ (variant' 0 gvary')
+ (variant' 1 gvary')
+
+instance (GVary a, GVary b) => GVary (a :*: b) where
+ gvary' =
+ divide
+ (\(a :*: b) -> (a, b))
+ (variant' 0 gvary')
+ (variant' 1 gvary')
+
+instance GVary c => GVary (M1 a b c) where
+ gvary' = contramap unM1 gvary'
+
+instance Vary b => GVary (K1 a b) where
+ gvary' = contramap unK1 vary
+
+-- | Build a co-generator for a type which has a 'Generic' instance
+gvary :: (Generic a, GVary (Rep a)) => CoGenT m a
+gvary = CoGenT $ \a -> applyCoGenT gvary' (from a)
+
+-- | 'Vary' provides a canonical co-generator for a type.
+--
+-- While technically there are many possible co-generators for a given type, we don't get any
+-- benefit from caring.
+class Vary a where
+ vary :: CoGenT m a
+ default vary :: (Generic a, GVary (Rep a)) => CoGenT m a
+ vary = gvary
+
+-- | Build a co-generator for an 'Integral' type
+varyIntegral :: Integral a => CoGenT m a
+varyIntegral = CoGenT $ variant . fromIntegral
+
+-- |
+-- A @'CoGenT' m a@ is used to perturb a @'GenT' m b@ based on the value of the @a@. This way,
+-- the generated function will have a varying (but still deterministic) right hand side.
+--
+-- Co-generators can be built using 'Divisible' and 'Decidable', but it is recommended to
+-- derive 'Generic' and use the default instance of the 'Vary' type class.
+--
+-- @'CoGenT' m ~ 'Data.Functor.Contravariabe.Op' ('Data.Monoid.Endo' ('GenT' m b))@
+newtype CoGenT m a = CoGenT { applyCoGenT :: forall b. a -> GenT m b -> GenT m b }
+type CoGen = CoGenT Identity
+
+instance Contravariant (CoGenT m) where
+ contramap f (CoGenT g) = CoGenT (g . f)
+
+instance Divisible (CoGenT m) where
+ divide f (CoGenT gb) (CoGenT gc) =
+ CoGenT $ \a ->
+ let (b, c) = f a in gc c . gb b
+ conquer = CoGenT $ const id
+
+instance Decidable (CoGenT m) where
+ choose f (CoGenT gb) (CoGenT gc) =
+ CoGenT $ \a ->
+ case f a of
+ Left b -> gb b . variant 0
+ Right c -> gc c . variant 1
+ lose f = CoGenT $ \a -> absurd (f a)
+
+instance (Show a, Show b) => Show (a :-> b) where
+ show = show . table
+
+-- | Evaluate a possibly partial function
+apply' :: a :-> b -> a -> Maybe b
+apply' (Unit c) () = Just c
+apply' Nil _ = Nothing
+apply' (Pair f) (a, b) = do
+ f' <- apply' f a
+ apply' f' b
+apply' (Sum f _) (Left a) = apply' f a
+apply' (Sum _ g) (Right a) = apply' g a
+apply' (Map f _ g) a = apply' g (f a)
+
+-- | Evaluate a total function. Unsafe.
+unsafeApply :: a :-> b -> a -> b
+unsafeApply f = fromJust . apply' f
+
+-- | The type of randomly-generated functions
+data Fn a b = Fn b (a :-> Tree (MaybeT Identity) b)
+
+-- | Extract the root value from a 'Tree'. Unsafe.
+unsafeFromTree :: Functor m => Tree (MaybeT m) a -> m a
+unsafeFromTree =
+ fmap (maybe (error "empty generator in function") nodeValue) .
+ runMaybeT .
+ runTree
+
+instance (Show a, Show b) => Show (Fn a b) where
+ show (Fn b a) =
+ case table a of
+ [] -> "_ -> " ++ show b
+ ta -> showTable ta ++ "_ -> " ++ show b
+ where
+ showTable :: (Show a, Show b) => [(a, Tree (MaybeT Identity) b)] -> String
+ showTable [] = "<empty function>\n"
+ showTable (x : xs) = unlines (showCase <$> x : xs)
+ where
+ showCase (lhs, rhs) = show lhs ++ " -> " ++ show (runIdentity $ unsafeFromTree rhs)
+
+-- | Shrink the function
+shrinkFn :: (b -> [b]) -> a :-> b -> [a :-> b]
+shrinkFn shr (Unit a) = Unit <$> shr a
+shrinkFn _ Nil = []
+shrinkFn shr (Pair f) =
+ (\case; Nil -> Nil; a -> Pair a) <$> shrinkFn (shrinkFn shr) f
+shrinkFn shr (Sum a b) =
+ fmap (\case; Sum Nil Nil -> Nil; x -> x) $
+ [ Sum a Nil | notNil b ] ++
+ [ Sum Nil b | notNil a ] ++
+ fmap (`Sum` b) (shrinkFn shr a) ++
+ fmap (a `Sum`) (shrinkFn shr b)
+ where
+ notNil Nil = False
+ notNil _ = True
+shrinkFn shr (Map f g a) = (\case; Nil -> Nil; x -> Map f g x) <$> shrinkFn shr a
+
+shrinkTree :: Monad m => Tree (MaybeT m) a -> m [Tree (MaybeT m) a]
+shrinkTree (Tree m) = do
+ a <- runMaybeT m
+ case a of
+ Nothing -> pure []
+ Just (Node _ cs) -> pure cs
+
+-- | Evaluate an 'Fn'
+apply :: Fn a b -> a -> b
+apply (Fn b f) = maybe b (runIdentity . unsafeFromTree) . apply' f
+
+-- | Generate a function using the user-supplied co-generator
+fnWith :: Arg a => CoGen a -> Gen b -> Gen (Fn a b)
+fnWith cg gb =
+ Fn <$>
+ gb <*>
+ genFn (\a -> applyCoGenT cg a gb)
+ where
+ genFn :: Arg a => (a -> Gen b) -> Gen (a :-> Tree (MaybeT Identity) b)
+ genFn g =
+ GenT $ \sz sd ->
+ Tree.unfold (shrinkFn $ runIdentity . shrinkTree) .
+ fmap (runGenT sz sd) $ build g
+
+-- | Generate a function
+fn :: (Arg a, Vary a) => Gen b -> Gen (Fn a b)
+fn = fnWith vary
+
+-- | Run the function generator to retrieve a function
+forAllFn :: (Show a, Show b, Monad m) => Gen (Fn a b) -> PropertyT m (a -> b)
+forAllFn = fmap apply . forAll
+
+instance Vary ()
+instance (Vary a, Vary b) => Vary (Either a b)
+instance (Vary a, Vary b) => Vary (a, b)
+instance Vary Void
+instance Vary Bool
+instance Vary Ordering
+instance Vary a => Vary (Maybe a)
+instance Vary a => Vary [a]
+instance Vary Int8 where; vary = varyIntegral
+instance Vary Int16 where; vary = varyIntegral
+instance Vary Int32 where; vary = varyIntegral
+instance Vary Int64 where; vary = varyIntegral
+instance Vary Int where; vary = varyIntegral
+instance Vary Integer where; vary = varyIntegral
+instance Vary Word8 where; vary = varyIntegral
+
+-- | Reify a function via an isomorphism.
+--
+-- If your function's domain has no instance of 'Generic' then you can still reify it using
+-- an isomorphism to a better domain type. For example, the 'Arg' instance for 'Integral'
+-- uses an isomorphism from @Integral a => a@ to @(Bool, [Bool])@, where the first element
+-- is the sign, and the second element is the bit-string.
+--
+-- Note: @via f g@ will only be well-behaved if @g . f = id@ and @f . g = id@
+via :: Arg b => (a -> b) -> (b -> a) -> (a -> c) -> a :-> c
+via a b f = Map a b . build $ f . b
+
+instance Arg Void where
+ build _ = Nil
+
+instance Arg () where
+ build f = Unit $ f ()
+
+instance (Arg a, Arg b) => Arg (a, b) where
+ build f = Pair . build $ \a -> build $ \b -> f (a, b)
+
+instance (Arg a, Arg b) => Arg (Either a b) where
+ build f = Sum (build $ f . Left) (build $ f . Right)
+
+gvia :: GArg b => (a -> b x) -> (b x -> a) -> (a -> c) -> a :-> c
+gvia a b f = Map a b . gbuild' $ f . b
+
+instance GArg V1 where
+ gbuild' _ = Nil
+
+instance GArg U1 where
+ gbuild' f = Map (\U1 -> ()) (\() -> U1) (Unit $ f U1)
+
+instance (GArg a, GArg b) => GArg (a :*: b) where
+ gbuild' f = Map fromPair toPair $ Pair . gbuild' $ \a -> gbuild' $ \b -> f (a :*: b)
+ where
+ fromPair (a :*: b) = (a, b)
+ toPair (a, b) = (a :*: b)
+
+instance (GArg a, GArg b) => GArg (a :+: b) where
+ gbuild' f = Map fromSum toSum $ Sum (gbuild' $ f . L1) (gbuild' $ f . R1)
+ where
+ fromSum = \case; L1 a -> Left a; R1 a -> Right a
+ toSum = either L1 R1
+
+instance GArg c => GArg (M1 a b c) where
+ gbuild' = gvia unM1 M1
+
+instance Arg b => GArg (K1 a b) where
+ gbuild' f = Map unK1 K1 . build $ f . K1
+
+-- | Reify a function on 'Integral's
+buildIntegral :: (Arg a, Integral a) => (a -> c) -> (a :-> c)
+buildIntegral = via toBits fromBits
+ where
+ toBits :: Integral a => a -> (Bool, [Bool])
+ toBits n
+ | n >= 0 = (True, go n)
+ | otherwise = (False, go $ -n - 1)
+ where
+ go 0 = []
+ go m =
+ let
+ (q, r) = quotRem m 2
+ in
+ (r == 1) : go q
+
+ fromBits :: Integral a => (Bool, [Bool]) -> a
+ fromBits (pos, bts)
+ | pos = go bts
+ | otherwise = negate $ go bts + 1
+ where
+ go [] = 0
+ go (x:xs) = (if x then 1 else 0) + 2 * go xs
+
+instance Arg Bool
+instance Arg Ordering
+instance Arg a => Arg (Maybe a)
+instance Arg a => Arg [a]
+instance Arg Int8 where; build = buildIntegral
+instance Arg Int16 where; build = buildIntegral
+instance Arg Int32 where; build = buildIntegral
+instance Arg Int64 where; build = buildIntegral
+instance Arg Int where; build = buildIntegral
+instance Arg Integer where; build = buildIntegral
+
diff --git a/tests/examples/ghc88/PersistUniqueTest.hs b/tests/examples/ghc88/PersistUniqueTest.hs
new file mode 100755
index 0000000..9a60a6d
--- /dev/null
+++ b/tests/examples/ghc88/PersistUniqueTest.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE QuasiQuotes, TemplateHaskell, CPP, GADTs, TypeFamilies, OverloadedStrings, FlexibleContexts, EmptyDataDecls, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}
+module PersistUniqueTest where
+
+import Init
+
+-- mpsGeneric = False is due to a bug or at least lack of a feature in mkKeyTypeDec TH.hs
+#if WITH_NOSQL
+mkPersist persistSettings { mpsGeneric = False } [persistUpperCase|
+#else
+share [mkPersist persistSettings { mpsGeneric = False }, mkMigrate "migration"] [persistLowerCase|
+#endif
+ Fo
+ foo Int
+ bar Int
+ Primary foo
+ UniqueBar bar
+ deriving Eq Show
+|]
+#ifdef WITH_NOSQL
+cleanDB :: (MonadIO m, PersistQuery backend, PersistEntityBackend Fo ~ backend) => ReaderT backend m ()
+cleanDB = do
+ deleteWhere ([] :: [Filter Fo])
+
+db :: Action IO () -> Assertion
+db = db' cleanDB
+#endif
+
+specs :: Spec
+specs = describe "custom primary key" $ do
+#ifdef WITH_NOSQL
+ return ()
+#else
+ it "getBy" $ db $ do
+ let b = 5
+ k <- insert $ Fo 3 b
+ Just vk <- get k
+ Just vu <- getBy (UniqueBar b)
+ vu @== Entity k vk
+ it "insertUniqueEntity" $ db $ do
+ let fo = Fo 3 5
+ Just (Entity _ insertedFoValue) <- insertUniqueEntity fo
+ Nothing <- insertUniqueEntity fo
+ fo @== insertedFoValue
+#endif
+
diff --git a/tests/examples/ghc88/StarBinder.hs b/tests/examples/ghc88/StarBinder.hs
new file mode 100755
index 0000000..7f2b8a6
--- /dev/null
+++ b/tests/examples/ghc88/StarBinder.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TypeOperators, TypeFamilies #-}
+{-# OPTIONS -Wno-star-is-type #-}
+
+module X (type (X.*)) where
+
+type family (*) a b where { (*) a b = Either b a }
+
diff --git a/tests/examples/ghc88/T12045TH1.hs b/tests/examples/ghc88/T12045TH1.hs
new file mode 100755
index 0000000..715678a
--- /dev/null
+++ b/tests/examples/ghc88/T12045TH1.hs
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds
+ , TypeInType, TypeApplications, TypeFamilies #-}
+
+module T12045TH1 where
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+
+$([d| type family F (a :: k) :: Type where
+ F @Type Int = Bool
+ F @(Type->Type) Maybe = Char |])
+
+
+$([d| data family D (a :: k) |])
+
+$([d| data instance D @Type a = DBool |])
+
+$([d| data instance D @(Type -> Type) b = DChar |])
+
diff --git a/tests/examples/ghc88/T12045TH2.hs b/tests/examples/ghc88/T12045TH2.hs
new file mode 100755
index 0000000..c13b9c4
--- /dev/null
+++ b/tests/examples/ghc88/T12045TH2.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE TemplateHaskell, TypeApplications, PolyKinds
+ , TypeFamilies, DataKinds #-}
+
+module T12045TH2 where
+
+import Data.Kind
+import Language.Haskell.TH hiding (Type)
+import System.IO
+
+type family Foo (a :: k) :: Type where
+ Foo @Type a = Bool
+
+type family Baz (a :: k)
+type instance Baz @(Type->Type->Type) a = Char
+
+$( do FamilyI foo@(ClosedTypeFamilyD (TypeFamilyHead _ tvbs1 res1 m_kind1)
+ [TySynEqn (Just bndrs1) (AppT _ lhs1) rhs1])
+ [] <- reify ''Foo
+ FamilyI baz@(OpenTypeFamilyD (TypeFamilyHead _ tvbs2 res2 m_kind2))
+ [inst@(TySynInstD (TySynEqn (Just bndrs2) (AppT _ lhs2) rhs2))] <- reify ''Baz
+ runIO $ putStrLn $ pprint foo
+ runIO $ putStrLn $ pprint baz
+ runIO $ putStrLn $ pprint inst
+ runIO $ hFlush stdout
+ return [ ClosedTypeFamilyD
+ (TypeFamilyHead (mkName "Foo'") tvbs1 res1 m_kind1)
+ [TySynEqn (Just bndrs1) (AppT (ConT (mkName "Foo'")) lhs1) rhs1]
+ , OpenTypeFamilyD
+ (TypeFamilyHead (mkName "Baz'") tvbs2 res2 m_kind2)
+ , TySynInstD (TySynEqn (Just bndrs2) (AppT (ConT (mkName "Baz'")) lhs2) rhs2)] )
+
diff --git a/tests/examples/ghc88/T12045a.hs b/tests/examples/ghc88/T12045a.hs
new file mode 100755
index 0000000..7a0697e
--- /dev/null
+++ b/tests/examples/ghc88/T12045a.hs
@@ -0,0 +1,84 @@
+{-# LANGUAGE PolyKinds, GADTs, TypeApplications, TypeInType, DataKinds,
+ RankNTypes, ConstraintKinds, TypeFamilies #-}
+
+module T12045a where
+
+import Data.Kind
+import Data.Typeable
+
+data T (f :: k -> Type) a = MkT (f a)
+
+newtype TType f a= MkTType (T @Type f a)
+
+t1 :: TType Maybe Bool
+t1 = MkTType (MkT (Just True))
+
+t2 :: TType Maybe a
+t2 = MkTType (MkT Nothing)
+
+data Nat = O | S Nat
+
+data T1 :: forall k1 k2. k1 -> k2 -> Type where
+ MkT1 :: T1 a b
+
+x :: T1 @_ @Nat False n
+x = MkT1
+
+-- test from trac 12045
+type Cat k = k -> k -> Type
+
+data FreeCat :: Cat k -> Cat k where
+ Nil :: FreeCat f a a
+ Cons :: f a b -> FreeCat f b c -> FreeCat f a c
+
+liftCat :: f a b -> FreeCat f a b
+liftCat x = Cons x Nil
+
+data Node = Unit | N
+
+data NatGraph :: Cat Node where
+ One :: NatGraph Unit N
+ Succ :: NatGraph N N
+
+one :: (FreeCat @Node NatGraph) Unit N
+one = liftCat One
+
+type Typeable1 = Typeable @(Type -> Type)
+type Typeable2 = Typeable @(Type -> Type -> Type)
+type Typeable3 = Typeable @(Cat Bool)
+
+type family F a where
+ F Type = Type -> Type
+ F (Type -> Type) = Type
+ F other = other
+
+data T2 :: F k -> Type
+
+foo :: T2 @Type Maybe -> T2 @(Type -> Type) Int -> Type
+foo a b = undefined
+
+data family D (a :: k)
+data instance D @Type a = DBool
+data instance D @(Type -> Type) b = DChar
+
+class C a where
+ tc :: (D a) -> Int
+
+instance C Int where
+ tc DBool = 5
+
+instance C Bool where
+ tc DBool = 6
+
+instance C Maybe where
+ tc DChar = 7
+
+-- Tests from D5229
+data P a = MkP
+type MkPTrue = MkP @Bool
+
+type BoolEmpty = '[] @Bool
+
+type family F1 (a :: k) :: Type
+type G2 (a :: Bool) = F1 @Bool a
+
diff --git a/tests/examples/ghc88/T13087.hs b/tests/examples/ghc88/T13087.hs
new file mode 100755
index 0000000..44ec086
--- /dev/null
+++ b/tests/examples/ghc88/T13087.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE AlternativeLayoutRule #-}
+{-# LANGUAGE LambdaCase #-}
+
+isOne :: Int -> Bool
+isOne = \case 1 -> True
+ _ -> False
+
+main = return ()
+
diff --git a/tests/examples/ghc88/T15365.hs b/tests/examples/ghc88/T15365.hs
new file mode 100755
index 0000000..91a9499
--- /dev/null
+++ b/tests/examples/ghc88/T15365.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE RoleAnnotations #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+module T15365 where
+
+$([d| type (|||) = Either
+
+ (&&&) :: Bool -> Bool -> Bool
+ (&&&) = (&&)
+
+ type role (***)
+ data (***)
+
+ class (???)
+ instance (???)
+
+ data family ($$$)
+ data instance ($$$)
+
+ type family (^^^)
+ type instance (^^^) = Int
+
+ type family (###) where
+ (###) = Int
+
+ pattern (:!!!) :: Bool
+ pattern (:!!!) = True
+ |])
+
diff --git a/tests/examples/ghc88/T4437.hs b/tests/examples/ghc88/T4437.hs
new file mode 100755
index 0000000..da2de38
--- /dev/null
+++ b/tests/examples/ghc88/T4437.hs
@@ -0,0 +1,57 @@
+-- | A test for ensuring that GHC's supporting language extensions remains in
+-- sync with Cabal's own extension list.
+--
+-- If you have ended up here due to a test failure, please see
+-- Note [Adding a language extension] in compiler/main/DynFlags.hs.
+
+module Main (main) where
+
+import Control.Monad
+import Data.List
+import DynFlags
+import Language.Haskell.Extension
+
+main :: IO ()
+main = do
+ let ghcExtensions = map flagSpecName xFlags
+ cabalExtensions = map show [ toEnum 0 :: KnownExtension .. ]
+ ghcOnlyExtensions = ghcExtensions \\ cabalExtensions
+ cabalOnlyExtensions = cabalExtensions \\ ghcExtensions
+ check "GHC-only flags" expectedGhcOnlyExtensions ghcOnlyExtensions
+ check "Cabal-only flags" expectedCabalOnlyExtensions cabalOnlyExtensions
+
+check :: String -> [String] -> [String] -> IO ()
+check title expected got
+ = do let unexpected = got \\ expected
+ missing = expected \\ got
+ showProblems problemType problems
+ = unless (null problems) $
+ do putStrLn (title ++ ": " ++ problemType)
+ putStrLn "-----"
+ mapM_ putStrLn problems
+ putStrLn "-----"
+ putStrLn ""
+ showProblems "Unexpected flags" unexpected
+ showProblems "Missing flags" missing
+
+-- See Note [Adding a language extension] in compiler/main/DynFlags.hs.
+expectedGhcOnlyExtensions :: [String]
+expectedGhcOnlyExtensions = ["RelaxedLayout",
+ "AlternativeLayoutRule",
+ "AlternativeLayoutRuleTransitional",
+ "EmptyDataDeriving",
+ "GeneralisedNewtypeDeriving"]
+
+expectedCabalOnlyExtensions :: [String]
+expectedCabalOnlyExtensions = ["Generics",
+ "ExtensibleRecords",
+ "RestrictedTypeSynonyms",
+ "HereDocuments",
+ "NewQualifiedOperators",
+ "XmlSyntax",
+ "RegularPatterns",
+ "SafeImports",
+ "Safe",
+ "Unsafe",
+ "Trustworthy"]
+
diff --git a/tests/examples/ghc88/TH_recover_warns.hs b/tests/examples/ghc88/TH_recover_warns.hs
new file mode 100755
index 0000000..c502712
--- /dev/null
+++ b/tests/examples/ghc88/TH_recover_warns.hs
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wall #-}
+module Bug where
+
+import Language.Haskell.TH
+
+-- Warnings should be preserved through recover
+main :: IO ()
+main = putStrLn $(recover (stringE "splice failed")
+ [| let x = "a" in let x = "b" in x |])
+
diff --git a/tests/examples/ghc88/TH_recursiveDoImport.hs b/tests/examples/ghc88/TH_recursiveDoImport.hs
new file mode 100755
index 0000000..ce30338
--- /dev/null
+++ b/tests/examples/ghc88/TH_recursiveDoImport.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_recursiveDoImport where
+import Data.IORef
+import Language.Haskell.TH
+
+data SelfRef = SelfRef (IORef (IORef SelfRef))
+
+recIO :: ExpQ
+recIO = [e|
+ do rec r1 <- newIORef r2
+ r2 <- newIORef (SelfRef r1)
+ readIORef r2 |]
+
+mdoIO :: ExpQ
+mdoIO = [e|
+ mdo r1 <- return r2
+ r2 <- return (const 1 r1)
+ return r1 |]
+
+emptyRecIO :: ExpQ
+emptyRecIO = [e|
+ do rec {}
+ return () |]
+
diff --git a/tests/examples/ghc88/TH_reifyDecl1.hs b/tests/examples/ghc88/TH_reifyDecl1.hs
new file mode 100755
index 0000000..076b6e4
--- /dev/null
+++ b/tests/examples/ghc88/TH_reifyDecl1.hs
@@ -0,0 +1,94 @@
+-- test reification of data declarations
+
+{-# LANGUAGE TypeFamilies, TypeApplications, PolyKinds #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_reifyDecl1 where
+
+import Data.Kind as K
+import System.IO
+import Language.Haskell.TH
+import Text.PrettyPrint.HughesPJ
+
+infixl 3 `m1`
+
+-- simple
+data T = A | B
+
+-- parametric
+data R a = C a | D
+
+-- recursive
+data List a = Nil | Cons a (List a)
+
+-- infix operator
+data Tree a = Leaf | Tree a :+: Tree a
+
+-- type declaration
+type IntList = [Int]
+
+-- newtype declaration
+newtype Length = Length Int
+
+-- simple class
+class C1 a where
+ m1 :: a -> Int
+
+-- class with instances
+class C2 a where
+ m2 :: a -> Int
+instance C2 Int where
+ m2 x = x
+
+-- associated types
+class C3 a where
+ type AT1 a
+ data AT2 a
+
+instance C3 Int where
+ type AT1 Int = Bool
+ data AT2 Int = AT2Int
+
+-- type family
+type family TF1 a
+
+-- type family, with instances
+type family TF2 a
+type instance TF2 Bool = Bool
+
+-- data family
+data family DF1 a
+
+-- data family, with instances
+data family DF2 a
+data instance DF2 Bool = DBool
+
+data family DF3 (a :: k)
+data instance DF3 @K.Type a = DF3Bool
+data instance DF3 @(K.Type -> K.Type) b = DF3Char
+
+$(return [])
+
+test :: ()
+test = $(let
+ display :: Name -> Q ()
+ display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) }
+ in do { display ''T
+ ; display ''R
+ ; display ''List
+ ; display ''Tree
+ ; display ''IntList
+ ; display ''Length
+ ; display 'Leaf
+ ; display 'm1
+ ; display ''C1
+ ; display ''C2
+ ; display ''C3
+ ; display ''AT1
+ ; display ''AT2
+ ; display ''TF1
+ ; display ''TF2
+ ; display ''DF1
+ ; display ''DF2
+ ; display ''DF3
+ ; [| () |] })
+
diff --git a/tests/examples/ghc88/Utils.hs b/tests/examples/ghc88/Utils.hs
new file mode 100755
index 0000000..fdd7bea
--- /dev/null
+++ b/tests/examples/ghc88/Utils.hs
@@ -0,0 +1,1056 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module : Distribution.Simple.Utils
+-- Copyright : Isaac Jones, Simon Marlow 2003-2004
+-- portions Copyright (c) 2007, Galois Inc.
+--
+-- Maintainer : cabal-devel@haskell.org
+-- Portability : portable
+--
+-- A large and somewhat miscellaneous collection of utility functions used
+-- throughout the rest of the Cabal lib and in other tools that use the Cabal
+-- lib like @cabal-install@. It has a very simple set of logging actions. It
+-- has low level functions for running programs, a bunch of wrappers for
+-- various directory and file functions that do extra logging.
+
+{- All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of Isaac Jones nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}
+
+module Distribution.Simple.Utils (
+ -- * logging and errors
+ die,
+ dieWithLocation,
+ topHandler,
+ warn, notice, info, debug,
+ debugNoWrap, chattyTry,
+
+ -- * running programs
+ rawSystemExit,
+ rawSystemExitCode,
+ rawSystemExitWithEnv,
+ rawSystemStdout,
+ rawSystemStdInOut,
+ rawSystemIOWithEnv,
+ maybeExit,
+ xargs,
+ findProgramLocation,
+
+ -- * copying files
+ createDirectoryIfMissingVerbose,
+ copyFileVerbose,
+ copyDirectoryRecursiveVerbose,
+ copyFiles,
+
+ -- * installing files
+ installOrdinaryFile,
+ installExecutableFile,
+ installOrdinaryFiles,
+ installDirectoryContents,
+
+ -- * File permissions
+ setFileOrdinary,
+ setFileExecutable,
+
+ -- * file names
+ currentDir,
+
+ -- * finding files
+ findFile,
+ findFirstFile,
+ findFileWithExtension,
+ findFileWithExtension',
+
+ -- * environment variables
+ isInSearchPath,
+
+ -- * simple file globbing
+ matchFileGlob,
+ matchDirFileGlob,
+ parseFileGlob,
+ FileGlob(..),
+
+ -- * temp files and dirs
+ withTempFile,
+ withTempDirectory,
+
+ -- * .cabal and .buildinfo files
+ defaultPackageDesc,
+ findPackageDesc,
+ defaultHookedPackageDesc,
+ findHookedPackageDesc,
+
+ -- * reading and writing files safely
+ withFileContents,
+ writeFileAtomic,
+ rewriteFile,
+
+ -- * Unicode
+ fromUTF8,
+ toUTF8,
+ readUTF8File,
+ withUTF8FileContents,
+ writeUTF8File,
+ normaliseLineEndings,
+
+ -- * generic utils
+ equating,
+ comparing,
+ isInfixOf,
+ intercalate,
+ lowercase,
+ wrapText,
+ wrapLine,
+ ) where
+
+import Control.Monad
+ ( when, unless, filterM )
+import Control.Concurrent.MVar
+ ( newEmptyMVar, putMVar, takeMVar )
+import Data.List
+ ( nub, unfoldr, isPrefixOf, tails, intercalate )
+import Data.Char as Char
+ ( toLower, chr, ord )
+import Data.Bits
+ ( Bits((.|.), (.&.), shiftL, shiftR) )
+import qualified Data.ByteString.Lazy as BS
+import qualified Data.ByteString.Lazy.Char8 as BS.Char8
+
+import System.Directory
+ ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile
+ , findExecutable )
+import System.Environment
+ ( getProgName )
+import System.Cmd
+ ( rawSystem )
+import System.Exit
+ ( exitWith, ExitCode(..) )
+import System.FilePath
+ ( normalise, (</>), (<.>)
+ , getSearchPath, takeDirectory, splitFileName
+ , splitExtension, splitExtensions, splitDirectories )
+import System.Directory
+ ( createDirectory, renameFile, removeDirectoryRecursive )
+import System.IO
+ ( Handle, openFile, openBinaryFile, openBinaryTempFile
+ , IOMode(ReadMode), hSetBinaryMode
+ , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
+import System.IO.Error as IO.Error
+ ( isDoesNotExistError, isAlreadyExistsError
+ , ioeSetFileName, ioeGetFileName, ioeGetErrorString )
+import System.IO.Error
+ ( ioeSetLocation, ioeGetLocation )
+import System.IO.Unsafe
+ ( unsafeInterleaveIO )
+import qualified Control.Exception as Exception
+
+import Distribution.Text
+ ( display )
+
+import Control.Exception (evaluate)
+import System.Process (runProcess)
+
+import Control.Concurrent (forkIO)
+import System.Process (runInteractiveProcess, waitForProcess)
+#if __GLASGOW_HASKELL__ >= 702
+import System.Process (showCommandForUser)
+#endif
+
+import Distribution.Compat.CopyFile
+ ( copyFile, copyOrdinaryFile, copyExecutableFile
+ , setFileOrdinary, setFileExecutable, setDirOrdinary )
+import Distribution.Compat.TempFile
+ ( openTempFile, createTempDirectory )
+import Distribution.Compat.Exception
+ ( IOException, throwIOIO, tryIO, catchIO, catchExit )
+import Distribution.Verbosity
+
+-- ----------------------------------------------------------------------------
+-- Exception and logging utils
+
+dieWithLocation :: FilePath -> Maybe Int -> String -> IO a
+dieWithLocation filename lineno msg =
+ ioError . setLocation lineno
+ . flip ioeSetFileName (normalise filename)
+ $ userError msg
+ where
+ setLocation Nothing err = err
+ setLocation (Just n) err = ioeSetLocation err (show n)
+
+die :: String -> IO a
+die msg = ioError (userError msg)
+
+topHandler :: IO a -> IO a
+topHandler prog = catchIO prog handle
+ where
+ handle ioe = do
+ hFlush stdout
+ pname <- getProgName
+ hPutStr stderr (mesage pname)
+ exitWith (ExitFailure 1)
+ where
+ mesage pname = wrapText (pname ++ ": " ++ file ++ detail)
+ file = case ioeGetFileName ioe of
+ Nothing -> ""
+ Just path -> path ++ location ++ ": "
+ location = case ioeGetLocation ioe of
+ l@(n:_) | n >= '0' && n <= '9' -> ':' : l
+ _ -> ""
+ detail = ioeGetErrorString ioe
+
+-- | Non fatal conditions that may be indicative of an error or problem.
+--
+-- We display these at the 'normal' verbosity level.
+--
+warn :: Verbosity -> String -> IO ()
+warn verbosity msg =
+ when (verbosity >= normal) $ do
+ hFlush stdout
+ hPutStr stderr (wrapText ("Warning: " ++ msg))
+
+-- | Useful status messages.
+--
+-- We display these at the 'normal' verbosity level.
+--
+-- This is for the ordinary helpful status messages that users see. Just
+-- enough information to know that things are working but not floods of detail.
+--
+notice :: Verbosity -> String -> IO ()
+notice verbosity msg =
+ when (verbosity >= normal) $
+ putStr (wrapText msg)
+
+-- | More detail on the operation of some action.
+--
+-- We display these messages when the verbosity level is 'verbose'
+--
+info :: Verbosity -> String -> IO ()
+info verbosity msg =
+ when (verbosity >= verbose) $
+ putStr (wrapText msg)
+
+-- | Detailed internal debugging information
+--
+-- We display these messages when the verbosity level is 'deafening'
+--
+debug :: Verbosity -> String -> IO ()
+debug verbosity msg =
+ when (verbosity >= deafening) $ do
+ putStr (wrapText msg)
+ hFlush stdout
+
+-- | A variant of 'debug' that doesn't perform the automatic line
+-- wrapping. Produces better output in some cases.
+debugNoWrap :: Verbosity -> String -> IO ()
+debugNoWrap verbosity msg =
+ when (verbosity >= deafening) $ do
+ putStrLn msg
+ hFlush stdout
+
+-- | Perform an IO action, catching any IO exceptions and printing an error
+-- if one occurs.
+chattyTry :: String -- ^ a description of the action we were attempting
+ -> IO () -- ^ the action itself
+ -> IO ()
+chattyTry desc action =
+ catchIO action $ \exception ->
+ putStrLn $ "Error while " ++ desc ++ ": " ++ show exception
+
+-- -----------------------------------------------------------------------------
+-- Helper functions
+
+-- | Wraps text to the default line width. Existing newlines are preserved.
+wrapText :: String -> String
+wrapText = unlines
+ . map (intercalate "\n"
+ . map unwords
+ . wrapLine 79
+ . words)
+ . lines
+
+-- | Wraps a list of words to a list of lines of words of a particular width.
+wrapLine :: Int -> [String] -> [[String]]
+wrapLine width = wrap 0 []
+ where wrap :: Int -> [String] -> [String] -> [[String]]
+ wrap 0 [] (w:ws)
+ | length w + 1 > width
+ = wrap (length w) [w] ws
+ wrap col line (w:ws)
+ | col + length w + 1 > width
+ = reverse line : wrap 0 [] (w:ws)
+ wrap col line (w:ws)
+ = let col' = col + length w + 1
+ in wrap col' (w:line) ws
+ wrap _ [] [] = []
+ wrap _ line [] = [reverse line]
+
+-- -----------------------------------------------------------------------------
+-- rawSystem variants
+maybeExit :: IO ExitCode -> IO ()
+maybeExit cmd = do
+ res <- cmd
+ unless (res == ExitSuccess) $ exitWith res
+
+printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
+printRawCommandAndArgs verbosity path args
+ | verbosity >= deafening = print (path, args)
+ | verbosity >= verbose =
+#if __GLASGOW_HASKELL__ >= 702
+ putStrLn $ showCommandForUser path args
+#else
+ putStrLn $ unwords (path : args)
+#endif
+ | otherwise = return ()
+
+printRawCommandAndArgsAndEnv :: Verbosity
+ -> FilePath
+ -> [String]
+ -> [(String, String)]
+ -> IO ()
+printRawCommandAndArgsAndEnv verbosity path args env
+ | verbosity >= deafening = do putStrLn ("Environment: " ++ show env)
+ print (path, args)
+ | verbosity >= verbose = putStrLn $ unwords (path : args)
+ | otherwise = return ()
+
+-- Exit with the same exitcode if the subcommand fails
+rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
+rawSystemExit verbosity path args = do
+ printRawCommandAndArgs verbosity path args
+ hFlush stdout
+ exitcode <- rawSystem path args
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ exitWith exitcode
+
+rawSystemExitCode :: Verbosity -> FilePath -> [String] -> IO ExitCode
+rawSystemExitCode verbosity path args = do
+ printRawCommandAndArgs verbosity path args
+ hFlush stdout
+ exitcode <- rawSystem path args
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ return exitcode
+
+rawSystemExitWithEnv :: Verbosity
+ -> FilePath
+ -> [String]
+ -> [(String, String)]
+ -> IO ()
+rawSystemExitWithEnv verbosity path args env = do
+ printRawCommandAndArgsAndEnv verbosity path args env
+ hFlush stdout
+ ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing
+ exitcode <- waitForProcess ph
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ exitWith exitcode
+
+-- Closes the passed in handles before returning.
+rawSystemIOWithEnv :: Verbosity
+ -> FilePath
+ -> [String]
+ -> [(String, String)]
+ -> Maybe Handle -- ^ stdin
+ -> Maybe Handle -- ^ stdout
+ -> Maybe Handle -- ^ stderr
+ -> IO ExitCode
+rawSystemIOWithEnv verbosity path args env inp out err = do
+ printRawCommandAndArgsAndEnv verbosity path args env
+ hFlush stdout
+ ph <- runProcess path args Nothing (Just env) inp out err
+ exitcode <- waitForProcess ph
+ unless (exitcode == ExitSuccess) $ do
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ return exitcode
+
+-- | Run a command and return its output.
+--
+-- The output is assumed to be text in the locale encoding.
+--
+rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String
+rawSystemStdout verbosity path args = do
+ (output, errors, exitCode) <- rawSystemStdInOut verbosity path args
+ Nothing False
+ when (exitCode /= ExitSuccess) $
+ die errors
+ return output
+
+-- | Run a command and return its output, errors and exit status. Optionally
+-- also supply some input. Also provides control over whether the binary/text
+-- mode of the input and output.
+--
+rawSystemStdInOut :: Verbosity
+ -> FilePath -> [String]
+ -> Maybe (String, Bool) -- ^ input text and binary mode
+ -> Bool -- ^ output in binary mode
+ -> IO (String, String, ExitCode) -- ^ output, errors, exit
+rawSystemStdInOut verbosity path args input outputBinary = do
+ printRawCommandAndArgs verbosity path args
+
+ Exception.bracket
+ (runInteractiveProcess path args Nothing Nothing)
+ (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)
+ $ \(inh,outh,errh,pid) -> do
+
+ -- output mode depends on what the caller wants
+ hSetBinaryMode outh outputBinary
+ -- but the errors are always assumed to be text (in the current locale)
+ hSetBinaryMode errh False
+
+ -- fork off a couple threads to pull on the stderr and stdout
+ -- so if the process writes to stderr we do not block.
+
+ err <- hGetContents errh
+ out <- hGetContents outh
+
+ mv <- newEmptyMVar
+ let force str = (evaluate (length str) >> return ())
+ `Exception.finally` putMVar mv ()
+ --TODO: handle exceptions like text decoding.
+ _ <- forkIO $ force out
+ _ <- forkIO $ force err
+
+ -- push all the input, if any
+ case input of
+ Nothing -> return ()
+ Just (inputStr, inputBinary) -> do
+ -- input mode depends on what the caller wants
+ hSetBinaryMode inh inputBinary
+ hPutStr inh inputStr
+ hClose inh
+ --TODO: this probably fails if the process refuses to consume
+ -- or if it closes stdin (eg if it exits)
+
+ -- wait for both to finish, in either order
+ takeMVar mv
+ takeMVar mv
+
+ -- wait for the program to terminate
+ exitcode <- waitForProcess pid
+ unless (exitcode == ExitSuccess) $
+ debug verbosity $ path ++ " returned " ++ show exitcode
+ ++ if null err then "" else
+ " with error message:\n" ++ err
+ ++ case input of
+ Nothing -> ""
+ Just ("", _) -> ""
+ Just (inp, _) -> "\nstdin input:\n" ++ inp
+
+ return (out, err, exitcode)
+
+
+-- | Look for a program on the path.
+findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath)
+findProgramLocation verbosity prog = do
+ debug verbosity $ "searching for " ++ prog ++ " in path."
+ res <- findExecutable prog
+ case res of
+ Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path")
+ Just path -> debug verbosity ("found " ++ prog ++ " at "++ path)
+ return res
+
+
+-- | Like the unix xargs program. Useful for when we've got very long command
+-- lines that might overflow an OS limit on command line length and so you
+-- need to invoke a command multiple times to get all the args in.
+--
+-- Use it with either of the rawSystem variants above. For example:
+--
+-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs
+--
+xargs :: Int -> ([String] -> IO ())
+ -> [String] -> [String] -> IO ()
+xargs maxSize rawSystemFun fixedArgs bigArgs =
+ let fixedArgSize = sum (map length fixedArgs) + length fixedArgs
+ chunkSize = maxSize - fixedArgSize
+ in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs)
+
+ where chunks len = unfoldr $ \s ->
+ if null s then Nothing
+ else Just (chunk [] len s)
+
+ chunk acc _ [] = (reverse acc,[])
+ chunk acc len (s:ss)
+ | len' < len = chunk (s:acc) (len-len'-1) ss
+ | otherwise = (reverse acc, s:ss)
+ where len' = length s
+
+-- ------------------------------------------------------------
+-- * File Utilities
+-- ------------------------------------------------------------
+
+----------------
+-- Finding files
+
+-- | Find a file by looking in a search path. The file path must match exactly.
+--
+findFile :: [FilePath] -- ^search locations
+ -> FilePath -- ^File Name
+ -> IO FilePath
+findFile searchPath fileName =
+ findFirstFile id
+ [ path </> fileName
+ | path <- nub searchPath]
+ >>= maybe (die $ fileName ++ " doesn't exist") return
+
+-- | Find a file by looking in a search path with one of a list of possible
+-- file extensions. The file base name should be given and it will be tried
+-- with each of the extensions in each element of the search path.
+--
+findFileWithExtension :: [String]
+ -> [FilePath]
+ -> FilePath
+ -> IO (Maybe FilePath)
+findFileWithExtension extensions searchPath baseName =
+ findFirstFile id
+ [ path </> baseName <.> ext
+ | path <- nub searchPath
+ , ext <- nub extensions ]
+
+-- | Like 'findFileWithExtension' but returns which element of the search path
+-- the file was found in, and the file path relative to that base directory.
+--
+findFileWithExtension' :: [String]
+ -> [FilePath]
+ -> FilePath
+ -> IO (Maybe (FilePath, FilePath))
+findFileWithExtension' extensions searchPath baseName =
+ findFirstFile (uncurry (</>))
+ [ (path, baseName <.> ext)
+ | path <- nub searchPath
+ , ext <- nub extensions ]
+
+findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a)
+findFirstFile file = findFirst
+ where findFirst [] = return Nothing
+ findFirst (x:xs) = do exists <- doesFileExist (file x)
+ if exists
+ then return (Just x)
+ else findFirst xs
+
+
+-- | List all the files in a directory and all subdirectories.
+--
+-- The order places files in sub-directories after all the files in their
+-- parent directories. The list is generated lazily so is not well defined if
+-- the source directory structure changes before the list is used.
+--
+getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
+getDirectoryContentsRecursive topdir = recurseDirectories [""]
+ where
+ recurseDirectories :: [FilePath] -> IO [FilePath]
+ recurseDirectories [] = return []
+ recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
+ (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
+ files' <- recurseDirectories (dirs' ++ dirs)
+ return (files ++ files')
+
+ where
+ collect files dirs' [] = return (reverse files, reverse dirs')
+ collect files dirs' (entry:entries) | ignore entry
+ = collect files dirs' entries
+ collect files dirs' (entry:entries) = do
+ let dirEntry = dir </> entry
+ isDirectory <- doesDirectoryExist (topdir </> dirEntry)
+ if isDirectory
+ then collect files (dirEntry:dirs') entries
+ else collect (dirEntry:files) dirs' entries
+
+ ignore ['.'] = True
+ ignore ['.', '.'] = True
+ ignore _ = False
+
+------------------------
+-- Environment variables
+
+-- | Is this directory in the system search path?
+isInSearchPath :: FilePath -> IO Bool
+isInSearchPath path = fmap (elem path) getSearchPath
+
+----------------
+-- File globbing
+
+data FileGlob
+ -- | No glob at all, just an ordinary file
+ = NoGlob FilePath
+
+ -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to
+ -- @FileGlob \"foo\/bar\" \".baz\"@
+ | FileGlob FilePath String
+
+parseFileGlob :: FilePath -> Maybe FileGlob
+parseFileGlob filepath = case splitExtensions filepath of
+ (filepath', ext) -> case splitFileName filepath' of
+ (dir, "*") | '*' `elem` dir
+ || '*' `elem` ext
+ || null ext -> Nothing
+ | null dir -> Just (FileGlob "." ext)
+ | otherwise -> Just (FileGlob dir ext)
+ _ | '*' `elem` filepath -> Nothing
+ | otherwise -> Just (NoGlob filepath)
+
+matchFileGlob :: FilePath -> IO [FilePath]
+matchFileGlob = matchDirFileGlob "."
+
+matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath]
+matchDirFileGlob dir filepath = case parseFileGlob filepath of
+ Nothing -> die $ "invalid file glob '" ++ filepath
+ ++ "'. Wildcards '*' are only allowed in place of the file"
+ ++ " name, not in the directory name or file extension."
+ ++ " If a wildcard is used it must be with an file extension."
+ Just (NoGlob filepath') -> return [filepath']
+ Just (FileGlob dir' ext) -> do
+ files <- getDirectoryContents (dir </> dir')
+ case [ dir' </> file
+ | file <- files
+ , let (name, ext') = splitExtensions file
+ , not (null name) && ext' == ext ] of
+ [] -> die $ "filepath wildcard '" ++ filepath
+ ++ "' does not match any files."
+ matches -> return matches
+
+----------------------------------------
+-- Copying and installing files and dirs
+
+-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels.
+--
+createDirectoryIfMissingVerbose :: Verbosity
+ -> Bool -- ^ Create its parents too?
+ -> FilePath
+ -> IO ()
+createDirectoryIfMissingVerbose verbosity create_parents path0
+ | create_parents = createDirs (parents path0)
+ | otherwise = createDirs (take 1 (parents path0))
+ where
+ parents = reverse . scanl1 (</>) . splitDirectories . normalise
+
+ createDirs [] = return ()
+ createDirs (dir:[]) = createDir dir throwIOIO
+ createDirs (dir:dirs) =
+ createDir dir $ \_ -> do
+ createDirs dirs
+ createDir dir throwIOIO
+
+ createDir :: FilePath -> (IOException -> IO ()) -> IO ()
+ createDir dir notExistHandler = do
+ r <- tryIO $ createDirectoryVerbose verbosity dir
+ case (r :: Either IOException ()) of
+ Right () -> return ()
+ Left e
+ | isDoesNotExistError e -> notExistHandler e
+ -- createDirectory (and indeed POSIX mkdir) does not distinguish
+ -- between a dir already existing and a file already existing. So we
+ -- check for it here. Unfortunately there is a slight race condition
+ -- here, but we think it is benign. It could report an exeption in
+ -- the case that the dir did exist but another process deletes the
+ -- directory and creates a file in its place before we can check
+ -- that the directory did indeed exist.
+ | isAlreadyExistsError e -> (do
+ isDir <- doesDirectoryExist dir
+ if isDir then return ()
+ else throwIOIO e
+ ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())
+ | otherwise -> throwIOIO e
+
+createDirectoryVerbose :: Verbosity -> FilePath -> IO ()
+createDirectoryVerbose verbosity dir = do
+ info verbosity $ "creating " ++ dir
+ createDirectory dir
+ setDirOrdinary dir
+
+-- | Copies a file without copying file permissions. The target file is created
+-- with default permissions. Any existing target file is replaced.
+--
+-- At higher verbosity levels it logs an info message.
+--
+copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
+copyFileVerbose verbosity src dest = do
+ info verbosity ("copy " ++ src ++ " to " ++ dest)
+ copyFile src dest
+
+-- | Install an ordinary file. This is like a file copy but the permissions
+-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\"
+-- while on Windows it uses the default permissions for the target directory.
+--
+installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO ()
+installOrdinaryFile verbosity src dest = do
+ info verbosity ("Installing " ++ src ++ " to " ++ dest)
+ copyOrdinaryFile src dest
+
+-- | Install an executable file. This is like a file copy but the permissions
+-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\"
+-- while on Windows it uses the default permissions for the target directory.
+--
+installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()
+installExecutableFile verbosity src dest = do
+ info verbosity ("Installing executable " ++ src ++ " to " ++ dest)
+ copyExecutableFile src dest
+
+-- | Copies a bunch of files to a target directory, preserving the directory
+-- structure in the target location. The target directories are created if they
+-- do not exist.
+--
+-- The files are identified by a pair of base directory and a path relative to
+-- that base. It is only the relative part that is preserved in the
+-- destination.
+--
+-- For example:
+--
+-- > copyFiles normal "dist/src"
+-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")]
+--
+-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and
+-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\".
+--
+-- This operation is not atomic. Any IO failure during the copy (including any
+-- missing source files) leaves the target in an unknown state so it is best to
+-- use it with a freshly created directory so that it can be simply deleted if
+-- anything goes wrong.
+--
+copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
+copyFiles verbosity targetDir srcFiles = do
+
+ -- Create parent directories for everything
+ let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
+ mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs
+
+ -- Copy all the files
+ sequence_ [ let src = srcBase </> srcFile
+ dest = targetDir </> srcFile
+ in copyFileVerbose verbosity src dest
+ | (srcBase, srcFile) <- srcFiles ]
+
+-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.
+--
+installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()
+installOrdinaryFiles verbosity targetDir srcFiles = do
+
+ -- Create parent directories for everything
+ let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
+ mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs
+
+ -- Copy all the files
+ sequence_ [ let src = srcBase </> srcFile
+ dest = targetDir </> srcFile
+ in installOrdinaryFile verbosity src dest
+ | (srcBase, srcFile) <- srcFiles ]
+
+-- | This installs all the files in a directory to a target location,
+-- preserving the directory layout. All the files are assumed to be ordinary
+-- rather than executable files.
+--
+installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO ()
+installDirectoryContents verbosity srcDir destDir = do
+ info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
+ srcFiles <- getDirectoryContentsRecursive srcDir
+ installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]
+
+---------------------------------
+-- Deprecated file copy functions
+
+{-# DEPRECATED copyDirectoryRecursiveVerbose
+ "You probably want installDirectoryContents instead" #-}
+copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO ()
+copyDirectoryRecursiveVerbose verbosity srcDir destDir = do
+ info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.")
+ srcFiles <- getDirectoryContentsRecursive srcDir
+ copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ]
+
+---------------------------
+-- Temporary files and dirs
+
+-- | Use a temporary filename that doesn't already exist.
+--
+withTempFile :: Bool -- ^ Keep temporary files?
+ -> FilePath -- ^ Temp dir to create the file in
+ -> String -- ^ File name template. See 'openTempFile'.
+ -> (FilePath -> Handle -> IO a) -> IO a
+withTempFile keepTempFiles tmpDir template action =
+ Exception.bracket
+ (openTempFile tmpDir template)
+ (\(name, handle) -> do hClose handle
+ unless keepTempFiles $ removeFile name)
+ (uncurry action)
+
+-- | Create and use a temporary directory.
+--
+-- Creates a new temporary directory inside the given directory, making use
+-- of the template. The temp directory is deleted after use. For example:
+--
+-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ...
+--
+-- The @tmpDir@ will be a new subdirectory of the given directory, e.g.
+-- @src/sdist.342@.
+--
+withTempDirectory :: Verbosity
+ -> Bool -- ^ Keep temporary files?
+ -> FilePath -> String -> (FilePath -> IO a) -> IO a
+withTempDirectory _verbosity keepTempFiles targetDir template =
+ Exception.bracket
+ (createTempDirectory targetDir template)
+ (unless keepTempFiles . removeDirectoryRecursive)
+
+-----------------------------------
+-- Safely reading and writing files
+
+-- | Gets the contents of a file, but guarantee that it gets closed.
+--
+-- The file is read lazily but if it is not fully consumed by the action then
+-- the remaining input is truncated and the file is closed.
+--
+withFileContents :: FilePath -> (String -> IO a) -> IO a
+withFileContents name action =
+ Exception.bracket (openFile name ReadMode) hClose
+ (\hnd -> hGetContents hnd >>= action)
+
+-- | Writes a file atomically.
+--
+-- The file is either written sucessfully or an IO exception is raised and
+-- the original file is left unchanged.
+--
+-- On windows it is not possible to delete a file that is open by a process.
+-- This case will give an IO exception but the atomic property is not affected.
+--
+writeFileAtomic :: FilePath -> BS.ByteString -> IO ()
+writeFileAtomic targetPath content = do
+ let (targetDir, targetFile) = splitFileName targetPath
+ Exception.bracketOnError
+ (openBinaryTempFile targetDir $ targetFile <.> "tmp")
+ (\(tmpPath, handle) -> hClose handle >> removeFile tmpPath)
+ (\(tmpPath, handle) -> do
+ BS.hPut handle content
+ hClose handle
+ renameFile tmpPath targetPath)
+
+-- | Write a file but only if it would have new content. If we would be writing
+-- the same as the existing content then leave the file as is so that we do not
+-- update the file's modification time.
+--
+rewriteFile :: FilePath -> String -> IO ()
+rewriteFile path newContent =
+ flip catchIO mightNotExist $ do
+ existingContent <- readFile path
+ _ <- evaluate (length existingContent)
+ unless (existingContent == newContent) $
+ writeFileAtomic path (BS.Char8.pack newContent)
+ where
+ mightNotExist e | isDoesNotExistError e = writeFileAtomic path
+ (BS.Char8.pack newContent)
+ | otherwise = ioError e
+
+-- | The path name that represents the current directory.
+-- In Unix, it's @\".\"@, but this is system-specific.
+-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.)
+currentDir :: FilePath
+currentDir = "."
+
+-- ------------------------------------------------------------
+-- * Finding the description file
+-- ------------------------------------------------------------
+
+-- |Package description file (/pkgname/@.cabal@)
+defaultPackageDesc :: Verbosity -> IO FilePath
+defaultPackageDesc _verbosity = findPackageDesc currentDir
+
+-- |Find a package description file in the given directory. Looks for
+-- @.cabal@ files.
+findPackageDesc :: FilePath -- ^Where to look
+ -> IO FilePath -- ^<pkgname>.cabal
+findPackageDesc dir
+ = do files <- getDirectoryContents dir
+ -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal
+ -- file we filter to exclude dirs and null base file names:
+ cabalFiles <- filterM doesFileExist
+ [ dir </> file
+ | file <- files
+ , let (name, ext) = splitExtension file
+ , not (null name) && ext == ".cabal" ]
+ case cabalFiles of
+ [] -> noDesc
+ [cabalFile] -> return cabalFile
+ multiple -> multiDesc multiple
+
+ where
+ noDesc :: IO a
+ noDesc = die $ "No cabal file found.\n"
+ ++ "Please create a package description file <pkgname>.cabal"
+
+ multiDesc :: [String] -> IO a
+ multiDesc l = die $ "Multiple cabal files found.\n"
+ ++ "Please use only one of: "
+ ++ intercalate ", " l
+
+-- |Optional auxiliary package information file (/pkgname/@.buildinfo@)
+defaultHookedPackageDesc :: IO (Maybe FilePath)
+defaultHookedPackageDesc = findHookedPackageDesc currentDir
+
+-- |Find auxiliary package information in the given directory.
+-- Looks for @.buildinfo@ files.
+findHookedPackageDesc
+ :: FilePath -- ^Directory to search
+ -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present
+findHookedPackageDesc dir = do
+ files <- getDirectoryContents dir
+ buildInfoFiles <- filterM doesFileExist
+ [ dir </> file
+ | file <- files
+ , let (name, ext) = splitExtension file
+ , not (null name) && ext == buildInfoExt ]
+ case buildInfoFiles of
+ [] -> return Nothing
+ [f] -> return (Just f)
+ _ -> die ("Multiple files with extension " ++ buildInfoExt)
+
+buildInfoExt :: String
+buildInfoExt = ".buildinfo"
+
+-- ------------------------------------------------------------
+-- * Unicode stuff
+-- ------------------------------------------------------------
+
+-- This is a modification of the UTF8 code from gtk2hs and the
+-- utf8-string package.
+
+fromUTF8 :: String -> String
+fromUTF8 [] = []
+fromUTF8 (c:cs)
+ | c <= '\x7F' = c : fromUTF8 cs
+ | c <= '\xBF' = replacementChar : fromUTF8 cs
+ | c <= '\xDF' = twoBytes c cs
+ | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF)
+ | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7)
+ | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3)
+ | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1)
+ | otherwise = replacementChar : fromUTF8 cs
+ where
+ twoBytes c0 (c1:cs')
+ | ord c1 .&. 0xC0 == 0x80
+ = let d = ((ord c0 .&. 0x1F) `shiftL` 6)
+ .|. (ord c1 .&. 0x3F)
+ in if d >= 0x80
+ then chr d : fromUTF8 cs'
+ else replacementChar : fromUTF8 cs'
+ twoBytes _ cs' = replacementChar : fromUTF8 cs'
+
+ moreBytes :: Int -> Int -> [Char] -> Int -> [Char]
+ moreBytes 1 overlong cs' acc
+ | overlong <= acc && acc <= 0x10FFFF
+ && (acc < 0xD800 || 0xDFFF < acc)
+ && (acc < 0xFFFE || 0xFFFF < acc)
+ = chr acc : fromUTF8 cs'
+
+ | otherwise
+ = replacementChar : fromUTF8 cs'
+
+ moreBytes byteCount overlong (cn:cs') acc
+ | ord cn .&. 0xC0 == 0x80
+ = moreBytes (byteCount-1) overlong cs'
+ ((acc `shiftL` 6) .|. ord cn .&. 0x3F)
+
+ moreBytes _ _ cs' _
+ = replacementChar : fromUTF8 cs'
+
+ replacementChar = '\xfffd'
+
+toUTF8 :: String -> String
+toUTF8 [] = []
+toUTF8 (c:cs)
+ | c <= '\x07F' = c
+ : toUTF8 cs
+ | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6))
+ : chr (0x80 .|. (w .&. 0x3F))
+ : toUTF8 cs
+ | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12))
+ : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))
+ : chr (0x80 .|. (w .&. 0x3F))
+ : toUTF8 cs
+ | otherwise = chr (0xf0 .|. (w `shiftR` 18))
+ : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F))
+ : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F))
+ : chr (0x80 .|. (w .&. 0x3F))
+ : toUTF8 cs
+ where w = ord c
+
+-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input
+--
+ignoreBOM :: String -> String
+ignoreBOM ('\xFEFF':string) = string
+ignoreBOM string = string
+
+-- | Reads a UTF8 encoded text file as a Unicode String
+--
+-- Reads lazily using ordinary 'readFile'.
+--
+readUTF8File :: FilePath -> IO String
+readUTF8File f = fmap (ignoreBOM . fromUTF8)
+ . hGetContents =<< openBinaryFile f ReadMode
+
+-- | Reads a UTF8 encoded text file as a Unicode String
+--
+-- Same behaviour as 'withFileContents'.
+--
+withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a
+withUTF8FileContents name action =
+ Exception.bracket
+ (openBinaryFile name ReadMode)
+ hClose
+ (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8)
+
+-- | Writes a Unicode String as a UTF8 encoded text file.
+--
+-- Uses 'writeFileAtomic', so provides the same guarantees.
+--
+writeUTF8File :: FilePath -> String -> IO ()
+writeUTF8File path = writeFileAtomic path . BS.Char8.pack . toUTF8
+
+-- | Fix different systems silly line ending conventions
+normaliseLineEndings :: String -> String
+normaliseLineEndings [] = []
+normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows
+normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx
+normaliseLineEndings ( c :s) = c : normaliseLineEndings s
+
+-- ------------------------------------------------------------
+-- * Common utils
+-- ------------------------------------------------------------
+
+equating :: Eq a => (b -> a) -> b -> b -> Bool
+equating p x y = p x == p y
+
+comparing :: Ord a => (b -> a) -> b -> b -> Ordering
+comparing p x y = p x `compare` p y
+
+isInfixOf :: String -> String -> Bool
+isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
+
+lowercase :: String -> String
+lowercase = map Char.toLower
+
diff --git a/tests/examples/ghc88/hie010.hs b/tests/examples/ghc88/hie010.hs
new file mode 100755
index 0000000..3f87299
--- /dev/null
+++ b/tests/examples/ghc88/hie010.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE DataKinds #-}
+module MoreExplicitForalls where
+
+import Data.Proxy
+
+data family F1 a
+data instance forall (x :: Bool). F1 (Proxy x) = MkF
+
+class C a where
+ type F2 a b
+
+instance forall a. C [a] where
+ type forall b. F2 [a] b = Int
+
+
+type family G a b where
+ forall x y. G [x] (Proxy y) = Double
+ forall z. G z z = Bool
+