Fix chapter 24

24-parser-combination/24-parser-combination.md

@@ -0,0 +1,29 @@
+# 24 Parser Combination
+
+## 24.3 Parsing practise
+
+[src/LearnParsers.hs](./src/LearnParsers.hs)
+
+## 24.4 Exercise: Unit of Success
+
+`(>>)` is actually `(*>)` from `Applicative` and `Applicative` also has `(<*)`
+which has type `Applicative f => f a -> f b -> f a` So the solution here is:
+`integer <* eof`
+
+## 24.6 Exercise: Try Try
+
+[src/TryTry.hs](./src/TryTry.hs)
+
+## 24.11 Chapter Exercises
+
+1. [src/SemVer.hs](./src/SemVer.hs)
+2. [src/PosInt.hs](./src/PosInt.hs)
+3. [src/PosInt.hs](./src/PosInt.hs)
+4. [src/PhoneNumber.hs](./src/PhoneNumber.hs)
+5. [src/ParseLog.hs](./src/ParseLog.hs)
+6. [src/IPAddress.hs](./src/IPAddress.hs)
+7. [src/IPAddress.hs](./src/IPAddress.hs)
+8. [src/IPAddress.hs](./src/IPAddress.hs)
+9. [src/IPAddress.hs](./src/IPAddress.hs)
+10. Probably not going to finish this at this time. It's a lot of the same
+    but just a lot more.

24-parser-combination/24.11-chapter-exercises.md

@@ -1,11 +0,0 @@
-# Chapter Exercises
-1. see src/SemVer.hs
-2. see src/PosInt.hs
-3. see src/PosInt.hs
-4. see src/PhoneNumber.hs
-5. see src/ParseLog.hs
-6. see src/IPAddress.hs
-7. see src/IPAddress.hs
-8. see src/IPAddress.hs
-9. see src/IPAddress.hs
-10. Not done (yet).

24-parser-combination/24.3-parsing-practise.md

@@ -1,2 +0,0 @@
-# Exercises: Parsing Practise
-see src/LearnParsers.hs

24-parser-combination/24.4-unit-of-success.md

@@ -1,4 +0,0 @@
-# Exercise: Unit of Success
-`(>>)` is actually `(*>)` from `Applicative` and `Applicative` also has `(<*)` which has type `Applicative f => f a -> f b -> f a`
-
-So the solution here is: `integer <* eof`

24-parser-combination/24.6-try-try.md

@@ -1,2 +0,0 @@
-# Exercise: Try Try
-see src/TryTry.hs

24-parser-combination/src/DOTParser.hs

@@ -0,0 +1,33 @@
+module DOTParser where
+
+import Text.Trifecta
+import Data.Char (toLower, toUpper)
+import Control.Applicative ((<|>))
+
+iChar :: Char -> Parser Char
+iChar c = char (toLower c) <|> char (toUpper c)
+
+iString :: String -> Parser String
+iString s = sequenceA $ fmap iChar s
+
+data CompassPT = N | NE | E | SE | S | SW | W | NW | C | O deriving (Show, Eq)
+
+pCompass :: Parser CompassPT
+pCompass =
+    -- North
+    try (iString "ne" *> pure NE) <|>
+    try (iString "nw" *> pure NW) <|>
+    (iString "n" *> pure N) <|>
+    -- East
+    (iString "e" *> pure E) <|>
+    -- South
+    try (iString "se" *> pure SE) <|>
+    try (iString "sw" *> pure SW) <|>
+    (iString "s" *> pure S) <|>
+    -- West
+    (iString "w" *> pure W) <|>
+    -- Others
+    (iString "c" *> pure C) <|> (string "_" *> pure O)
+
+newtype ID = ID String deriving (Eq, Show)
+

24-parser-combination/src/IPAddress.hs

@@ -2,21 +2,139 @@
 
 module IPAddress where
 
+import Control.Applicative ((<|>), liftA2, liftA3)
 import Text.Trifecta hiding (span)
-import Data.Word
-import Data.Bits
-import Data.List (splitAt)
-import Numeric (readHex, showHex)
-import Control.Monad.State
-import Data.Maybe (fromMaybe)
--- import Data.List (group, span)
-import Data.Either (lefts)
--- import qualified Data.Sequence as S
+import Data.Word (Word32, Word64)
+import Data.Bits (shiftL, shiftR, (.&.))
+import Control.Monad (replicateM)
+import Text.Parser.Char (char)
+import Data.Char (toLower, ord)
+import Data.List (intersperse, span)
+import Numeric (showHex)
 
 import Test.Hspec
 
 -- Exercise 6
 data IPAddress = IPAddress Word32 deriving (Eq, Ord)
