MonadFix instance for ReadP

errMfix :: a
errMfix = errorWithoutStackTrace "mfix (ReadP): loop detected"
{-# NOINLINE errMfix #-}

instance MonadFix ReadP where
  mfix f = R (\k -> Look (fixup f 0 k)) where
    toP g a = case g a of R m -> m pure
    {-# INLINE toP #-}

    skip :: Int -> P b -> P b
    skip 0 p = p
    skip n p = Get $ const $ skip (n - 1) p

    unwrapM Nothing = errMfix
    unwrapM (Just (_, a)) = a
    {-# INLINE unwrapM #-}

    fixup :: (a -> ReadP a) -> Int -> (a -> P b) -> String -> P b
    fixup _ n _ _ | n `seq` False = undefined
    fixup f n k s = let
      ms = probeM n 0 (toP f (unwrapM ms)) s
      in case ms of
        Nothing -> Fail
        Just (sk, a) -> skip sk (k a) <|> fixup f (n + 1) k s

    probeM n sk _ _ | n `seq` sk `seq` False = undefined
    probeM n sk (Get f) (c:s) = probeM n (sk + 1) (f c) s
    probeM n sk (Look f) s = probeM n sk (f s) s
    probeM n sk (Result a p) s
      | n == 0 = Just (sk, a)
      | otherwise = probeM (n - 1) sk p s
    probeM n sk (Final (r :| rs)) _ = findF n (r:rs) where
      findF _ [] = Nothing
      findF 0 ((a, _):_) = Just (sk, a)
      findF n (_:rs) = findF (n - 1) rs
    probeM _ _ _ _ = Nothing
  {-# INLINE mfix #-}