Merge pull request #949 from haskell/issue-852-monadfix-parser

Resolve #927: Add MonadFix instance

Author: phadej

changelog.md

@@ -7,6 +7,7 @@ For the latest version of this document, please see [https://github.com/haskell/
 - Export `Key` type also from `Data.Aeson.KeyMap` module.
 - Export `mapWithKey` from `Data.Aeson.KeyMap` module.
 - Export `ifromJSON` and `iparse` from `Data.Aeson.Types`. Add `iparseEither`.
+- Add `MonadFix Parser` instance.
 
 ### 2.0.3.0
 

src/Data/Aeson/Types/Internal.hs

@@ -90,6 +90,7 @@ import Prelude.Compat
 import Control.Applicative (Alternative(..))
 import Control.DeepSeq (NFData(..))
 import Control.Monad (MonadPlus(..), ap)
+import Control.Monad.Fix (MonadFix (..))
 import Data.Char (isLower, isUpper, toLower, isAlpha, isAlphaNum)
 import Data.Aeson.Key (Key)
 import Data.Data (Data)
@@ -307,6 +308,19 @@ instance Monad.Monad Parser where
     {-# INLINE fail #-}
 #endif
 
+-- |
+--
+-- @since 2.1.0.0
+instance MonadFix Parser where
+    mfix f = Parser $ \path kf ks -> let x = runParser (f (fromISuccess x)) path IError ISuccess in
+        case x of
+            IError p e -> kf p e
+            ISuccess y -> ks y
+      where
+        fromISuccess :: IResult a -> a
+        fromISuccess (ISuccess x)      = x
+        fromISuccess (IError path msg) = error $ "mfix @Aeson.Parser: " ++ formatPath path ++ ": " ++ msg
+
 instance Fail.MonadFail Parser where
     fail msg = Parser $ \path kf _ks -> kf (reverse path) msg
     {-# INLINE fail #-}

tests/UnitTests.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecursiveDo #-}
 
 -- For Data.Aeson.Types.camelTo
 {-# OPTIONS_GHC -fno-warn-deprecations #-}
@@ -37,7 +38,9 @@ import Data.Aeson.Parser
 import Data.Aeson.Types
   ( Options(..), Result(Success, Error), ToJSON(..)
   , Value(Array, Bool, Null, Number, Object, String), camelTo, camelTo2
-  , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse)
+  , explicitParseField, liftParseJSON, listParser
+  , defaultOptions, formatPath, formatRelativePath, omitNothingFields, parse, parseMaybe)
+import qualified Data.Aeson.Types
 import qualified Data.Aeson.KeyMap as KM
 import Data.Attoparsec.ByteString (Parser, parseOnly)
 import Data.Char (toUpper, GeneralCategory(Control,Surrogate), generalCategory)
@@ -71,6 +74,7 @@ import qualified Data.Text.Lazy.Encoding as TLE
 import qualified Data.Vector as Vector
 import qualified ErrorMessages
 import qualified SerializationFormatSpec
+import qualified Data.Map as Map -- Lazy!
 
 roundTripCamel :: String -> Assertion
 roundTripCamel name = assertEqual "" name (camelFrom '_' $ camelTo '_' name)
@@ -717,6 +721,106 @@ type instance Fam757 = Maybe
 newtype Newtype757 a = MkNewtype757 (Fam757 a)
 deriveToJSON1 defaultOptions ''Newtype757
 
+-------------------------------------------------------------------------------
+-- MonadFix
+-------------------------------------------------------------------------------
+
+monadFixDecoding1 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion
+monadFixDecoding1 p = do
+    fmap (take 10) (parseMaybe p value) @?= Just "xyzxyzxyzx"
+  where
+    value = object
+        [ "foo" .= ('x', "bar" :: String)
+        , "bar" .= ('y', "quu" :: String)
+        , "quu" .= ('z', "foo" :: String)
+        ]
+
+monadFixDecoding2 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion
+monadFixDecoding2 p = do
+    fmap (take 10) (parseMaybe p value) @?= Nothing
+  where
+    value = object
+        [ "foo" .= ('x', "bar" :: String)
+        , "bar" .= ('y', "???" :: String)
+        , "quu" .= ('z', "foo" :: String)
+        ]
+
+monadFixDecoding3 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion
+monadFixDecoding3 p =
+    fmap (take 10) (parseMaybe p value) @?= Nothing
+  where
+    value = object
+        [ "foo" .= ('x', "bar" :: String)
+        , "bar" .= Null
+        , "quu" .= ('z', "foo" :: String)
+        ]
+
+monadFixDecoding4 :: (Value -> Data.Aeson.Types.Parser [Char]) -> Assertion
+monadFixDecoding4 p =
+    fmap (take 10) (parseMaybe p value) @?= Nothing
+  where
+    value = object
+        [ "els" .= ('x', "bar" :: String)
+        , "bar" .= Null
+        , "quu" .= ('z', "foo" :: String)
+        ]
+
+-- Parser with explicit references
+monadFixParserA :: Value -> Data.Aeson.Types.Parser [Char]
+monadFixParserA = withObject "Rec" $ \obj -> mdo
+    let p'' :: Value -> Data.Aeson.Types.Parser String
+        p'' "foo" = return foo
+        p'' "bar" = return bar
+        p'' "quu" = return quu
+        p'' _     = fail "Invalid reference"
+
+    let p' :: Value -> Data.Aeson.Types.Parser [Char]
+        p' v = do
+            (c, cs) <- liftParseJSON p'' (listParser p'') v
+            return (c : cs)
+
+    foo <- explicitParseField p' obj "foo"
+    bar <- explicitParseField p' obj "bar"
+    quu <- explicitParseField p' obj "quu"
+    return foo
+
+-- Parser with arbitrary references!
+monadFixParserB :: Value -> Data.Aeson.Types.Parser [Char]
+monadFixParserB = withObject "Rec" $ \obj -> mdo
+    let p'' :: Value -> Data.Aeson.Types.Parser String
+        p'' key' = do
+            key <- parseJSON key'
+            -- this is ugly: we look whether key is in original obj
+            -- but then query from refs.
+            --
+            -- This way we are lazier. Map.traverse isn't lazy enough.
+            case KM.lookup key obj of
+                Just _  -> return (refs Map.! key)
+                Nothing -> fail "Invalid reference"
+
+    let p' :: Value -> Data.Aeson.Types.Parser [Char]
+        p' v = do
+            (c, cs) <- liftParseJSON p'' (listParser p'') v
+            return (c : cs)
+
+    refs <- traverse p' (KM.toMap obj)
+    case Map.lookup "foo" refs of
+        Nothing   -> fail "No foo node"
+        Just root -> return root
+
+monadFixTests :: TestTree
+monadFixTests = testGroup "MonadFix"
+    [ testCase "Example1a" $ monadFixDecoding1 monadFixParserA
+    , testCase "Example2a" $ monadFixDecoding2 monadFixParserA
+    , testCase "Example3a" $ monadFixDecoding3 monadFixParserA
+    , testCase "Example4a" $ monadFixDecoding4 monadFixParserA
+
+    , testCase "Example1b" $ monadFixDecoding1 monadFixParserB
+    , testCase "Example2b" $ monadFixDecoding2 monadFixParserB
+    , testCase "Example3b" $ monadFixDecoding3 monadFixParserB
+    , testCase "Example4b" $ monadFixDecoding4 monadFixParserB
+    ]
+
 -------------------------------------------------------------------------------
 -- Tests trees
 -------------------------------------------------------------------------------
@@ -779,4 +883,5 @@ tests = testGroup "unit" [
     [ testCase "example" $
       assertEqual "" (object ["foo" .= True]) [aesonQQ| {"foo": true } |]
     ]
+  , monadFixTests
   ]