[GHC] #14679: The interpreter showed panic! (the 'impossible' happened)

[GHC]

#14679: The interpreter showed panic! (the 'impossible' happened)
-------------------------------------+-------------------------------------
           Reporter:  crick_         |             Owner:  (none)
               Type:  bug            |            Status:  new
           Priority:  normal         |         Milestone:
          Component:  Compiler       |           Version:  8.0.1
           Keywords:  panic          |  Operating System:  Windows
       Architecture:  x86_64         |   Type of failure:  Compile-time
  (amd64)                            |  crash or panic
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 My code -

 {{{#!hs
 {-
 Example run:

 Enter initial state:
 12356 784
 Enter final state:

 123586 74
 1 2 3
 5 8 6
   7 4

 1 2 3
 5 8 6
 7   4

 1 2 3
 5   6
 7 8 4

 1 2 3
 5 6
 7 8 4

 Minimum path length: 3

 -}

 import Data.List
 import Data.List.Split
 import Data.Map as Map hiding (map, filter)

 swap :: Int -> Int -> State -> State
 swap i j (State xs depth) = let (i', j') = if i > j then (j ,i) else (i,
 j)
                                 left = take i' xs
                                 middle = drop (i'+1) $ take j' xs
                                 i_elem = xs !! i'
                                 right = drop (j'+1) xs
                                 j_elem = xs !! j'
                                 xs' = left ++ [j_elem] ++ middle ++
 [i_elem] ++ right
                             in (State xs' depth)

 printGrid :: State -> IO()
 printGrid (State xs depth) = let [x,y,z] = chunksOf 6 $ intersperse ' ' xs
                              in do putStrLn x
                                    putStrLn y
                                    putStrLn z
                                    putStrLn ""

 data State = State {
   state :: [Char],
   depth :: Int
 } deriving (Eq, Show, Ord)

 getMoves :: State -> [Char]
 getMoves (State xs depth) = case ' ' `elemIndex` xs of
   Nothing -> error "Empty block not found"
   Just n -> let l = n `elem` [1,4,7,2,5,8]
                 r = n `elem` [0,3,6,1,4,7]
                 d = n `elem` [0..5]
                 u = n `elem` [3..8]
                 pairs = zip [l,r,d,u] ['L','R','D','U']
                 filtered = filter (\x -> fst x) pairs
             in map snd filtered

 next :: State -> [Char] -> [State]
 next (State state depth) cs = case ' ' `elemIndex` state of
   Nothing -> error "Empty block not found"
   Just n -> do c <- cs
                return $ case c of
                          'L' -> swap n (n-1) (State state (depth + 1))
                          'R' -> swap n (n+1) (State state (depth + 1))
                          'U' -> swap n (n-3) (State state (depth + 1))
                          'D' -> swap n (n+3) (State state (depth + 1))

 test :: State -> State -> Bool
 test state1 state2 = (state state1) == (state state2)

 -- loop :: finalState -> open -> closed -> accmulated parentMap ->
 parentMap
 loop :: State -> [State] -> [State] -> Map State State -> Maybe (State,
 Map State State)
 loop final [] _ _ = Nothing
 loop final open@(x:xs) closed parentMap = if test final x
   then Just (x, parentMap)
   else let moves = getMoves x
            nextStates = next x moves
            filter_fn = \x -> not (x `elem` open || x `elem` closed)
            filtered = filter filter_fn nextStates
            newMap = insertIntoMap filtered x parentMap
        in loop final (xs ++ filtered) (x:closed) newMap

 insertIntoMap :: [State] -> State -> Map State State -> Map State State
 insertIntoMap [] _ parentMap = parentMap
 insertIntoMap (x:xs) parent parentMap =
  insertIntoMap xs parent (Map.insert x parent parentMap)

 printAns :: State -> Map State State -> Int -> IO ()
 printAns state parentMap count =
  case Map.lookup state parentMap of
    Just parent -> do printGrid parent
                      printAns parent parentMap (count + 1)
    Nothing -> do putStrLn $ "Minimum path length: " ++ show count
                  return ()

 ans :: Maybe (State, Map State State) -> IO ()
 ans (Just (final, parentMap)) = do
  printGrid final
  printAns final parentMap 0
 ans _ = putStrLn "No answer found."

 main :: IO ()
 main = do putStrLn "Enter initial state: "
           start <- getLine
           putStrLn "Enter final state: "
           final <- getLine
           ans $ loop (State final 0) [(State start 0)] [] Map.empty

 }}}

 Test Cases I entered in the order:

 *Main> main

 Enter initial state:
 123456 784

 Enter final state:
 1234567 8mianrrupted.

 *Main>

 *Main> main

 Enter initial state:
 12356 784

 Enter final state:
 123586 74

 1 2 3
 5 8 6
   7 4

 1 2 3
 5 8 6
 7   4


 1 2 3
 5   6
 7 8 4

 1 2 3
 5 6
 7 8 4


 Minimum path length: 3
 *Main>
 <interactive>: panic! (the 'impossible' happened)
   (GHC version 8.0.1 for x86_64-unknown-mingw32):
         thread blocked indefinitely in an MVar operation

 Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug

-- 
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/14679>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler