large-anon-0.3.3: test/Test/Sanity/BlogPost.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
#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.Bifunctor
import Data.Function (on)
import Data.Kind
import Data.Maybe
import Data.SOP (fn_3)
import Data.String
import Data.Type.Equality
import GHC.TypeLits
import Optics.Core (over)
import Text.Parsec (Parsec, ParseError)
import Text.Read (readMaybe)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson.Pretty
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as Lazy.BS.C8
import qualified Data.Text as Text
import qualified Text.Parsec as Parsec
import Data.Record.Anon
import Data.Record.Anon.Simple (Record)
import Data.Record.Anon.Advanced (InRow(..))
import qualified Data.Record.Anon.Advanced as A
import qualified Data.Record.Anon.Simple 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