From 7bd25f882ce8992f776561d684fbaa4b9352bc6d Mon Sep 17 00:00:00 2001 From: Santi Weight Date: Sun, 17 Oct 2021 14:13:56 -0700 Subject: [PATCH] Axe ParsePretty - praise be --- poker-base.cabal | 2 -- src/Poker.hs | 2 -- src/Poker/Cards.hs | 67 ++++++++++++---------------------------- src/Poker/ParsePretty.hs | 29 ----------------- test/Test/Poker/Cards.hs | 58 ++-------------------------------- 5 files changed, 23 insertions(+), 135 deletions(-) delete mode 100644 src/Poker/ParsePretty.hs diff --git a/poker-base.cabal b/poker-base.cabal index a7a3474..1e18d74 100644 --- a/poker-base.cabal +++ b/poker-base.cabal @@ -30,7 +30,6 @@ library Poker.Range other-modules: Poker.Amount - Poker.ParsePretty Poker.BigBlind Poker.Cards Poker.Game @@ -45,7 +44,6 @@ library base >= 4.11 && <5, text >= 0.11 && <1.3, containers >= 0.5 && <0.7, - megaparsec >= 7.0 && < 9.3, prettyprinter >= 1.6 && < 1.8, safe-money >= 0.9 && < 0.10 default-language: Haskell2010 diff --git a/src/Poker.hs b/src/Poker.hs index a13b6c5..ee56dd2 100644 --- a/src/Poker.hs +++ b/src/Poker.hs @@ -3,7 +3,6 @@ module Poker module Poker.BigBlind, module Poker.Cards, module Poker.Game, - module Poker.ParsePretty, module Poker.Range, ) where @@ -12,5 +11,4 @@ import Poker.Amount import Poker.BigBlind import Poker.Cards import Poker.Game -import Poker.ParsePretty import Poker.Range diff --git a/src/Poker/Cards.hs b/src/Poker/Cards.hs index 0a260b5..fbad0e7 100644 --- a/src/Poker/Cards.hs +++ b/src/Poker/Cards.hs @@ -40,8 +40,7 @@ module Poker.Cards ) where -import Control.Applicative (Alternative (empty), Applicative (liftA2)) -import Control.Monad (liftM2) +import Control.Monad (join, liftM2) #if MIN_VERSION_prettyprinter(1,7,0) import Prettyprinter import Prettyprinter.Internal ( unsafeTextWithoutNewlines, Doc(Char) ) @@ -57,13 +56,7 @@ import Data.String (IsString (fromString)) import Data.Text (Text) import qualified Data.Text as T import GHC.Stack (HasCallStack) -import Poker.ParsePretty import Poker.Utils -import Text.Megaparsec - ( MonadParsec (label), - anySingle, - (), - ) -- | The 'Rank' of a playing 'Card' data Rank @@ -85,9 +78,6 @@ data Rank instance Pretty Rank where pretty = unsafeTextWithoutNewlines . T.singleton . rankToChr -instance ParsePretty Rank where - parsePrettyP = anySingle >>= (maybe empty pure . chrToRank) "Rank" - -- | >>> allRanks -- [Two,Three,Four,Five,Six,Seven,Eight,Nine,Ten,Jack,Queen,King,Ace] allRanks :: [Rank] @@ -140,9 +130,6 @@ data Suit = Club | Diamond | Heart | Spade instance Pretty Suit where pretty = Char . suitToChr -instance ParsePretty Suit where - parsePrettyP = anySingle >>= (maybe empty pure . chrToSuit) "Suit" - -- | >>> allSuits -- [Club,Diamond,Heart,Spade] allSuits :: [Suit] @@ -201,9 +188,6 @@ data Card = Card instance Pretty Card where pretty Card {rank = r, suit = s} = pretty r <> pretty s -instance ParsePretty Card where - parsePrettyP = liftA2 Card parsePrettyP parsePrettyP - instance Enum Card where toEnum n = fromMaybe (error $ "Invalid Card enum: " <> show n) $ atMay allCards n @@ -234,7 +218,10 @@ data Hole = MkHole !Card !Card -- TODO tests instance IsString Hole where - fromString = fromJust . parsePretty . T.pack + fromString s@[r1, s1, r2, s2] = + fromMaybe (error $ "Invalid Hole: " <> s) . join $ + mkHole <$> (cardFromShortTxt . T.pack) [r1, s1] <*> (cardFromShortTxt . T.pack) [r2, s2] + fromString str = error $ "Invalid Hole: " <> str {-# COMPLETE Hole #-} @@ -294,15 +281,6 @@ instance Bounded Hole where instance Pretty Hole where pretty (Hole c1 c2) = pretty c1 <> pretty c2 --- >>> parsePretty @Hole "AhKs" --- Just (Hole (Card {rank = Ace, suit = Heart}) (Card {rank = King, suit = Spade})) -instance ParsePretty Hole where - parsePrettyP = label "Hole" $ do - c1 <- parsePrettyP - c2 <- parsePrettyP - maybe (tfailure $ "Invalid card: " <> prettyText (c1, c2)) pure $ - mkHole c1 c2 - -- | -- A 'ShapedHole' is the 'Suit'-normalised representation of a -- poker 'Hole'. For example, the 'Hole' "King of Diamonds, 5 of Hearts" is often referred @@ -338,6 +316,21 @@ pattern Offsuit r1 r2 <- MkOffsuit r1 r2 pattern Suited :: Rank -> Rank -> ShapedHole pattern Suited r1 r2 <- MkSuited r1 r2 +instance IsString ShapedHole where + fromString str = case str of + [r1,r2,s] -> + fromMaybe invalidShapedHole $ do + r1' <- chrToRank r1 + r2' <- chrToRank r2 + case s of + 'p' -> if r1' == r2' then Just $ mkPair r1' else Nothing + 'o' -> mkOffsuit r1' r2' + 's' -> mkSuited r1' r2' + _ -> Nothing + _ -> invalidShapedHole + where + invalidShapedHole = error $ "Invalid ShapedHole: " <> str + mkPair :: Rank -> ShapedHole mkPair = MkPair @@ -422,26 +415,6 @@ instance Pretty ShapedHole where pretty (Suited r1 r2) = pretty r1 <> pretty r2 <> "s" pretty (Pair r) = pretty r <> pretty r <> "p" -instance ParsePretty ShapedHole where - parsePrettyP = label "ShapedHole" $ do - r1 <- parsePrettyP @Rank - r2 <- parsePrettyP @Rank - let rs = (r1, r2) - anySingle >>= \case - 'p' -> if r1 /= r2 then invalidShapedFail "Pair" rs else pure $ MkPair r1 - 'o' -> - if r1 == r2 - then invalidShapedFail "Offsuit" rs - else pure $ unsafeMkOffsuit r1 r2 - 's' -> - if r1 == r2 - then invalidShapedFail "Suited" rs - else pure $ unsafeMkSuited r1 r2 - _ -> tfailure "Unexpected hand shape" - where - invalidShapedFail name rs = - tfailure $ "Invalid " <> name <> " ranks: " <> prettyText rs - newtype Deck = UnsafeMkDeck [Card] deriving (Read, Show, Eq) {-# COMPLETE Deck #-} diff --git a/src/Poker/ParsePretty.hs b/src/Poker/ParsePretty.hs deleted file mode 100644 index cb2711c..0000000 --- a/src/Poker/ParsePretty.hs +++ /dev/null @@ -1,29 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} - -module Poker.ParsePretty where - -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Void (Void) -import Poker.Utils (terror) -import Text.Megaparsec (MonadParsec, empty, parseMaybe, ()) -#if MIN_VERSION_prettyprinter(1,7,0) -import Prettyprinter (Pretty) -#else -import Data.Text.Prettyprint.Doc -#endif - --- | A class for parsing the output of the 'Pretty' instance for @a@. -class Pretty a => ParsePretty a where - parsePrettyP :: Ord e => MonadParsec e Text m => m a - -tfailure :: MonadParsec e Text m => Text -> m a -tfailure err = empty T.unpack err - -parsePretty :: ParsePretty a => Text -> Maybe a -parsePretty = parseMaybe $ parsePrettyP @_ @Void - -unsafeParsePretty :: ParsePretty a => Text -> a -unsafeParsePretty txt = fromMaybe (terror $ "Not a valid value: " <> txt) . parsePretty $ txt diff --git a/test/Test/Poker/Cards.hs b/test/Test/Poker/Cards.hs index 875d022..d1bd4ae 100644 --- a/test/Test/Poker/Cards.hs +++ b/test/Test/Poker/Cards.hs @@ -16,10 +16,9 @@ import Data.Functor import Data.List.Extra import Data.Maybe import Data.Text (Text) -import qualified Data.Text as T import Poker import Test.Hspec -import Test.Tasty.QuickCheck +import Data.String (IsString(fromString)) spec_rankToChr :: SpecWith () spec_rankToChr = do @@ -49,30 +48,6 @@ spec_cardFromShortTxt = do it "cardFromShortTxt \"Acd\" == Nothing" $ cardFromShortTxt "Acd" `shouldBe` Nothing it "cardFromShortTxt \"AcAd\" == Nothing" $ cardFromShortTxt "AcAd" `shouldBe` Nothing -spec_CardPrettyAndParse :: SpecWith () -spec_CardPrettyAndParse = do - describe "Check Pretty and ParsePretty form isomorphism" $ - forM_ cardCases genTestCase - where - genTestCase (cardStr, card) = do - it (T.unpack $ "parsePretty " <> cardStr) $ - parsePretty cardStr - `shouldBe` Just card - -prop_badCardParse :: Gen Property -prop_badCardParse = do - cardStr <- - liftA2 - (\a b -> T.pack [a, b]) - arbitraryASCIIChar - arbitraryASCIIChar - pure $ - cardStr `notElem` allValidCardStrs - ==> isNothing - (parsePretty @Card cardStr) - where - allValidCardStrs = fst <$> cardCases - cardCases :: [(Text, Card)] cardCases = [ ("As", Card Ace Spade), @@ -129,33 +104,6 @@ cardCases = ("2c", Card Two Club) ] -spec_isoPrettyParseRank :: SpecWith () -spec_isoPrettyParseRank = checkPrettyParseEnumIso @Rank "Rank" - -spec_isoPrettyParseSuit :: SpecWith () -spec_isoPrettyParseSuit = checkPrettyParseEnumIso @Suit "Suit" - -spec_isoPrettyParseCard :: SpecWith () -spec_isoPrettyParseCard = checkPrettyParseEnumIso @Card "Card" - -spec_isoPrettyParseHole :: SpecWith () -spec_isoPrettyParseHole = checkPrettyParseEnumIso @Hole "Hole" - -spec_isoPrettyParseShapedHole :: SpecWith () -spec_isoPrettyParseShapedHole = checkPrettyParseEnumIso @ShapedHole "ShapeHole" - -checkPrettyParseEnumIso :: - forall a. - (Eq a, ParsePretty a, Enum a, Bounded a, Show a) => - String -> - SpecWith () -checkPrettyParseEnumIso typeName = - describe ("pretty and parse form iso" <> typeName) $ - mapM_ (\val -> it (show val) $ roundTrip val == val) (enumerate @a) - where - renderPrettyT = T.pack . show . pretty - roundTrip = unsafeParsePretty . renderPrettyT - spec_mkHole :: SpecWith () spec_mkHole = do let aceS = Card Ace Spade @@ -245,8 +193,8 @@ spec_shapedHoleToHoles = do ] mkCase name combo expected = it name $ - shapedHoleToHoles (unsafeParsePretty combo) - `shouldBe` unsafeParsePretty + shapedHoleToHoles (fromString combo) + `shouldBe` fromString <$> expected spec_toUnicode :: SpecWith ()