large-anon-0.4.0: test/Test/Sanity/BlogPost.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
#if defined(NO_RECORD_DOT_PREPROCESSOR)
module Test.Sanity.BlogPost (tests) where
import Test.Tasty
import Test.Tasty.HUnit
tests :: TestTree
tests =
testCaseInfo "Test.Sanity.BlogPost" $
return "Blogposts tests (no record-dot-preprocessor)"
#else
{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Anon.Plugin #-}
module Test.Sanity.BlogPost (
tests
-- * Examples for the blog post
, checkIsSubRow
, exampleRender
, exampleRender'
, magenta
, magenta'
, ordImpliesEq
, purple
, recordToJSON
, recordToJSON'
, reduceBlue
, reduceGreen
, reduceRed
, showRecord
, smallerSatisfies
) where
import Data.Aeson (ToJSON(..), Value)
import Data.Aeson qualified as Aeson
import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty
import Data.Bifunctor
import Data.ByteString.Lazy qualified as Lazy (ByteString)
import Data.ByteString.Lazy.Char8 qualified as Lazy.BS.C8
import Data.Function (on)
import Data.Kind
import Data.Maybe
import Data.SOP (fn_3)
import Data.String
import Data.Text qualified as Text
import Data.Type.Equality
import GHC.TypeLits
import Optics.Core (over)
import Text.Parsec (Parsec, ParseError)
import Text.Parsec qualified as Parsec
import Text.Read (readMaybe)
import Data.Record.Anon
import Data.Record.Anon.Advanced (InRow(..))
import Data.Record.Anon.Advanced qualified as A
import Data.Record.Anon.Simple (Record)
import Data.Record.Anon.Simple qualified as S
import Test.Tasty
import Test.Tasty.HUnit
tests :: TestTree
tests = testGroup "Test.Sanity.BlogPost" [
testCase "showColor" test_showColor
, testCase "toJSON" test_toJSON
, testCase "parseConfig" test_parseConfig
, testCase "recordToJSON" test_recordToJSON
]
test_showColor :: Assertion
test_showColor =
assertEqual "" expected $
show magenta
where
expected :: String
expected = "ANON {red = 1.0, green = 0.0, blue = 1.0}"
test_toJSON :: Assertion
test_toJSON =
assertEqual "" expected $
Aeson.Pretty.encodePretty' aesonPrettyConfig $
toJSON magenta
where
expected :: Lazy.ByteString
expected = Lazy.BS.C8.intercalate "\n" [
"{"
, " \"red\": 1,"
, " \"green\": 0,"
, " \"blue\": 1"
, "}"
]
test_parseConfig :: Assertion
test_parseConfig = do
assertEqual "in order" expected . first show $
runParser parseConfig ["2.1", "14", "Example"]
assertEqual "out of order" expected . first show $
runParser parseConfig' ["Example", "2.1", "14"]
assertEqual "out of order, WRONG" expected' . first show $
runParser parseConfigWRONG ["Example", "2.1", "14"]
where
expected :: Either String (Record Config)
expected = Right ANON {
margin = 2.1
, fontSize = 14
, header = "Example"
}
expected' :: Either String (Record Config)
expected' = Left "(line 1, column 1):\nunexpected Example"
test_recordToJSON :: Assertion
test_recordToJSON = do
assertEqual "" expected $
Aeson.Pretty.encodePretty' aesonPrettyConfig $
recordToJSON
defaultFieldToJSON{header = FieldToJSON headerToJSON}
defaultConfig
where
expected :: Lazy.ByteString
expected = Lazy.BS.C8.intercalate "\n" [
"{"
, " \"margin\": 1,"
, " \"fontSize\": 18,"
, " \"header\": null"
, "}"
]
headerToJSON :: String -> Value
headerToJSON "" = Aeson.Null
headerToJSON xs = toJSON xs
-- | Aeson config with specific field ordering
--
-- For some reason this function results in a Core Lint warning in ghc 9.0
--
-- > *** Core Lint warnings : in result of CorePrep ***
-- > <no location info>: warning:
-- > Unsafe coercion: between unboxed and boxed value
-- > From: Int
-- > To: Int#
--
-- No idea why; this is just regular Haskell code.
aesonPrettyConfig :: Aeson.Pretty.Config
aesonPrettyConfig = Aeson.Pretty.defConfig {
Aeson.Pretty.confCompare = compare `on` (fieldIndex . Text.unpack)
}
where
-- This is pretty hacky, but it just makes the examples a bit nicer and
-- avoids compatibility problems between Aeson versions.
fieldIndex :: String -> Int
-- Color
fieldIndex "red" = 0
fieldIndex "green" = 1
fieldIndex "blue" = 2
-- Config
fieldIndex "margin" = 0
fieldIndex "fontSize" = 1
fieldIndex "header" = 2
-- Other
fieldIndex name = error $ "fieldIndex: unknown field " ++ show name
{-------------------------------------------------------------------------------
Introduction example
Introduces ANON syntax, and field get/set
-------------------------------------------------------------------------------}
magenta :: Record [ "red" := Double, "green" := Double, "blue" := Double ]
magenta = ANON { red = 1, green = 0, blue = 1 }
reduceRed :: RowHasField "red" r Double => Record r -> Record r
reduceRed c = c{red = c.red * 0.9}
{-------------------------------------------------------------------------------
The simple API
- Alternative syntax for writing records
- Alternative ways to access fields
o set/get
o lens
- Show and other standard instances
Show the signature of `showRecord`, forward reference to discussion
about `KnownFields` and `AllFields`.
- Generics (example: ToJSON)
- Subrows
-------------------------------------------------------------------------------}
purple :: Record [ "red" := Double, "green" := Double, "blue" := Double ]
purple =
S.insert #red 0.5
$ S.insert #green 0
$ S.insert #blue 0.5
$ S.empty
reduceGreen :: RowHasField "green" r Double => Record r -> Record r
reduceGreen c = S.set #green (S.get #green c * 0.9) c
reduceBlue :: RowHasField "blue" r Double => Record r -> Record r
reduceBlue = over #blue (* 0.9)
showRecord :: (KnownFields r, AllFields r Show) => Record r -> String
showRecord = show
type Config = [
"margin" := Double
, "fontSize" := Int
, "header" := String
]
defaultConfig :: Record Config
defaultConfig = ANON {
margin = 1
, fontSize = 18
, header = ""
}
render :: Record Config -> ()
render = undefined
exampleRender :: ()
exampleRender = render $ defaultConfig{margin = 2}
render' :: SubRow Config overrides => Record overrides -> ()
render' overrides = render (S.inject overrides defaultConfig)
exampleRender' :: ()
exampleRender' = render' $ ANON { margin = 2 }
{-------------------------------------------------------------------------------
Advanced API
- Functor argument
- Usefulness of ordering
-------------------------------------------------------------------------------}
magenta' :: A.Record I [ "red" := Double, "green" := Double, "blue" := Double ]
magenta' = S.toAdvanced magenta
parseConfig :: Parser (Record Config)
parseConfig = S.sequenceA $ ANON_F {
margin = parseDouble
, fontSize = parseInt
, header = parseString
}
parseConfig' :: Parser (Record Config)
parseConfig' = fmap S.project . S.sequenceA $ ANON_F {
header = parseString
, margin = parseDouble
, fontSize = parseInt
}
parseConfigWRONG :: Parser (Record Config)
parseConfigWRONG = S.sequenceA . A.project $ ANON_F {
header = parseString
, margin = parseDouble
, fontSize = parseInt
}
{-------------------------------------------------------------------------------
Slightly more elaborate example: generate JSON with per-field overrides
-------------------------------------------------------------------------------}
newtype FieldToJSON a = FieldToJSON (a -> Value)
recordToJSON :: KnownFields r => A.Record FieldToJSON r -> Record r -> Value
recordToJSON fs xs = Aeson.object . map (first fromString) $
A.toList $ A.zipWith aux fs (S.toAdvanced xs)
where
aux :: FieldToJSON x -> I x -> K Value x
aux (FieldToJSON f) (I x) = K (f x)
defaultFieldToJSON :: AllFields r ToJSON => A.Record FieldToJSON r
defaultFieldToJSON = A.cpure (Proxy @ToJSON) (FieldToJSON toJSON)
newtype NamedFieldToJSON a = NamedFieldToJSON (String -> a -> Value)
recordToJSON' :: forall r.
KnownFields r
=> A.Record NamedFieldToJSON r -> Record r -> Value
recordToJSON' fs xs = Aeson.object . map (first fromString) $
A.toList $
A.pure (fn_3 aux)
`A.ap` fs
`A.ap` A.reifyKnownFields (Proxy @r)
`A.ap` S.toAdvanced xs
where
aux :: NamedFieldToJSON x -> K String x -> I x -> K Value x
aux (NamedFieldToJSON f) (K name) (I x) = K (f name x)
{-------------------------------------------------------------------------------
Examples of proving constraints
No induction, so we must do something different.
-------------------------------------------------------------------------------}
ordImpliesEq :: AllFields r Ord => Reflected (AllFields r Eq)
ordImpliesEq =
A.reflectAllFields $
A.map aux (A.reifyAllFields (Proxy @Ord))
where
aux :: forall x. Dict Ord x -> Dict Eq x
aux Dict = Dict
smallerSatisfies :: forall r r' c.
(SubRow r r', AllFields r c)
=> Proxy c -> Proxy r -> Reflected (AllFields r' c)
smallerSatisfies pc _ =
A.reflectAllFields $
A.project (A.reifyAllFields pc :: A.Record (Dict c) r)
{-------------------------------------------------------------------------------
Advanced example: check for projection
We avoid Typeable, just to show that we can. The version in
"Test.Infra.Discovery" gives better error messages and is kind-polymorphic.
-------------------------------------------------------------------------------}
data SupportedType a where
SupportedInt :: SupportedType Int
SupportedBool :: SupportedType Bool
class IsSupportedType a where
supportedType :: Proxy a -> SupportedType a
instance IsSupportedType Int where supportedType _ = SupportedInt
instance IsSupportedType Bool where supportedType _ = SupportedBool
sameType :: SupportedType a -> SupportedType b -> Maybe (a :~: b)
sameType SupportedInt SupportedInt = Just Refl
sameType SupportedBool SupportedBool = Just Refl
sameType _ _ = Nothing
checkIsSubRow :: forall (r :: Row Type) (r' :: Row Type) proxy proxy'.
( KnownFields r
, KnownFields r'
, SubRow r r
, SubRow r' r'
, AllFields r IsSupportedType
, AllFields r' IsSupportedType
)
=> proxy r -> proxy' r' -> Maybe (Reflected (SubRow r r'))
checkIsSubRow _ _ =
A.reflectSubRow <$> go A.reifySubRow A.reifySubRow
where
go :: A.Record (InRow r ) r
-> A.Record (InRow r') r'
-> Maybe (A.Record (InRow r) r')
go r r' = A.cmapM (Proxy @IsSupportedType) (findField r) r'
findField :: forall x'.
IsSupportedType x'
=> A.Record (InRow r) r -> InRow r' x' -> Maybe (InRow r x')
findField r x' =
listToMaybe . catMaybes . A.collapse $
A.cmap (Proxy @IsSupportedType) (checkIsMatch x') r
checkIsMatch :: forall x x'.
(IsSupportedType x, IsSupportedType x')
=> InRow r' x' -> InRow r x -> K (Maybe (InRow r x')) x
checkIsMatch (InRow x') (InRow x) = K $ do
Refl <- sameSymbol x x'
Refl <- sameType (supportedType (Proxy @x)) (supportedType (Proxy @x'))
return $ InRow x
{-------------------------------------------------------------------------------
Auxiliary: simple Parsec instantation just for demonstration purposes
-------------------------------------------------------------------------------}
type Parser a = Parsec [String] () a
runParser :: Parser a -> [String] -> Either ParseError a
runParser p = Parsec.runParser p () ""
parser :: Read a => Parser a
parser = Parsec.tokenPrim id (\pos _ _ -> pos) readMaybe
parseDouble :: Parser Double
parseDouble = parser
parseInt :: Parser Int
parseInt = parser
parseString :: Parser String
parseString = Parsec.tokenPrim id (\pos _ _ -> pos) Just
#endif