1 files changed, 60 insertions, 0 deletions
diff --git a/testsuite/tests/typecheck/should_run/tcrun021.hs b/testsuite/tests/typecheck/should_run/tcrun021.hs
new file mode 100644
index 0000000000..50497dd640
--- /dev/null
+++ b/testsuite/tests/typecheck/should_run/tcrun021.hs
@@ -0,0 +1,60 @@
+{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies,
+             TypeSynonymInstances, FlexibleInstances #-}
+
+-- This bizarre program failed because TcSimplify built a loop of
+-- dictionaries, due to an obscure bug in the way in which superclasses
+-- were added
+
+module Main where
+
+import Data.List
+import Data.Map
+
+class (Ord oid) => Object o oid | o -> oid where
+
+data Access oid
+
+class (Object o oid) => SecurityModel model o oid | model -> o
+
+class (SecurityModel model o oid) => SecurityPolicy policy model o oid where
+    checkAccess :: policy -> model -> Access oid -> Bool
+    checkAccess _ _ _ = True
+    checkModel :: policy -> model -> Bool
+    checkModel _ _ = True
+
+------------------------------------------------------------
+-- The Linux instance
+------------------------------------------------------------
+
+type LinuxObjectId = Either [String] String
+
+data LinuxObject = File [String] deriving (Eq, Show)
+
+instance Object LinuxObject LinuxObjectId
+
+data LinuxSecurityModel =
+    LinuxSecurityModel { lsmObjectSet   :: Map LinuxObjectId LinuxObject }
+
+
+-- Now defined in Data.Map, don't think this affects the bug:
+-- instance (Show a, Show b) => Show (Map a b) where
+--     show fm = show (fmToList fm)
+
+instance Show LinuxSecurityModel where
+    show lsm = "LSM:" ++ "\tObjects:  " ++ show (lsmObjectSet lsm)
+
+instance SecurityModel LinuxSecurityModel LinuxObject LinuxObjectId
+
+data LinuxSecurityPolicy = LinuxSecurityPolicy
+instance SecurityPolicy LinuxSecurityPolicy LinuxSecurityModel LinuxObject LinuxObjectId
+
+model :: Map LinuxObjectId LinuxObject
+model =  fromList [ (Left [], File []), (Left ["home"], File ["home"]) ]
+
+
+-- 	works
+-- model :: (LinuxObjectId, LinuxObject)
+-- model =  (Left [], File [])
+
+main :: IO ()
+main = do { putStrLn (show model) }