Add solutions to the parser combinators chapter

Author: BoeingX

package.yaml

@@ -22,11 +22,17 @@ description:         Please see the README on GitHub at <https://github.com/Boei
 dependencies:
 - base >= 4.7 && < 5
 - transformers
+- containers
+- bytestring
+- text
+- raw-strings-qq
+- random
+- trifecta
+- parsers
 - hspec
 - QuickCheck
 - checkers
 - hspec-checkers
-- random
 - split
 
 library:

src/ParserCombinators/Alternative/IntermissionExercise.hs

@@ -0,0 +1,26 @@
+module ParserCombinators.Alternative.IntermissionExercise where
+
+import Control.Applicative
+import Data.Ratio ((%))
+import Text.Trifecta
+
+instance (Eq a) => Eq (Result a) where
+    Success a == Success b = a == b
+    Failure a == Failure b = True
+    _ == _ = False
+
+parseFraction :: Parser Rational
+parseFraction = do
+    numerator <- decimal
+    char '/'
+    denominator <- decimal
+    case denominator of
+        0 -> fail "Denominator cannot be zero"
+        _ -> return (numerator % denominator)
+
+type IntegerOrRational = Either Rational Integer
+
+parseIor :: Parser IntegerOrRational
+parseIor = try (Left <$> parseFraction) <|> try (Right <$> decimal)
+-- This will not work
+-- parseIor = (Left <$> parseFraction) <|> (Right <$> decimal)

src/ParserCombinators/ChapterExercises/IPV4Addresses.hs

@@ -0,0 +1,45 @@
+module ParserCombinators.ChapterExercises.IPV4Addresses where
+
+import Control.Applicative
+import Data.Word
+import Data.List
+import Text.Trifecta
+import Test.QuickCheck (Arbitrary, arbitrary)
+
+instance (Eq a) => Eq (Result a) where
+    Success a == Success b = a == b
+    Failure a == Failure b = True
+    _ == _ = False
+
+data IPAddress = IPAddress Word32
+    deriving (Eq, Ord)
+
+instance Show IPAddress where
+    show (IPAddress x) = intercalate "." $ map (show . binToDecimal) x''
+        where x' = pad 32 0 $ decimalToBin x
+              x'' = separateEvery 8 x'
+
+instance Arbitrary IPAddress where
+    arbitrary = IPAddress <$> arbitrary
+
+ipAddress :: Parser IPAddress
+ipAddress = IPAddress . fromIntegral . binToDecimal . dotDecimalToBin <$> sepBy integer (char '.')
+
+decimalToBin :: (Integral a) => a -> [a]
+decimalToBin n
+  | n <= 1      = [n]
+  | otherwise   = decimalToBin (n `div` 2) ++ [n `mod` 2]
+
+pad :: Int -> a -> [a] -> [a]
+pad n a xs = replicate nPad a ++ xs
+    where nPad = max (n - length xs) 0
+
+dotDecimalToBin :: (Integral a) => [a] -> [a]
+dotDecimalToBin = concatMap (pad 8 0 . decimalToBin)
+
+binToDecimal :: (Integral a) => [a] -> a
+binToDecimal = foldl' (\acc x -> acc * 2 + x) 0
+
+separateEvery :: Int -> [a] -> [[a]]
+separateEvery _ [] = []
+separateEvery n xs = take n xs : separateEvery n (drop n xs)

src/ParserCombinators/ChapterExercises/IPV6Addresses.hs

