2 files changed, 53 insertions, 10 deletions
diff --git a/users/grfn/xanthous/test/Test/Prelude.hs b/users/grfn/xanthous/test/Test/Prelude.hs
index c423796184f7..2df0a6290a02 100644
--- a/users/grfn/xanthous/test/Test/Prelude.hs
+++ b/users/grfn/xanthous/test/Test/Prelude.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+--------------------------------------------------------------------------------
 module Test.Prelude
   ( module Xanthous.Prelude
   , module Test.Tasty
@@ -5,15 +7,26 @@ module Test.Prelude
   , module Test.Tasty.QuickCheck
   , module Test.QuickCheck.Classes
   , testBatch
+  , jsonRoundTrip
   ) where
-
-import Xanthous.Prelude hiding (assert, elements)
-import Test.Tasty
-import Test.Tasty.QuickCheck
-import Test.Tasty.HUnit
-import Test.QuickCheck.Classes
-import Test.QuickCheck.Checkers (TestBatch)
-import Test.QuickCheck.Instances.ByteString ()
+--------------------------------------------------------------------------------
+import           Xanthous.Prelude hiding (assert, elements)
+--------------------------------------------------------------------------------
+import           Test.Tasty
+import           Test.Tasty.QuickCheck
+import           Test.Tasty.HUnit
+import           Test.QuickCheck.Classes
+import           Test.QuickCheck.Checkers (TestBatch, EqProp ((=-=)))
+import           Test.QuickCheck.Instances.ByteString ()
+--------------------------------------------------------------------------------
+import qualified Data.Aeson as JSON
+import           Data.Aeson (ToJSON, FromJSON)
+--------------------------------------------------------------------------------
 
 testBatch :: TestBatch -> TestTree
 testBatch (name, tests) = testGroup name $ uncurry testProperty <$> tests
+
+jsonRoundTrip
+  :: forall a. (ToJSON a, FromJSON a, EqProp a, Arbitrary a, Show a) => TestTree
+jsonRoundTrip = testProperty "JSON round trip" $ \(x :: a) ->
+  JSON.decode (JSON.encode x) =-= Just x
diff --git a/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
index 3740945877ef..0d800e8a91de 100644
--- a/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
+++ b/users/grfn/xanthous/test/Xanthous/OrphansSpec.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE OverloadedLists #-}
 --------------------------------------------------------------------------------
 module Xanthous.OrphansSpec where
 --------------------------------------------------------------------------------
@@ -8,6 +9,10 @@ import           Text.Mustache
 import           Text.Megaparsec (errorBundlePretty)
 import           Graphics.Vty.Attributes
 import qualified Data.Aeson as JSON
+import           Data.Interval (Interval, (<=..<=), (<=..<), (<..<=))
+import           Data.Aeson ( ToJSON(toJSON), object, Value(Array) )
+import           Data.Aeson.Types (fromJSON)
+import           Data.IntegerInterval (Extended(Finite))
 --------------------------------------------------------------------------------
 import           Xanthous.Orphans
 --------------------------------------------------------------------------------
@@ -36,7 +41,32 @@ test = testGroup "Xanthous.Orphans"
         $ JSON.decode (JSON.encode tpl) === Just tpl
     ]
   , testGroup "Attr"
-    [ testProperty "JSON round trip" $ \(attr :: Attr) ->
-        JSON.decode (JSON.encode attr) === Just attr
+    [ jsonRoundTrip @Attr ]
+  , testGroup "Extended"
+    [ jsonRoundTrip @(Extended Int) ]
+  , testGroup "Interval"
+    [ testGroup "JSON"
+      [ jsonRoundTrip @(Interval Int)
+      , testCase "parses a single value as a length-1 interval" $
+          getSuccess (fromJSON $ toJSON (1 :: Int))
+          @?= Just (Finite (1 :: Int) <=..<= Finite 1)
+      , testCase "parses a pair of values as a single-ended interval" $
+          getSuccess (fromJSON $ toJSON ([1, 2] :: [Int]))
+          @?= Just (Finite (1 :: Int) <=..< Finite (2 :: Int))
+      , testCase "parses the full included/excluded syntax" $
+          getSuccess (fromJSON $ Array [ object [ "Excluded" JSON..= (1 :: Int) ]
+                                       , object [ "Included" JSON..= (4 :: Int) ]
+                                       ])
+          @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int))
+      , testCase "parses open/closed as aliases" $
+          getSuccess (fromJSON $ Array [ object [ "Open" JSON..= (1 :: Int) ]
+                                       , object [ "Closed" JSON..= (4 :: Int) ]
+                                       ])
+          @?= Just (Finite (1 :: Int) <..<= Finite (4 :: Int))
+      ]
     ]
   ]
+  where
+    getSuccess :: JSON.Result a -> Maybe a
+    getSuccess (JSON.Error _) = Nothing
+    getSuccess (JSON.Success r) = Just r