+
+parseDecOctet :: CharParsing m => m Integer
+parseDecOctet =
+    fmap read $ case1 <|> case2 <|>  case3 <|> case4 <|> case5
+    where case1 = try $ sequenceA [char '2', char '5', oneOf "012345"]
+          case2 = try $ sequenceA [char '2', oneOf "01234", digit]
+          case3 = try $ sequenceA [char '1', digit, digit]
+          case4 = try $ sequenceA [oneOf "123456789", digit]
+          case5 = pure <$> digit
+
+shiftLFolder :: Int -> [Integer] -> Integer
+shiftLFolder i = fst . foldr f (0, 0)
+    where f a (t, s) = ((a `shiftL` s) + t, s + i)
+
+parseIPv4Address :: CharParsing m => m IPAddress
+parseIPv4Address =
+    let wDot = char '.' *> parseDecOctet
+        words = liftA2 (:) parseDecOctet $ replicateM 3 wDot
+    in IPAddress . fromInteger . shiftLFolder 8 <$> words
+
+-- Exercise 7
+data IPAddress6 = IPAddress6 Word64 Word64 deriving (Eq, Ord)
+
+-- From RFC 3986
+
+-- IPv6address   =                            6( h16 ":" ) ls32
+-- /                       "::" 5( h16 ":" ) ls32
+-- / [               h16 ] "::" 4( h16 ":" ) ls32
+-- / [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32
+-- / [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32
+-- / [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32
+-- / [ *4( h16 ":" ) h16 ] "::"              ls32
+-- / [ *5( h16 ":" ) h16 ] "::"              h16
+-- / [ *6( h16 ":" ) h16 ] "::"
+-- h16           = 1*4HEXDIG
+-- ls32          = ( h16 ":" h16 ) / IPv4address
+
+-- "::" = Cons
+data IPv6ParseOption =
+    NoCons | Cons0 | Cons1 | Cons2 | Cons3 | Cons4 | Cons5 | Cons6 | Cons7
+
+-- This is just the representation of the ABNF from the RFC
+parseIPv6Address :: Parser IPAddress6
+parseIPv6Address = fmap f $ (try $ parseOption NoCons)
+                 <|> (try $ parseOption Cons0)
+                 <|> (try $ parseOption Cons1)
+                 <|> (try $ parseOption Cons2)
+                 <|> (try $ parseOption Cons3)
+                 <|> (try $ parseOption Cons4)
+                 <|> (try $ parseOption Cons5)
+                 <|> (try $ parseOption Cons6)
+                 <|> parseOption Cons7
+    where f = integerToIPv6Address . shiftLFolder 16
+
+integerToIPv6Address :: Integer -> IPAddress6
+integerToIPv6Address n =
+    let [w1, w2] = fmap f [n `shiftR` 64, n]
+        f = fromInteger . (.&. 0xFFFFFFFFFFFFFFFF)
+    in IPAddress6 w1 w2
+
+parseOption :: IPv6ParseOption -> Parser [Integer]
+parseOption o = liftA3 f (parseFirst o) (parseMiddle o) (parseLast o)
+    where f s1 s2 s3 = s1 ++ s2 ++ s3
+
+parseFirst :: IPv6ParseOption -> Parser [Integer]
+parseFirst o = case o of
+    NoCons -> pure []
+    Cons0 -> string "::" *> pure [0]
+    Cons1 -> (try $ lower Cons0) <|> go 0
+    Cons2 -> (try $ lower Cons1) <|> go 1
+    Cons3 -> (try $ lower Cons2) <|> go 2
+    Cons4 -> (try $ lower Cons3) <|> go 3
+    Cons5 -> (try $ lower Cons4) <|> go 4
+    Cons6 -> (try $ lower Cons5) <|> go 5
+    Cons7 -> (try $ lower Cons6) <|> go 6
+    where lower o' = liftA2 (++) (parseFirst o') (pure [0])
+          go n = liftA2 (++) (rep n) (parseFirst Cons0)
+          rep n = liftA2 (++) (replicateM n piece) end
+          piece = parseH16 <* char ':'
+          end = sequenceA [parseH16]
+
+parseMiddle :: IPv6ParseOption -> Parser [Integer]
+parseMiddle o = case o of
+    NoCons -> rep 6
+    Cons0 -> rep 5
+    Cons1 -> rep 4
+    Cons2 -> rep 3
+    Cons3 -> rep 2
+    Cons4 -> rep 1
+    otherwise -> pure []
+    where rep n = replicateM n (parseH16 <* char ':')
+
+parseLast :: IPv6ParseOption -> Parser [Integer]
+paresLast Cons6 = sequenceA [parseH16]
+parseLast Cons7 = pure []
+parseLast _ = parseLs32
+
+parseLs32 :: Parser [Integer]
+parseLs32 = try case1 <|> case2
+    where case1 = sequenceA [parseH16 <* char ':', parseH16]
+          case2 = toWord16s <$> parseIPv4Address
+          toWord16s (IPAddress w) =
+            let w' = toInteger w
+            in fmap (.&. 0xFFFF) [w' `shiftR` 16, w']
+
+parseH16 :: Parser Integer
+parseH16 = fmap (shiftLFolder 4) $ try four <|> try three <|> try two <|> one
+    where four = replicateM 4 parseHexDig
+          three = replicateM 3 parseHexDig
+          two = replicateM 2 parseHexDig
+          one = replicateM 1 parseHexDig
+
+parseHexDig :: Parser Integer
+parseHexDig = d <|> h
+    where d = read <$> sequenceA [digit]
+          h = f . toLower <$> oneOf "abcdefABCDEF"
+          f c = toInteger $ ord c - ord 'a' + 10
+
+-- Exercise 8
 instance Show IPAddress where
     show (IPAddress w32) =
         let n = toInteger w32
@@ -25,36 +143,54 @@ instance Show IPAddress where
            show ((n `shiftR` 8)  .&. 0xFF) ++ "." ++
            show (n .&. 0xFF)
 
-parseValidIPByte :: Parser Word8
-parseValidIPByte = do
-    i <- decimal 
-    let max' = toInteger (maxBound :: Word8)
-        min' = toInteger (minBound :: Word8)
-    if i <= max' && i >= min'
-    then return (fromInteger i)
-    else unexpected "Invalid byte"
-
-parseIPv4Address :: Parser IPAddress
-parseIPv4Address = do
-    b1 <- toInteger <$> parseValidIPByte
-    _  <- char '.'
-    b2 <- toInteger <$> parseValidIPByte
-    _  <- char '.'
-    b3 <- toInteger <$> parseValidIPByte
-    _  <- char '.'
-    b4 <- toInteger <$> parseValidIPByte
-    return $ IPAddress . fromInteger $ (b1 `shiftL` 24) +
-                                       (b2 `shiftL` 16) +
-                                       (b3 `shiftL`  8) +
-                                       b4
+-- RFC 5952
+instance Show IPAddress6 where
+    show i = concat $ intersperse ":" $ processed
+        where processed = fmap fix longest
+              longest = repLongestListOfZeroes $ collapseZeroes asStrings
+              asStrings = fmap (flip showHex "") (toArray i)
+              fix x = if length x > 1 then intersperse ':' x else x
+
+toArray :: IPAddress6 -> [Integer]
+toArray (IPAddress6 w1 w2) = go w1 ++ go w2
+    where go w = reverse $ take 4 $ f (toInteger w)
+          f w = w .&. mask : f (w `shiftR` 16)
+          mask = 0xFFFF
+
+collapseZeroes :: [String] -> [String]
+collapseZeroes [] = []
+collapseZeroes xs = nonZeroes ++ zeroes ++ remainder
+    where (nonZeroes, rest) = span (/= "0") xs
+          (zeroes', rest') = span (== "0") rest
+          zeroes = [concat zeroes']
+          remainder = collapseZeroes rest'
+
+repLongestListOfZeroes :: [String] -> [String]
+repLongestListOfZeroes xs = h ++ rep t
+    where (h, t) = span (p . length) xs
+          p x = (max' < 2) || (x /= max')
+          max' = maximum $ fmap length xs
+          rep [] = []
+          rep (x:xs) = "":xs
+
+-- Exercise 9
+toIPAddress6 :: IPAddress -> IPAddress6
+toIPAddress6 (IPAddress w32) = IPAddress6 0 (fromIntegral w32)
+
+toIPAddress :: IPAddress6 -> Maybe IPAddress
+toIPAddress (IPAddress6 w64 w64')
+    | w64 /= 0 = Nothing
+    | w64' > (fromIntegral $ (maxBound :: Word32)) = Nothing
+    | otherwise = Just $ IPAddress (fromIntegral w64')
 
+-- Tests
 maybeSuccess :: Result a -> Maybe a
 maybeSuccess (Success a) = Just a
 maybeSuccess _ = Nothing
-
-testByteHelper :: String -> Maybe Word8 -> Expectation
-testByteHelper s r = do
-    let m = parseString parseValidIPByte mempty s
+-- IPv4
+testDecOctetHelper :: String -> Maybe Integer -> Expectation
+testDecOctetHelper s r = do
+    let m = parseString parseDecOctet mempty s
         r' = maybeSuccess m
     r' `shouldBe` r
 
@@ -64,14 +200,19 @@ testIPv4Helper s r = do
         r' = maybeSuccess m
     r' `shouldBe` r
 
-testByte :: IO ()
-testByte = hspec $ do
+testDecOctet :: IO ()
+testDecOctet = hspec $ do
     describe "Test parsing of byte" $ do
-        it "Can parse 0" $ testByteHelper "0" (Just 0)
-        it "Can parse 255" $ testByteHelper "255" (Just 255)
-        it "Can't parse 256" $ testByteHelper "256" Nothing
-        it "Can't parse -1" $ testByteHelper "-1" Nothing
-        it "Can't parse empty" $ testByteHelper "" Nothing    
+        it "Can parse 0" $ testDecOctetHelper "0" (Just 0)
+        it "Can parse 10" $ testDecOctetHelper "10" (Just 10)
+        it "Can parse 100" $ testDecOctetHelper "100" (Just 100)
+        it "Can parse 249" $ testDecOctetHelper "249" (Just 249)
+        it "Can parse 255" $ testDecOctetHelper "255" (Just 255)
+        it "Can parse 260 as 26" $ testDecOctetHelper "256" (Just 25)
+        it "Can parse 256 as 25" $ testDecOctetHelper "256" (Just 25)
+        it "Can parse 2550 as 255" $ testDecOctetHelper "2550s" (Just 255)
+        it "Can't parse -1" $ testDecOctetHelper "-1" Nothing
+        it "Can't parse empty" $ testDecOctetHelper "" Nothing
 
 testIPv4 :: IO ()
 testIPv4 = hspec $ do
@@ -87,188 +228,99 @@ testIPv4 = hspec $ do
         it "Can't parse 0..0.0.0" $ do
             testIPv4Helper "0..0.0.0" Nothing
 
-toIPAddress6 :: IPAddress -> IPAddress6
-toIPAddress6 (IPAddress w32) = IPAddress6 0 (fromIntegral w32)
-
--- Exercise 7
-
--- Datatypes:
-data IPAddress6 = IPAddress6 Word64 Word64 deriving (Eq, Ord)
--- An IPv6Piece is the part between ':', it can be either
--- "::" or "ABCD"
-type IPv6Piece = Either () Word16
-
---
-toArray :: IPAddress6 -> [Word16]
-toArray (IPAddress6 w64 w64') =
-    let n = toInteger w64
-        m = toInteger w64'
-        mask = fromInteger . (\a -> (.&.) a 0xFFFF)
-    in mask (n `shiftR` 48) :
-       mask (n `shiftR` 32) :
-       mask (n `shiftR` 16) :
-       mask n :
-       mask (m `shiftR` 48) :
-       mask (m `shiftR` 32) :
-       mask (m `shiftR` 16) :
-       mask m : []
-
-toArray' :: [Word16] -> [Either Int Word16]
-toArray' [] = []
-toArray' s@(0:0:_) = (Left $ length ys) : (toArray' zs)
-    where (ys, zs) = span (==0) s
-toArray' (x:xs) = (Right x) : toArray' xs
-
-findMax :: [Either Int Word16] -> Maybe Int
-findMax xs = go $ lefts xs
-    where go [] = Nothing
-          go ys = Just $ maximum ys
-
-replaceLeft :: Int -> [Either Int Word16] -> [IPv6Piece]
-replaceLeft m xs = go m xs False
-    where go _ [] _ = []
-          go i ((Right c):ys) b = (Right c) : (go i ys b)
-          go i ((Left c):ys) False = 
-            if (c == i)
-            then (Left ()) : (go i ys True)
-            else (replicate c (Right 0)) ++ (go i ys False)
-          go i ((Left c):ys) True = (replicate c (Right 0)) ++ (go i ys True)
-
-showPieces :: [IPv6Piece] -> String
-showPieces [] = ""
-showPieces ((Right c):ys) = (showHex c "") ++ (go ys)
-    where go [] = []
-          go (Right c':zs) = ":" ++ (showHex c' "") ++ (go zs)
-          go zs = showPieces zs
-showPieces ((Left ():ys)) = "::" ++ (showPieces ys)
-            
+-- IPv6
+testParseFirstHelper :: IPv6ParseOption
+                     -> String
+                     -> Maybe [Integer]
+                     -> Expectation
+testParseFirstHelper o s r = do
+    let m = parseString (parseFirst o) mempty s
+        r' = maybeSuccess m
+    r' `shouldBe` r
 
-instance Show IPAddress6 where
-    show p = let xs = toArray' (toArray p)
-             in showPieces $ (case findMax xs of
-                                     Nothing -> replaceLeft 0 xs
-                                     (Just i) -> replaceLeft i xs)
-
-validHex :: String
-validHex = "abcdefABCDEF0123456789"
-
--- Helper functions
--- only parses [0-9A-Fa-f]{1,4}
-readWord16 :: String -> Maybe Word16
-readWord16 s =
-    let r = readHex  (take 4 s) :: [(Word16, String)]
-    in case r of
-        ((w,s'):[]) -> if s' == "" then Just w else Nothing
-        _ -> Nothing
-
-mkWord64 :: Word16 -> Word16 -> Word16 -> Word16 -> Word64
-mkWord64 a b c d = (fromIntegral a `shiftL` 48) +
-                   (fromIntegral b `shiftL` 32) +
-                   (fromIntegral c `shiftL` 16) +
-                   (fromIntegral d)
-
-mkIPAddress6 :: [Word16] -> Maybe IPAddress6
-mkIPAddress6 xs = 
-    case length xs of
-        8 -> let (a,b) = splitAt 4 xs
-                 w1 = (mkWord64 (a !! 0) (a !! 1) (a !! 2) (a !! 3))
-                 w2 = (mkWord64 (b !! 0) (b !! 1) (b !! 2) (b !! 3))
-             in Just $ IPAddress6 w1 w2                             
-        _ -> Nothing
-
-expandIPv6Pieces :: [IPv6Piece] -> Maybe [Word16]
-expandIPv6Pieces xs =
-    case length $ filter (==(Left ())) xs of
-        0 -> Just $ foldr f [] xs
-        1 -> Just $ foldr g [] xs
-        _ -> Nothing
-    where f (Left _)  s = s
-          f (Right c) s = c:s
-          n = max (9 - (length xs)) 0
-          g (Left _)  s = (take n $ repeat 0) ++ s
-          g (Right c) s = c:s
-
-getIPAddress6 :: [IPv6Piece] -> Maybe IPAddress6
-getIPAddress6 xs = expandIPv6Pieces xs >>= mkIPAddress6
-
-type IPv6State = Bool
-type IPv6Parser a = StateT IPv6State Parser a
-
--- Parsing the individual pieces:
--- hex, 1-4 hexes, ':', '::'
-parseSingleHex :: IPv6Parser Char
-parseSingleHex = do
-    c <- oneOf validHex
-    return c
-
-parseIPv6Hex :: IPv6Parser Word16
-parseIPv6Hex = do
-    c1 <- parseSingleHex <?> "At least one hex"
-    o  <- mapStateT f $ count 3 $ optional parseSingleHex
-    let s = c1 : (fromMaybe "" o)
-    case readWord16 s of
-        Just w  -> return w
-        Nothing -> unexpected $ "Invalid piece: " ++ s
-    where f :: Parser ([Maybe Char], IPv6State) 
-            -> Parser (Maybe [Char], IPv6State)
-          f = fmap (\(c,b) -> (sequence c, b))
-
-parseSep :: IPv6Parser String
-parseSep = do
-    c <- string ":"
-    return c
-
-parseCons :: IPv6Parser (Maybe IPv6Piece)
-parseCons = do
-    b <- get
-    c <- optional $ string "::"
-    case c of
-        Nothing -> return Nothing
-        Just _ -> if b
-                  then unexpected "Only one '::' allowed"
-                  else do
-                    put True
-                    return (Just $ Left ())
-
--- Parses: 
---  ::ABCD
---  :ABCD                   
-parseInnerParts :: IPv6Parser [IPv6Piece]
-parseInnerParts = do
-    c <- parseCons
-    case c of
-        Nothing -> do
-            parseSep
-            w <- parseIPv6Hex
-            return [Right w]
-        Just _ -> do
-            w <- parseIPv6Hex
-            return [Left (), Right w]
-
-
-parseIPv6Address :: IPv6Parser IPAddress6
-parseIPv6Address = do
-    c <- parseCons
-    w <- parseIPv6Hex
-    a <- case c of
-            Nothing -> do            
-                xs <- mapStateT f $ many parseInnerParts
-                c' <- parseCons
-                case c' of
-                    Nothing -> return ([Right w] ++ xs)
-                    Just _  -> return ([Right w] ++ xs ++ [Left ()])
-            Just _ -> do
-                xs <- mapStateT f $ many parseInnerParts
-                return $ ([Left ()] ++ [Right w] ++ xs)
-    case getIPAddress6 a of
-        Nothing -> unexpected "Invalid format"
-        Just a' -> return a'        
-    where f :: Parser ([[IPv6Piece]], IPv6State) 
-            -> Parser ([IPv6Piece], IPv6State)
-          f = fmap (\(xs, b) -> (concat xs, b))
+testParseFirst :: IO ()
+testParseFirst = hspec $ do
+    describe "Test parsing of parseFirst NoCons" $ do
+        it "Can parse anything" $ do
+            testParseFirstHelper NoCons "" (Just [])
+    describe "Test parsing of parseFirst Cons0" $ do
+        it "Can parse only '::'" $ do
+            testParseFirstHelper Cons0 "::" (Just [0])
+        it "Cannot parse non '::'" $ do
+            testParseFirstHelper Cons0 "a::" (Nothing)
+    describe "Test parsing of parseFirst Cons1" $ do
+        it "Can parse only '::'" $ do
+            testParseFirstHelper Cons1 "::" (Just [0, 0])
+        it "Can parse 'f::'" $ do
+            testParseFirstHelper Cons1 "f::" (Just [15,0])
+        it "Cannot parse f:f::" $ do
+            testParseFirstHelper Cons1 "f:f::" Nothing
+    describe "Test parsing of parseFirst Cons2" $ do
+        it "Can parse only '::'" $ do
+            testParseFirstHelper Cons2 "::" (Just [0, 0, 0])
+        it "Can parse 'f::'" $ do
+            testParseFirstHelper Cons2 "f::" (Just [15,0,0])
+        it "Can parse 'f:f::'" $ do
+            testParseFirstHelper Cons2 "f:f::" (Just [15,15,0])
+        it "Cannot parse f:f:f::" $ do
+            testParseFirstHelper Cons2 "f:f:f::" Nothing
+    describe "Test parsing of parseFirst Cons3" $ do
+        it "Can parse only '::'" $ do
+            testParseFirstHelper Cons3 "::" (Just [0, 0, 0, 0])
+        it "Can parse 'f::'" $ do
+            testParseFirstHelper Cons3 "f::" (Just [15,0,0,0])
+        it "Can parse 'f:f::'" $ do
+            testParseFirstHelper Cons3 "f:f::" (Just [15,15,0,0])
+        it "Can parse 'f:f:f::'" $ do
+            testParseFirstHelper Cons3 "f:f:f::" (Just [15,15,15,0])
+        it "Cannot parse f:f:f:f::" $ do
+            testParseFirstHelper Cons3 "f:f:f:f::" Nothing
+    describe "Test parsing of parseFirst Cons4" $ do
+        it "Can parse only '::'" $ do
+            testParseFirstHelper Cons4 "::" (Just [0, 0, 0, 0, 0])
+        it "Can parse 'f::'" $ do
+            testParseFirstHelper Cons4 "f::" (Just [15,0,0,0, 0])
+        it "Can parse 'f:f::'" $ do
+            testParseFirstHelper Cons4 "f:f::" (Just [15,15,0,0,0])
+        it "Can parse 'f:f:f::'" $ do
+            testParseFirstHelper Cons4 "f:f:f::" (Just [15,15,15,0, 0])
+        it "Can parse f:f:f:f::" $ do
+            testParseFirstHelper Cons4 "f:f:f:f::" (Just [15,15,15,15, 0])
+        it "Cannot parse f:f:f:f:f::" $ do
+            testParseFirstHelper Cons4 "f:f:f:f:f::" Nothing
+    describe "Test parsing of parseFirst Cons5" $ do
+        it "Can parse only '::'" $ do
+            testParseFirstHelper Cons5 "::" (Just [0, 0, 0, 0, 0, 0])
+        it "Can parse 'f::'" $ do
+            testParseFirstHelper Cons5 "f::" (Just [15,0,0,0, 0, 0])
+        it "Can parse 'f:f::'" $ do
+            testParseFirstHelper Cons5 "f:f::" (Just [15,15,0,0,0, 0])
+        it "Can parse 'f:f:f::'" $ do
+            testParseFirstHelper Cons5 "f:f:f::" (Just [15,15,15,0, 0, 0])
+        it "Can parse f:f:f:f::" $ do
+            testParseFirstHelper Cons5 "f:f:f:f::" (Just [15,15,15,15, 0, 0])
+        it "Can parse f:f:f:f:f::" $ do
+            testParseFirstHelper Cons5 "f:f:f:f:f::" (Just [15,15,15,15,15, 0])
+        it "Cannot parse f:f:f:f:f:f::" $ do
+            testParseFirstHelper Cons5 "f:f:f:f:f:f::" Nothing
+    -- rest is copy-paste but also not necessary since they're all
+    -- handled the same way in the parseFirst method.
+
+
+testIPv6Helper :: String -> Maybe IPAddress6 -> Expectation
+testIPv6Helper s r = do
+    let m = parseString parseIPv6Address mempty s
+        r' = maybeSuccess m
+    r' `shouldBe` r
 
-toIPAddress :: IPAddress6 -> Maybe IPAddress
-toIPAddress (IPAddress6 w64 w64')
-    | w64 /= 0 = Nothing
-    | w64' > (fromIntegral $ (maxBound :: Word32)) = Nothing
-    | otherwise = Just $ IPAddress (fromIntegral w64')
+testIPv6 :: IO ()
+testIPv6 = hspec $ do
+    describe "Test parsing of IPv6" $ do
+        it "Can parse 0:0:1:0:0:0:1:0" $ do
+            testIPv6Helper "0:0:1:0:0:0:1:0" (Just (IPAddress6 65536 65536))
+        it "Can parse ::0:1:0:0:0:1:0" $ do
+            testIPv6Helper "::0:1:0:0:0:1:0" (Just (IPAddress6 65536 65536))
+        it "Can parse ::1:0:0:0:1:0" $ do
+            testIPv6Helper "::1:0:0:0:1:0" (Just (IPAddress6 65536 65536))
+        it "Can parse 0::1:0:0:0:1:0" $ do
+            testIPv6Helper "0::1:0:0:0:1:0" (Just (IPAddress6 65536 65536))

24-parser-combination/src/ParseLog.hs

@@ -3,15 +3,18 @@
 
 module ParseLog where
 
-import Control.Applicative ((<|>), liftA2)
+import Control.Applicative ((<|>), liftA2, liftA3)
 import Data.Monoid ((<>))
 import Text.Trifecta
 import Data.Time.Format
 import Data.Time
 import Data.List (intersperse)
 import Text.RawString.QQ
-
+import Text.Parser.Token
+import Control.Monad (replicateM)
+import Data.Maybe
 import Test.QuickCheck
+import Data.Char
 
 data LogEntry = LogEntry TimeOfDay String deriving Eq
 instance Show LogEntry where
@@ -20,7 +23,10 @@ instance Show LogEntry where
         in time ++ " " ++ s
 instance Arbitrary LogEntry where
     arbitrary = do
-        tod <- TimeOfDay <$> choose (0,23) <*> choose (0,59) <*> pure 0
+        tod <- liftA3 TimeOfDay
+                      (choose (0,23))
+                      (choose (0,59))
+                      (pure 0)
         s <- liftA2 (++)
                     arbitrary
                     (oneof [((++) "--") <$> arbitrary, arbitrary])
@@ -62,64 +68,78 @@ countDay (DayEntry _ e) = countTimeSpentDay e
 countTime :: Log -> DiffTime
 countTime (Log ds) = sum $ map countDay ds
 
-skipBlankLines :: Parser ()
-skipBlankLines =
-    skipMany $ (skipWhiteSpace >> skipComment >> newline) <|>
-            (skipWhiteSpace >> newline)
+skipComment :: (Monad m, TokenParsing m) => m ()
+skipComment = token $ do
+    string "--"
+    manyTill anyChar $ try newline
+    return ()
 
-skipComment :: Parser ()
-skipComment = skipMany $ do
-    _ <- count 2 $ char '-'
-    skipMany $ notChar '\n'
+myToken :: (Monad m, TokenParsing m) => m a -> m a
+myToken p = token p <* (token $ skipSome skipComment <|> pure ())
 
-skipWhiteSpace :: Parser ()
-skipWhiteSpace = skipMany $ oneOf "\t "
+-- token :: m a -> m a
+-- token p = p <* (someSpace <|> pure ())
 
-removeComment :: String -> String
-removeComment [] = []
-removeComment (x:xs) = go "" x False xs
-    where go s '-' True _ = s -- skip comment
-          go s '-' False [] = s ++ "-" -- ended with '-'
-          go s c _ [] = s ++ [c] -- ended without comment
-          go s '-' False (y:ys) = go s y True ys -- possible start of comment
-          go s c _ (y:ys) = go (s ++ [c]) y False ys
+parseHour :: Parser String
+parseHour = case1 <|> case2
+    where case1 = sequenceA [oneOf "01", digit]
+          case2 = sequenceA [char '2', oneOf "0123"]
 
+parseMinutes :: Parser String
+parseMinutes = sequenceA [ oneOf "012345", digit]
 
-parseLogEntry :: Parser LogEntry
-parseLogEntry = do
-    t <- count 2 digit <> string ":" <> count 2 digit 
-    let m = parseTimeM True defaultTimeLocale "%H:%M" t
-    timeOfDay <- case m of
+parseTimeOfDay :: Parser TimeOfDay
+parseTimeOfDay = do
+    timeString <- parseHour <> string ":" <> parseMinutes
+    case parseTimeM True defaultTimeLocale "%H:%M" timeString of
         Just time -> return time
         Nothing -> unexpected "Incorrect time format"
-    _ <- space
-    s <- some $ notChar '\n'
-    _ <- newline
-    return $ LogEntry timeOfDay (removeComment s)
 
-parseDayEntry :: Parser DayEntry
-parseDayEntry = do
-    _ <- char '#'
-    _ <- space
-    d <- some digit <> string "-" 
-           <> count 2 digit <> string "-" 
-           <> count 2 digit
-    let m = parseTimeM True defaultTimeLocale "%Y-%m-%d" d
-    day <- case m of
+parseLogEntry :: Parser LogEntry
+parseLogEntry = myToken $ do
+    tod <- parseTimeOfDay
+    space
+    s <- manyTill anyChar ((newline >> return ()) <|> skipComment)
+    return $ LogEntry tod s
+
+parseYear :: Parser String
+parseYear = count 4 digit
+
+-- This is actually also a cool way to do this, where the year
+-- can consist up to 4 digits instead of 4, but this is not in the spirit of
+-- the exercise I believe. year should be in "YYYY" format.
+-- parseYear = liftA2 (:) digit (catMaybes <$> replicateM 3 d)
+--     where d = try $ optional digit
+
+parseMonth :: Parser String
+parseMonth = case1 <|> case2
+    where case1 = sequenceA [ char '0', digit ]
+          case2 = sequenceA [ char '1', oneOf "012"]
+
+parseDay :: Parser String
+parseDay = case1 <|> case2
+    where case1 = sequenceA [ oneOf "012", digit ]
+          case2 = sequenceA [ char '3', oneOf "01" ]
+
+parseDay' :: Parser Day
+parseDay' = do
+    day <- parseYear <> string "-" <> parseMonth <> string "-" <> parseDay
+    case parseTimeM True defaultTimeLocale "%Y-%m-%d" day of
         Just day' -> return day'
         Nothing -> unexpected "Incorrect day format"
-    -- only thing allowed after day is whitespace and comments
-    skipWhiteSpace
-    skipComment
-    _ <- newline
-    -- Followed by a list of paserLogEntries
+
+parseDayEntry :: Parser DayEntry
+parseDayEntry = myToken $ do
+    char '#'
+    space
+    day <- myToken $ parseDay'
     logEntries <- many parseLogEntry
-    skipBlankLines
     return $ DayEntry day logEntries
 
 parseLog :: Parser Log
 parseLog  = do
-    skipBlankLines
+    whiteSpace
+    skipMany skipComment
     dayEntries <- many parseDayEntry
     return $ Log dayEntries
 

24-parser-combination/src/PhoneNumber.hs

@@ -3,13 +3,23 @@
 module PhoneNumber where
 
 import Control.Applicative ((<|>))
+import Control.Monad (replicateM)
+
 import Text.Trifecta
 import Test.Hspec
 
+import qualified Test.QuickCheck as Q
+import qualified Test.QuickCheck.Property as QP
+import Test.QuickCheck.Arbitrary
+import Test.QuickCheck.Gen
+
+import Data.Maybe (isJust)
+import Data.Char (isDigit)
+
 -- This is an exercise for the Belgian Phone numbers system
 -- From wikipedia
 {-
-Belgian telephone numbers consist of two major parts: Firstly '0', secondly the 
+Belgian telephone numbers consist of 3 major parts: First '0', second the
 "zone prefix" (A) which is 1 or 2 digits long for landlines and 3 digits long
 for mobile phones and thirdly the "subscriber's number" (B).
 
@@ -46,6 +56,7 @@ data ZonePrefix = MobileZP String
                 | LandOneZP String
                 | LandTwoZP String
                 deriving (Eq)
+
 instance Show ZonePrefix where
     show (MobileZP s)  = "0" ++ s
     show (LandOneZP s) = "  0" ++ s
@@ -55,6 +66,7 @@ data SubscribersNumber = MobileSN String
                        | LandOneSN String
                        | LandTwoSN String
                        deriving (Eq)
+
 instance Show SubscribersNumber where
     show (LandOneSN (a:b:c:d:e:f:g:[])) = a:b:c:" " ++ d:e:" " ++ f:g:[]
     show (LandOneSN s) = "Invalid format: " ++ s
@@ -64,43 +76,32 @@ instance Show SubscribersNumber where
     show (LandTwoSN s) = "Invalid format: " ++ s
 
 data PhoneNumberBE = PhoneNumberBE ZonePrefix SubscribersNumber deriving Eq
+
 instance Show PhoneNumberBE where
     show (PhoneNumberBE z s) = "(PhoneNumberBE " ++ show z
                                                  ++ " "
                                                  ++ show s
                                                  ++ ")"
 
-
 -- Mobile numbers are: 046x 047x 048x 049x
 -- Land lines are most other things where:
 --  02,03,04 and 09 are single digit land line area codes
 --  the rest are two digit land line phone
 parseZonePrefix :: Parser ZonePrefix
 parseZonePrefix =
-    let mobile  = MobileZP <$> do
-                    one <- char '4'
-                    two <- oneOf ['6', '7', '8', '9']
-                    three <- digit
-                    return $ [one, two, three]
+    let mobile  = do
+            one <- char '4'
+            two <- oneOf ['6', '7', '8', '9']
+            three <- digit
+            return $ MobileZP [one, two, three]
         landOne = LandOneZP . (:[]) <$> oneOf ['2', '3', '4', '9']
         landTwo = LandTwoZP <$> count 2 digit
     -- Order is important, we want to check mobile first, followed by
     -- landOne. Everything else is assumed to be land two
-    in mobile <|> landOne <|> landTwo
-
-parseMobileSN :: Parser SubscribersNumber
-parseMobileSN = do
-    let p = count 2 digit
-        skip = skipOptional $ char ' ' <|> char '.'
-    p1 <- p
-    skip
-    p2 <- p
-    skip
-    p3 <- p
-    return . MobileSN $ p1 ++ p2 ++ p3
+    in try mobile <|> landOne <|> landTwo
 
-parseLandTwoSN :: Parser SubscribersNumber
-parseLandTwoSN = do
+parseSNOfSix :: Parser String
+parseSNOfSix = do
     let p = count 2 digit
         skip = skipOptional $ char ' ' <|> char '.'
     p1 <- p
@@ -108,10 +109,10 @@ parseLandTwoSN = do
     p2 <- p
     skip
     p3 <- p
-    return . LandTwoSN $ p1 ++ p2 ++ p3
+    return $ p1 ++ p2 ++ p3
 
-parseLandOneSN :: Parser SubscribersNumber
-parseLandOneSN = do
+parseSNOfSeven :: Parser String
+parseSNOfSeven = do
     let p = count 2 digit
         skip = skipOptional $ char ' ' <|> char '.'
     p1 <- count 3 digit
@@ -119,7 +120,7 @@ parseLandOneSN = do
     p2 <- p
     skip
     p3 <- p
-    return . LandTwoSN $ p1 ++ p2 ++ p3
+    return $ p1 ++ p2 ++ p3
 
 parsePhone :: Parser PhoneNumberBE
 parsePhone = do
@@ -128,45 +129,186 @@ parsePhone = do
     -- white space
     skipMany $ char ' '
     -- Leading zero depends on country code
-    skipOptional $ char ' ' 
     _ <- case m of
         Just _  -> do
-                    a <- optional $ char '0'
-                    case a of
-                        Nothing -> return Nothing
-                        Just _ -> unexpected "0 not expected here"
+            a <- optional $ char '0'
+            case a of
+                Nothing -> return Nothing
+                Just _ -> unexpected "0 not expected here"
         Nothing -> Just <$> char '0'
     z <- parseZonePrefix
     skipOptional $ char ' ' <|> char '/'
     s <- case z of
-            MobileZP _  -> parseMobileSN
-            LandOneZP _ -> parseLandOneSN
-            LandTwoZP _ -> parseLandTwoSN
+            MobileZP _  -> MobileSN <$> parseSNOfSix
+            LandOneZP _ -> LandOneSN <$> parseSNOfSix
+            LandTwoZP _ -> LandTwoSN <$> parseSNOfSeven
     return $ PhoneNumberBE z s
 
+-- Tests
+
 maybeSuccess :: Result a -> Maybe a
 maybeSuccess (Success a) = Just a
 maybeSuccess _ = Nothing
 
--- Should test all options for mobile and single-digit land lines,
--- but that is just copy-paste... QuickCheck could also help.
+-- ZonePrefix
+validMobileZonePrefix :: [String]
+validMobileZonePrefix =
+    [(++) "4"] <*> (map ((++) . show) [6..9] <*> map show [0..9])
+
+validLandOneZonePrefix :: [String]
+validLandOneZonePrefix = ["2", "3", "4", "9"]
+
+validLandTwoZonePrefix :: [String]
+validLandTwoZonePrefix =
+    map (++) ["1", "5", "6", "7", "8"] <*> map show [0..9]
+
+invalidZonePrefix :: [String]
+invalidZonePrefix = ["0", "a"]
+
+validMobileZonePrefixTest :: (String -> ZonePrefix) -> String -> SpecWith ()
+validMobileZonePrefixTest zp input = do
+    it ("Zone prefix: " ++ input) $ do
+        let m = parseString parseZonePrefix mempty input
+            r = maybeSuccess m
+        r `shouldBe` Just (zp input)
+
+invalidZonePrefixTest :: String -> SpecWith ()
+invalidZonePrefixTest input = do
+    it ("Zone prefix: " ++ input) $ do
+        let m = parseString parseZonePrefix mempty input
+            r = maybeSuccess m
+        r `shouldBe` Nothing
+
+zonePrefixTests :: Spec
+zonePrefixTests = do
+    describe "Parsing valid Mobile Zone Prefixes" $ do
+        mapM_ (validMobileZonePrefixTest MobileZP) validMobileZonePrefix
+    describe "Parsing valid Land One Zone Prefixes" $ do
+        mapM_ (validMobileZonePrefixTest LandOneZP) validLandOneZonePrefix
+    describe "Parsing valid Land Two Zone Prefixes" $ do
+        mapM_ (validMobileZonePrefixTest LandTwoZP) validLandTwoZonePrefix
+    describe "Parsing invalid Zone Prefixes" $ do
+        mapM_ invalidZonePrefixTest invalidZonePrefix
+
+gen_MobileZP :: Gen String
+gen_MobileZP = do
+    c1 <- elements ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
+    c2 <- elements ['6', '7', '8', '9']
+    return $ ['4', c2, c1]
+
+gen_LandOneZP :: Gen String
+gen_LandOneZP = elements ["2", "3", "4", "9"]
+
+gen_LandTwoZP :: Gen String
+gen_LandTwoZP = do
+    c1 <- elements ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
+    c2 <- elements ['1', '5', '6', '7', '8']
+    return $ [c2, c1]
+
+prop_ZP :: Gen String -> (String -> ZonePrefix) -> QP.Property
+prop_ZP g c = QP.forAll g $ \input ->
+    let r = maybeSuccess m
+        m = parseString parseZonePrefix mempty input
+    in isJust r
+
+-- Subscriber Number
+gen_MobileSN :: Gen String
+gen_MobileSN = do
+    let c = elements ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
+    p1 <- replicateM 2 c
+    r <- replicateM 2 $ do
+        s1 <- elements [" ",  "."]
+        p2 <- replicateM 2 c
+        return $ s1 ++ p2
+    return $ p1 ++ (concat r)
+
+gen_LandOneSN :: String -> Gen String
+gen_LandOneSN zp = do
+    let c = elements ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
+    c1 <- case zp of
+            "4" -> elements ['0', '1', '2', '3', '4', '5']
+            otherwise -> c
+    c2 <- c
+    r <- replicateM 2 $ do
+        s1 <- elements [" ",  "."]
+        p2 <- replicateM 2 c
+        return $ s1 ++ p2
+    return $ c1:c2:(concat r)
+
+gen_LandOneSN' :: Gen String
+gen_LandOneSN' = do
+    zp <- gen_LandOneZP
+    gen_LandOneSN zp
+
+gen_LandTwoSN :: Gen String
+gen_LandTwoSN = do
+    let c = elements ['0', '1', '2', '3', '4', '5', '6', '7', '8', '9']
+    p1 <- replicateM 3 c
+    r <- replicateM 2 $ do
+        s1 <- elements [" ",  "."]
+        p2 <- replicateM 2 c
+        return $ s1 ++ p2
+    return $ p1 ++ (concat r)
+
+prop_SN :: Gen String -> Parser String -> QP.Property
+prop_SN g p = QP.forAll g $ \input ->
+    let r = maybeSuccess m
+        m = parseString p mempty input
+    in isJust r
+
+-- Phone Number
+gen_Spaces :: Gen String
+gen_Spaces = listOf $ return ' '
+
+gen_CountryCode :: Gen String
+gen_CountryCode = do
+    sp <- gen_Spaces
+    return $ "+32" ++ sp
+
+gen_NoCountryCode :: Gen String
+gen_NoCountryCode = do
+    sp <- gen_Spaces
+    return $ sp ++ "0"
+
+gen_MobileNumber :: Gen String
+gen_MobileNumber = do
+    cc <- oneof [gen_CountryCode, gen_NoCountryCode]
+    zp <- gen_MobileZP
+    sep <- elements ["/", " ", ""]
+    sn <- gen_MobileSN
+    return $ cc ++ zp ++ sep ++ sn
+
+gen_LandOneNumber :: Gen String
+gen_LandOneNumber = do
+    cc <- oneof [gen_CountryCode, gen_NoCountryCode]
+    zp <- gen_LandOneZP
+    sep <- elements ["/", " ", ""]
+    sn <- gen_LandOneSN zp
+    return $ cc ++ zp ++ sep ++ sn
+
+gen_LandTwoNumber :: Gen String
+gen_LandTwoNumber = do
+    cc <- oneof [gen_CountryCode, gen_NoCountryCode]
+    zp <- gen_LandTwoZP
+    sep <- elements ["/", " ", ""]
+    sn <- gen_LandTwoSN
+    return $ cc ++ zp ++ sep ++ sn
+
+prop_PhoneNumberBE :: QP.Property
+prop_PhoneNumberBE = QP.forAll g $ \input ->
+        let r = maybeSuccess m
+            m = parseString parsePhone mempty input
+        in isJust r
+    where g = oneof [gen_MobileNumber, gen_LandOneNumber, gen_LandTwoNumber]
+
 main :: IO ()
-main = hspec $ do
-    describe "Parse Zone Prefix" $ do
-        it "Mobile starts with 4[6-9]x " $ do
-            let m = parseString parseZonePrefix mempty "472"
-                r = maybeSuccess m
-            r `shouldBe` Just (MobileZP "472")
-        it "Incorrect mobile zone prefix should fail" $ do
-            let m = parseString parseZonePrefix mempty "47"
-                r = maybeSuccess m
-            r `shouldBe` Nothing
-        it "Land line with single digit" $ do
-            let m = parseString parseZonePrefix mempty "2"
-                r = maybeSuccess m
-            r `shouldBe` Just (LandOneZP "2")
-        it "Land line with double digit" $ do
-            let m = parseString parseZonePrefix mempty "55"
-                r = maybeSuccess m
-            r `shouldBe` Just (LandTwoZP "55")
-    -- ...
+main = do
+    hspec $ do
+        zonePrefixTests
+    Q.quickCheck $ prop_ZP gen_MobileZP MobileZP
+    Q.quickCheck $ prop_ZP gen_LandOneZP LandOneZP
+    Q.quickCheck $ prop_ZP gen_LandTwoZP LandTwoZP
+    Q.quickCheck $ prop_SN gen_MobileSN parseSNOfSix
+    Q.quickCheck $ prop_SN gen_LandOneSN' parseSNOfSix
+    Q.quickCheck $ prop_SN gen_LandTwoSN parseSNOfSeven
+    Q.quickCheckWith Q.stdArgs { Q.maxSuccess = 10000 } $ prop_PhoneNumberBE

24-parser-combination/src/PosInt.hs

@@ -10,7 +10,7 @@ parseDigit = oneOf ['0'..'9']
 
 base10Integer :: Parser Integer
 base10Integer = do
-    xs <- some $ (\a -> read (a:"")) <$> parseDigit
+    xs <- (fmap . fmap) (read . (:[])) $ some parseDigit
     return $
       fst $ foldr (\a (b,i) -> (a * i + b, i*10)) (0,1) xs
 
@@ -118,4 +118,3 @@ main = hspec $ do
             let m = parseString base10Integer' mempty "-123abc"
                 r = maybeSuccess m
             r `shouldBe` Just (-123)
-    

24-parser-combination/src/SemVer.hs

@@ -19,21 +19,8 @@ data SemVer = SemVer Major Minor Patch Release Metadata deriving (Eq, Show)
 -- Probably nicer ways of doing this?
 instance Ord SemVer where
     compare (SemVer major minor patch _ _)
-            (SemVer major' minor' patch' _ _) =
-    --    case compare major major' of
-    --     GT -> GT
-    --     LT -> LT
-    --     EQ ->
-    --         case compare minor minor' of
-    --             GT -> GT
-    --             LT -> LT
-    --             EQ ->
-    --                 case compare patch patch' of
-    --                     GT -> GT
-    --                     LT -> LT
-    --                     EQ -> EQ 
-        mconcat $ 
-        zipWith compare [major, minor, patch] [major', minor', patch']
+            (SemVer major' minor' patch' _ _) = mconcat $
+                zipWith compare [major, minor, patch] [major', minor', patch']
 
 validChars :: [Char]
 validChars = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']