sayable-1.2.3.0: test/Test.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- The -ddump-splices writes the sayableSubConstraints output to stdout during
-- compilation:
{-- OPTIONS_GHC -ddump-splices #-}
import Data.Maybe ( catMaybes )
import Data.Text ( Text )
import qualified Language.Haskell.TH as TH
import qualified Prettyprinter as PP
import Text.Sayable
import Test.Hspec
import Test.Tasty
import Test.Tasty.Hspec
import Test.Tasty.Runners.AntXML
import Helpers
data Bar = Bar
data Baz = Baz Bar
data Foo = Foo { fld1 :: Bar
, fld2 :: [Baz]
, fld3 :: Maybe Bar
}
data HiddenValue = HiddenValue Char
data Foo2 = FC1 Bar [Maybe Baz] | FC2 Bar Int HiddenValue
data Bar3 a = Bar3 (Maybe a)
data Baz3 a b = BazL a | BazR b
data Foo3 a = Foo3 { inputs :: Bar3 a, outputs :: Baz3 a String }
$(return [])
instance Sayable "loud" Bar where sayable _ = t'"BAR" &+ '!'
instance {-# OVERLAPPABLE #-} Sayable stag Bar where sayable _ = t'"bar" &+ '.'
-- This instance has no constraints, so the "loud" will not invoke the proper
-- Sayable for Bar.
instance Sayable stag Baz where sayable (Baz bar) = t'"baz" &- bar
-- This instance has the necessary constraints (via our TH helper) so the "loud"
-- Sayable for Bar will be properly invoked.
instance $(sayableSubConstraints $ ofType ''Foo >> tagVar "stag"
) => Sayable stag Foo where
sayable foo = t'"Foo" &- fld1 foo &+ ',' &* fld2 foo &+ ',' &? fld3 foo &- 'E'
-- TH-supplied sub-element constraints for Foo2 with a filter. Also verify that
-- only the last of the tag specification operations is used.
instance $(sayableSubConstraints $ do ofType ''Foo2
-- tagNat 3
tagSym "three"
subElemFilter foo2Filter
tagVar "t"
) => Sayable t Foo2 where
sayable = \case
FC1 x y -> t'"First Foo2 form with" &- x &- t'"and" &* catMaybes y
FC2 x y _ -> t'"Second Foo2 form with" &- x &- y
-- TH-supplied sub-element constraints for Foo3 with parameterized sub-elements.
instance $(sayableSubConstraints $ do ofType ''Foo3
tagVar "t"
paramVar "a"
paramTH (TH.ConT ''String)
) => Sayable t (Foo3 a) where
sayable f3 = t'"Foo3" &- inputs f3 &- t'"-->" &- outputs f3
-- TH-supplied sub-element constraints with explicit override
instance $(sayableSubConstraints $ do ofType ''Bar3
paramVar "a"
tagSym "loud"
) => Sayable "loud" (Bar3 a) where
sayable (Bar3 mba) = t'"BAR3" &? mba
instance {-# OVERLAPPABLE #-}
$(sayableSubConstraints $ paramVar "a" >> ofType ''Bar3
) => Sayable saytag (Bar3 a) where
sayable (Bar3 mba) = t'"bar3" &? mba
-- TH-supplied sub-element constraints with explicit override
instance $(sayableSubConstraints $ do paramVar "a"
tagSym "loud"
paramTH $ TH.ConT ''String
ofType ''Baz3
) => Sayable "loud" (Baz3 a String) where
sayable = \case
BazL a -> t'"BAZL" &- a
BazR b -> t'"BAZR" &- b
instance {-# OVERLAPPABLE #-}
$(sayableSubConstraints $ do ofType ''Baz3
paramVar "a"
paramTH $ TH.ConT ''String
paramNat 0 -- extra: ignored
paramVar "a" -- extra: ignored
tagVar "lvl"
) => Sayable lvl (Baz3 a String) where
sayable = \case
BazL a -> t'"bazl" &- a
BazR b -> t'"bazr" &- b
----------------------------------------------------------------------
main :: IO ()
main = tests >>= defaultMainWithIngredients (antXMLRunner : defaultIngredients)
tests :: IO TestTree
tests = testGroup "Sayable" <$> sequence
[
testSpec "Operators" $
describe "operator results shown in haddocks" $ do
it "renders &-" $
(sez @"info" $ t'"hello" &- t'"world") `shouldBe` "hello world"
it "renders &+" $
(sez @"info" $ t'"hello" &+ t'"world") `shouldBe` "helloworld"
it "renders &%" $
(sez @"info" $ t'"hello" &% (t'"world", t'"!")) `shouldBe` "hello (world, !)"
it "renders &!" $
(sez @"info" $ PP.group &! t'"hi") `shouldBe` "hi"
it "renders &*" $
(sez @"info" $ t'"three:" &* [1, 2, 3::Int]) `shouldBe` "three: 1, 2, 3"
it "renders &+*" $
(sez @"info" $ t'"three:" &- '(' &+* [1, 2, 3::Int] &+ ')')
`shouldBe` "three: (1, 2, 3)"
it "renders &:*" $
(sez @"info" $ t'"three:" &- t'".." &:* [1, 2, 3::Int])
`shouldBe` "three: 1..2..3"
it "renders &!*" $
(sez @"info" $ t'"three:" &- PP.align . PP.vsep &!* [1, 2, 3::Int])
`shouldBe` "three: 1, \n 2, \n 3"
it "renders &!$*" $
(sez @"info" $ t'"three:" &- PP.align &!$* [1, 2, 3::Int])
`shouldBe` "three: 1, 2, 3"
it "renders &!:*" $
(sez @"info" $ t'"three:" &- (PP.align . PP.vsep &!:* (t'" or")) [1, 2, 3::Int])
`shouldBe` "three: 1 or\n 2 or\n 3"
it "renders &?" $
(sez @"info" $ t'"It's" &? Just (t'"something") &- t'"or" &? (Nothing :: Maybe Text))
`shouldBe` "It's something or"
it "renders &!?" $
(sez @"info" $ PP.group &!? Just (t'"hi")) `shouldBe` "hi"
it "renders &<" $
(sez @"info" $ t'"Hello" &< t'"world") `shouldBe` "Hello\nworld"
it "renders &<*" $
(sez @"info" $ t'"three:" &<* [1, 2, 3::Int]) `shouldBe` "three:\n1, 2, 3"
it "renders &<? Just" $
(sez @"info" $ t'"First" &<? Just (t'"something"))
`shouldBe` "First\nsomething"
it "renders &<? Nothing" $
(sez @"info" $ t'"Then" &<? (Nothing :: Maybe Text)) `shouldBe` "Then"
it "renders &+?" $
(sez @"info" $ t'"It's" &+? (Nothing :: Maybe Text) &- t'"ok" &+? Just ("time" :: Text))
`shouldBe` "It's oktime"
, testSpec "sub-constraints" $ do
-- As described in the haddocks for sayableSubConstraints
describe "sub-constraints working" $ do
let v = Foo Bar [Baz Bar, Baz Bar] $ Just Bar
-- Foo does have sub-element constraints, so "loud" is different than
-- "normal", unlike Baz which doesn't express sub-constraints and therefore
-- its sub-elements don't properly get the propagated Sayable tag.
it "normal rendering" $
(sez @"normal" v) `shouldBe` "Foo bar., baz bar., baz bar., bar. E"
it "loud rendering" $
(sez @"loud" v) `shouldBe` "Foo BAR!, baz bar., baz bar., BAR! E"
describe "sub-constraints constructor filtering" $ do
let v = FC2 Bar 0 (HiddenValue 'h')
it "normal rendering" $
(sez @"normal" v) `shouldBe` "Second Foo2 form with bar. 0"
it "loud rendering" $
(sez @"loud" v) `shouldBe` "Second Foo2 form with BAR! 0"
describe "sub-constraints with varBindings" $ do
let v = Foo3 (Bar3 (Just (Bar3 (Just (9 :: Int))))) (BazL (Bar3 Nothing))
it "normal rendering" $
(sez @"normal" v) `shouldBe` "Foo3 bar3 bar3 9 --> bazl bar3"
it "loud rendering" $
(sez @"loud" v) `shouldBe` "Foo3 BAR3 BAR3 9 --> BAZL BAR3"
]