@@ -0,0 +1,68 @@
+module ParserCombinators.ChapterExercises.IPV6Addresses where
+
+import Control.Applicative
+import qualified Data.Map as M
+import Data.Char
+import Data.Word
+import Data.List
+import Data.Maybe
+import Text.Trifecta
+import Test.QuickCheck (Arbitrary, arbitrary)
+
+instance (Eq a) => Eq (Result a) where
+    Success a == Success b = a == b
+    Failure a == Failure b = True
+    _ == _ = False
+
+data IPAddress6 = IPAddress6 Word64 Word64
+    deriving (Eq, Ord)
+
+instance Show IPAddress6 where
+    show (IPAddress6 x y) = intercalate ":" $ map stripLeadingZeros xy
+        where x' = pad 16 '0' $ decimalToHex x
+              y' = pad 16 '0' $ decimalToHex y
+              xy = separateEvery 4 $ x' ++ y'
+
+instance Arbitrary IPAddress6 where
+    arbitrary = liftA2 IPAddress6 arbitrary arbitrary
+
+ipAddress6 :: Parser IPAddress6
+ipAddress6 = do
+    xs <- sepBy (many (noneOf ":")) (char ':')
+    let ys = map (pad 4 '0') $ uncollapse xs
+        ys1 = fromIntegral $ hexToDecimal $ concat $ take 4 ys
+        ys2 = fromIntegral $ hexToDecimal $ concat $ drop 4 ys
+    return $ IPAddress6 ys1 ys2
+
+uncollapse :: [String] -> [String]
+uncollapse xs = go xs
+    where n = 8 - length (filter (/= "") xs)
+          go [] = []
+          go (y : ys)
+            | y == "" = replicate n "0" ++ ys
+            | otherwise = y : go ys
+
+stripLeadingZeros :: String -> String
+stripLeadingZeros "" = ""
+stripLeadingZeros [x] = [x]
+stripLeadingZeros (x:xs)
+  | x == '0'    = stripLeadingZeros xs
+  | otherwise   = x : xs
+
+pad :: Int -> a -> [a] -> [a]
+pad n x xs = replicate (n - length xs) x ++ xs
+
+hexToDecimal :: (Integral a) => String -> a
+hexToDecimal = foldl' (\acc x -> acc * 16 + lookup x) 0
+    where vocab = M.fromList $ zip "0123456789ABCDEF" [0..15]
+          lookup x = fromJust $ M.lookup (toUpper x) vocab
+
+decimalToHex :: (Integral a) => a -> String
+decimalToHex n
+  | n < 16      = [vocab !! fromIntegral n]
+  | otherwise   = decimalToHex (n `div` 16) ++ [vocab !! fromIntegral (n `mod` 16)]
+    where vocab = "0123456789ABCDEF"
+
+separateEvery :: Int -> [a] -> [[a]]
+separateEvery _ [] = []
+separateEvery n xs = take n xs : separateEvery n (drop n xs)

src/ParserCombinators/ChapterExercises/LogFile.hs

@@ -0,0 +1,107 @@
+module ParserCombinators.ChapterExercises.LogFile where
+
+import Control.Applicative
+import Data.List
+import Text.Trifecta
+
+instance (Eq a) => Eq (Result a) where
+    Success a == Success b = a == b
+    Failure a == Failure b = True
+    _ == _ = False
+
+-- Some types
+type Year = Integer
+type Month = Integer
+type Day = Integer
+
+data Date = Date Year Month Day
+    deriving (Show, Eq)
+
+type Hour = Integer
+type Minute = Integer
+
+data Time = Time Hour Minute
+    deriving (Show, Eq)
+
+type StartTime = Time
+type Name = String
+type Duration = Double
+
+data Activity = Activity StartTime Name
+    deriving (Show, Eq)
+
+data Daily = Daily Date [Activity]
+    deriving (Show, Eq)
+
+-- Parsing
+comment :: Parser String
+comment = try (spaces >> string "--" >> many (noneOf "\n"))
+
+eol :: Parser ()
+eol = (newline >> return ()) <|> (comment >> return ())
+
+-- This function is tricky
+-- We have to 1) ignore comments started with -- and all white spaces before
+--            2) handle correctly a single dash
+parseName :: Parser String
+parseName =  (eof >> return "")
+         <|> (eol >> return "")
+         <|> (liftA2 (:) anyChar parseName)
+
+parseDate :: Parser Date
+parseDate = do
+    string "# "
+    year <- integer
+    char '-'
+    month <- integer
+    char '-'
+    day <- integer
+    many newline
+    return $ Date year month day
+    
+parseTime :: Parser Time
+parseTime = do
+    hour <- integer
+    char ':'
+    minute <- integer
+    return $ Time hour minute
+
+parseActivity :: Parser Activity
+parseActivity = do
+    startTime <- parseTime
+    -- integer consumes the trailing zero
+    -- so `_ <- char ' '` gives an error
+    skipMany (char ' ')
+    name <- parseName
+    skipMany eol
+    return $ Activity startTime name
+
+parseDaily :: Parser Daily
+parseDaily = do
+    date <- parseDate
+    skipMany eol
+    activities <- some parseActivity
+    return $ Daily date activities
+
+parseLog :: Parser [Daily]
+parseLog = skipMany eol >> some parseDaily
+
+-- Group by the first component and aggregate the second component
+-- with a binary operator
+groupByOp :: Eq a => (b -> b -> b) -> [(a, b)] -> [(a, b)]
+groupByOp op = map reduce . groupBy (\a a' -> fst a == fst a')
+    where reduce = liftA2 (,) (head . map fst) (foldr1 op . map snd)
+
+dailySummary :: Daily -> [(Name, Duration)]
+dailySummary (Daily _ activities) = nameDurations
+    where getDuration (Activity t1 n1) (Activity t2 _) = (n1, timeDiff t1 t2)
+          timeDiff (Time h1 m1) (Time h2 m2) = fromIntegral $ (h2 * 60 + m2) - (h1 * 60 + m1)
+          nameDurations = groupByOp (+) $ sortOn fst $ zipWith getDuration activities (tail activities)
+
+summary :: [Daily] -> [(Name, Duration)]
+summary = groupByOp (+) . sortOn fst . concatMap dailySummary
+
+-- Average time spent on each activity
+avgTime :: [Daily] -> [(Name, Duration)]
+avgTime xs = map (\(name, duration) -> (name, duration / len)) $ summary xs
+    where len = fromIntegral $ length xs

