Merge pull request #29 from santiweight/axe-parse-pretty

Axe ParsePretty - praise be

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

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

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) )
@@ -55,13 +54,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
@@ -83,9 +76,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]
@@ -138,9 +128,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]
@@ -199,9 +186,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 IsString Card where
   fromString = fromJust . cardFromShortTxt . T.pack
 
@@ -223,7 +207,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 #-}
 
@@ -266,15 +253,6 @@ allHoles = reverse $ do
 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
@@ -310,6 +288,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
 
@@ -377,26 +370,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 #-}

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,23 +104,6 @@ cardCases =
     ("2c", Card Two Club)
   ]
 
-spec_isoPrettyParseRank :: SpecWith ()
-spec_isoPrettyParseRank = checkPrettyParseEnumIso @Rank "Rank"
-
-spec_isoPrettyParseSuit :: SpecWith ()
-spec_isoPrettyParseSuit = checkPrettyParseEnumIso @Suit "Suit"
-
-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
@@ -236,8 +194,8 @@ spec_shapedHoleToHoles = do
       ]
     mkCase name combo expected =
       it name $
-        shapedHoleToHoles (unsafeParsePretty combo)
-          `shouldBe` unsafeParsePretty
+        shapedHoleToHoles (fromString combo)
+          `shouldBe` fromString
           <$> expected
 
 spec_toUnicode :: SpecWith ()