Ticket #7057: ghcloop.hs

File ghcloop.hs, 2.3 KB (added by ronwalf, 3 years ago)

Infinite loop test case

Line 
1{-# LANGUAGE
2   DeriveDataTypeable,
3   FlexibleContexts,
4   FlexibleInstances,
5   FunctionalDependencies,
6   MultiParamTypeClasses,
7   StandaloneDeriving,
8   TypeOperators,
9   UndecidableInstances
10   #-}
11import Data.Data 
12import Data.Generics (extQ, something)
13import Data.List (intercalate)
14import Data.Maybe (fromJust)
15
16
17newtype Expr f = In (f (Expr f))
18instance Typeable1 f => Typeable (Expr f) where
19    typeOf e = mkTyConApp (mkTyCon "Foo.Bar.Expr") [typeOf1 x]
20        where In x = (In undefined) `asTypeOf` e
21deriving instance (Typeable1 a, Data (a (Expr a))) => Data (Expr a)
22
23infixr 6 :+:
24data (f :+: g) e = Inl (f e) | Inr (g e) deriving (Eq)
25instance (Typeable1 f, Typeable1 g) => Typeable1 (f :+: g) where
26    typeOf1 l = mkTyConApp (mkTyCon "Foo.Bar.:+:") [typeOf1 x, typeOf1 y] where
27        Inl x = (Inl undefined) `asTypeOf` l
28        Inr y = (Inr undefined) `asTypeOf` l
29
30deriving instance (
31   Typeable1 f,
32    Typeable1 g,
33    Typeable e,
34    Data (f e),
35    Data (g e))
36        => Data ((f :+: g) e)
37
38
39gfind :: (Data a, Typeable b) => a -> Maybe b
40gfind = something (const Nothing `extQ` Just)
41
42
43data Goal f = Goal (Maybe f) deriving (Eq, Show, Data, Typeable)
44unGoal :: Goal f -> Maybe f
45unGoal (Goal a) = a
46class (Data a, Typeable f) => HasGoal f a | a -> f where
47    getGoal :: a -> Maybe f
48    getGoal = unGoal . fromJust . gfind
49
50class PDDLDocExpr f where
51    pddlDocExpr :: (PDDLDocExpr g) => f (Expr g) -> String
52instance (PDDLDocExpr f, PDDLDocExpr g) => PDDLDocExpr (f :+: g) where
53    pddlDocExpr (Inr x) = pddlDocExpr x
54    pddlDocExpr (Inl y) = pddlDocExpr y
55
56
57class PDDLDoc d where
58    pddlDoc :: d -> String
59
60instance PDDLDocExpr f => PDDLDoc (Expr f) where
61    pddlDoc (In x) = pddlDocExpr x
62
63data Imply e = Imply e e deriving (Data, Typeable)
64instance PDDLDocExpr Imply where
65    pddlDocExpr (Imply (In e1) (In e2)) = 
66        "(implies "
67        ++ pddlDocExpr e1
68        ++ pddlDocExpr e2
69        ++ ")"
70data Or e = Or [e] deriving (Data, Typeable)
71instance PDDLDocExpr Or where
72    pddlDocExpr (Or sl) = "(or " ++ intercalate ", " (map pddlDoc sl) ++ ")"
73
74data Container a = Container (Goal a) deriving (Data, Typeable)
75instance (Data a) => HasGoal a (Container a)
76
77main = do
78    print $ pddlDoc $ fromJust $ getGoal $ Container (Goal $ Just (In (Inr (Or [])):: Expr (Imply :+: Or)))