src/ParserCombinators/ChapterExercises/ParseDigitAndInteger.hs

@@ -0,0 +1,28 @@
+module ParserCombinators.ChapterExercises.ParseDigitAndInteger where
+
+import Control.Applicative
+import Data.List
+import Text.Trifecta
+
+instance (Eq a) => Eq (Result a) where
+    Success a == Success b = a == b
+    Failure a == Failure b = True
+    _ == _ = False
+
+parseDigit :: Parser Char
+parseDigit = oneOf $ concatMap show [0..9]
+
+readChar :: (Read a) => Char -> a
+readChar a = read [a]
+
+base10Integer :: Parser Integer
+base10Integer = do
+    -- (<?>) give parser a name
+    -- See https://hackage.haskell.org/package/parsers-0.12.9/docs/Text-Parser-Combinators.html
+    digits <- some parseDigit <?> "integer"
+    return $ (foldl1' (\acc x -> 10 * acc + x) . map readChar) digits
+
+base10Integer' :: Parser Integer
+base10Integer' =  (char '+' >> base10Integer) 
+              <|> (char '-' >> base10Integer >>= \x -> return (-x))
+              <|> base10Integer

src/ParserCombinators/ChapterExercises/PhoneNumbers.hs

@@ -0,0 +1,42 @@
+module ParserCombinators.ChapterExercises.PhoneNumbers where
+
+import Control.Applicative
+import Data.List
+import Text.Trifecta
+
+instance (Eq a) => Eq (Result a) where
+    Success a == Success b = a == b
+    Failure a == Failure b = True
+    _ == _ = False
+
+type NumberingPlanArea = Int -- aka area code
+type Exchange = Int
+type LineNumber = Int
+
+data PhoneNumber =
+    PhoneNumber NumberingPlanArea Exchange LineNumber
+    deriving (Eq, Show)
+
+number :: String -> Int
+number = foldl' (\acc x -> acc * 10 + read [x]) 0 
+
+parseNumberingPlanArea :: Parser NumberingPlanArea
+parseNumberingPlanArea = do
+    _ <- optional (string "1-")
+    numberingPlanArea   <-  char '(' *> count 3 digit <* char ')' <* char ' '
+                        <|> (count 3 digit <* optional (char '-'))
+    return $ number numberingPlanArea
+
+parseExchange :: Parser Exchange
+parseExchange = number <$> count 3 digit
+
+parseLineNumber :: Parser LineNumber
+parseLineNumber = number <$> count 4 digit
+
+parsePhone :: Parser PhoneNumber
+parsePhone = do
+    numberingPlanArea <- parseNumberingPlanArea
+    exchange <- parseExchange
+    _ <- optional (char '-')
+    lineNumber <- parseLineNumber
+    return $ PhoneNumber numberingPlanArea exchange lineNumber