Add remaining haskell book exercises

28 files changed, 1917 insertions, 0 deletions

diff --git a/Haskell-book/24/LearnParsers/.gitignore b/Haskell-book/24/LearnParsers/.gitignore
new file mode 100644
index 0000000..b3162b7
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/.gitignore
@@ -0,0 +1,3 @@
+.stack-work/
+LearnParsers.cabal
+*~
\ No newline at end of file
diff --git a/Haskell-book/24/LearnParsers/ChangeLog.md b/Haskell-book/24/LearnParsers/ChangeLog.md
new file mode 100644
index 0000000..365af37
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/ChangeLog.md
@@ -0,0 +1,3 @@
+# Changelog for LearnParsers
+
+## Unreleased changes
diff --git a/Haskell-book/24/LearnParsers/Setup.hs b/Haskell-book/24/LearnParsers/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Haskell-book/24/LearnParsers/app/Main.hs b/Haskell-book/24/LearnParsers/app/Main.hs
new file mode 100644
index 0000000..57ff0bf
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/app/Main.hs
@@ -0,0 +1,24 @@
+module Main where
+
+import Control.Applicative
+import LearnParsers
+import Text.Fractions
+import Text.Trifecta
+import Text.Parser.Combinators
+
+unitOfSuccess :: (TokenParsing m, Monad m) => m Integer
+unitOfSuccess = do
+    number <- integer
+    _ <- eof
+    return number
+
+type FractionOrNumber = Either Rational Integer
+
+parseFractionOrNumber :: Parser FractionOrNumber
+parseFractionOrNumber =  skipMany (oneOf "\n")
+     >> (Left <$> try virtuousFraction)
+    <|> (Right <$> integer)
+
+main :: IO ()
+main = do
+    print $ parseString unitOfSuccess mempty "123"
diff --git a/Haskell-book/24/LearnParsers/package.yaml b/Haskell-book/24/LearnParsers/package.yaml
new file mode 100644
index 0000000..ef83d5d
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/package.yaml
@@ -0,0 +1,24 @@
+name:                LearnParsers
+version:             0.1.0.0
+author:              "Eugen Wissner"
+maintainer:          "belka@caraus.de"
+copyright:           "2018 Eugen Wissner"
+
+dependencies:
+- base >= 4.7 && < 5
+- trifecta
+- parsers
+
+library:
+  source-dirs: src
+
+executables:
+  LearnParsers:
+    main:                Main.hs
+    source-dirs:         app
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - LearnParsers
diff --git a/Haskell-book/24/LearnParsers/src/LearnParsers.hs b/Haskell-book/24/LearnParsers/src/LearnParsers.hs
new file mode 100644
index 0000000..9c349fd
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/src/LearnParsers.hs
@@ -0,0 +1,45 @@
+module LearnParsers where
+
+import Text.Trifecta
+
+stop :: Parser a
+stop = unexpected "stop"
+
+-- read a single character '1'
+one = char '1'
+
+-- read a single character '1', then die
+one' = one >> stop
+-- equivalent to char '1' >> stop
+
+-- read two characters, '1', and '2'
+oneTwo = char '1' >> char '2'
+
+-- read two characters,
+-- '1' and '2', then die
+
+oneTwo' = oneTwo >> stop
+
+testParse :: Parser Char -> IO ()
+testParse p = print $ parseString p mempty "123"
+
+pNL s = putStrLn ('\n' : s)
+
+oneTwoThree :: Parser String
+oneTwoThree = choice
+            [ string "123"
+            , string "12"
+            , string "1"
+            ]
+
+oneTwoThree' = oneTwoThree >> stop
+
+testParse' :: Parser String -> IO ()
+testParse' p = print $ parseString p mempty "123"
+
+oneTwoThree'' :: Parser Char
+oneTwoThree'' = choice
+        [ one
+        , oneTwo
+        , char '1' >> char '2' >> char '3'
+        ]
diff --git a/Haskell-book/24/LearnParsers/src/Text/Fractions.hs b/Haskell-book/24/LearnParsers/src/Text/Fractions.hs
new file mode 100644
index 0000000..f09efc0
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/src/Text/Fractions.hs
@@ -0,0 +1,31 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Fractions where
+
+import Control.Applicative
+import Data.Ratio ((%))
+import Text.Trifecta
+
+badFraction = "1/0"
+
+alsoBad = "10"
+
+shouldWork = "1/2"
+
+shouldAlsoWork = "2/1"
+
+parseFraction :: Parser Rational
+parseFraction = do
+    numerator <- decimal
+    char '/'
+    denominator <- decimal
+    return (numerator % denominator)
+
+virtuousFraction :: Parser Rational
+virtuousFraction = do
+    numerator <- decimal
+    char '/'
+    denominator <- decimal
+    case denominator of
+      0 -> fail "Denominator cannot be zero"
+      _ -> return $ numerator % denominator
diff --git a/Haskell-book/24/LearnParsers/stack.yaml b/Haskell-book/24/LearnParsers/stack.yaml
new file mode 100644
index 0000000..c741be6
--- /dev/null
+++ b/Haskell-book/24/LearnParsers/stack.yaml
@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-11.0
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.6"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
\ No newline at end of file
diff --git a/Haskell-book/24/ParserExercises/.gitignore b/Haskell-book/24/ParserExercises/.gitignore
new file mode 100644
index 0000000..1918f96
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/.gitignore
@@ -0,0 +1,3 @@
+.stack-work/
+ParserExercises.cabal
+*~
\ No newline at end of file
diff --git a/Haskell-book/24/ParserExercises/Setup.hs b/Haskell-book/24/ParserExercises/Setup.hs
new file mode 100644
index 0000000..9a994af
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/Haskell-book/24/ParserExercises/package.yaml b/Haskell-book/24/ParserExercises/package.yaml
new file mode 100644
index 0000000..8740046
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/package.yaml
@@ -0,0 +1,38 @@
+name:                ParserExercises
+version:             0.1.0.0
+author:              "Eugen Wissner"
+maintainer:          "belka@caraus.de"
+copyright:           "2018 Eugen Wissner"
+
+dependencies:
+- base >= 4.7 && < 5
+- parsec
+- trifecta
+- QuickCheck
+- time
+- containers
+
+library:
+  source-dirs: src
+
+tests:
+  ParserExercises-test:
+    main:                Main.hs
+    source-dirs:         test/Spec
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - ParserExercises
+    - hspec
+
+  Log-test:
+    main:                Main.hs
+    source-dirs:         test/LogTest
+    ghc-options:
+    - -threaded
+    - -rtsopts
+    - -with-rtsopts=-N
+    dependencies:
+    - ParserExercises
diff --git a/Haskell-book/24/ParserExercises/src/Base10Integer.hs b/Haskell-book/24/ParserExercises/src/Base10Integer.hs
new file mode 100644
index 0000000..4e8ee3a
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/src/Base10Integer.hs
@@ -0,0 +1,52 @@
+module Base10Integer where
+
+import Control.Applicative
+import Text.Trifecta
+
+-- 2. Write a parser for positive integer values. Don't reuse the preexisting
+-- digit or integer functions, but you can use the rest of the libraries we've
+-- shown you so far. You are not expected to write a parsing library from
+-- scratch.
+--
+-- Hint: Assume you're parsing base-10 numbers. Use arithmetic as a cheap
+-- "accumulator" for your final number as you parse each digit left-to-right.
+
+parseDigit :: Parser Char
+parseDigit = (char '0')
+    <|> (char '1')
+    <|> (char '2')
+    <|> (char '3')
+    <|> (char '4')
+    <|> (char '5')
+    <|> (char '6')
+    <|> (char '7')
+    <|> (char '8')
+    <|> (char '9')
+
+charToDigit :: Char -> Integer
+charToDigit c = case c of
+                    '0' -> 0
+                    '1' -> 1
+                    '2' -> 2
+                    '3' -> 3
+                    '4' -> 4
+                    '5' -> 5
+                    '6' -> 6
+                    '7' -> 7
+                    '8' -> 8
+                    '9' -> 9
+
+base10Integer :: Parser Integer
+base10Integer = do
+    number <- some parseDigit
+    let n = foldl (\acc x -> (acc * 10) + (charToDigit x)) 0 number
+    return n
+
+-- 3. Extend the parser your wrote to handle negative and positive integers.
+-- Try writing a new parser in terms of the one you already have to do this.
+base10Integer' :: Parser Integer
+base10Integer' = do
+    negative <- (char '-' >> (return negate)) <|> (return id)
+    number <- some parseDigit
+    let n = foldl (\acc x -> (acc * 10) + (charToDigit x)) 0 number
+    return $ negative n
diff --git a/Haskell-book/24/ParserExercises/src/IPAddress.hs b/Haskell-book/24/ParserExercises/src/IPAddress.hs
new file mode 100644
index 0000000..e6a7102
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/src/IPAddress.hs
@@ -0,0 +1,260 @@
+module IPAddress where
+
+import Numeric
+import Control.Monad (join)
+import Control.Applicative
+import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Map (lookup, Map(..), fromList)
+import Data.Word
+import Data.Bits
+import Text.Trifecta
+
+-- 6. Write a parser for IPv4 addresses.
+
+data IPAddress = IPAddress Word32 deriving (Eq, Ord)
+
+parseIP4 :: Parser IPAddress
+parseIP4 = do
+    p1 <- natural
+    _ <- char '.'
+    p2 <- natural
+    _ <- char '.'
+    p3 <- natural
+    _ <- char '.'
+    p4 <- natural
+    return $ IPAddress $ fromIntegral $ xor (xor (xor (shift p1 24) (shift p2 16)) (shift p3 8)) p4
+
+-- A 32-bit word is a 32-bit unsigned int. Lowest value is 0 rahter than being
+-- capable of representing negative numbers, but the highest possible value in
+-- the same number of bits is twice as high.
+--
+-- Word32 is an appropriate and compact way to represent IPv4 addresses. You
+-- are expected to figure out not only how to parse the typical IP address
+-- format, but how IP addresses work numerically insofar as is required to
+-- write a working parser. This will require using a search engine unless you
+-- have an appropriate book on internet networking handy.
+
+-- 7. Same as before, but IPv6.
+
+data IPAddress6 = IPAddress6 Word64 Word64 deriving (Eq, Ord)
+
+-- One of the trickier parts about IPv6 will be full vs. collapsed
+-- addresses and the abbrevations. See this Q&A thread 13 about
+-- IPv6 abbreviations for more.
+
+
+newtype IPV6Normed = IPV6Normed String
+  deriving (Eq, Ord, Show)
+
+newtype IPV6Str = IPV6Str String
+  deriving (Eq, Ord, Show)
+
+spanList :: ([a] -> Bool) -> [a] -> ([a], [a])
+spanList _ [] = ([],[])
+spanList func list@(x:xs) =
+    if func list
+       then (x:ys,zs)
+       else ([],list)
+    where (ys,zs) = spanList func xs
+
+breakList :: ([a] -> Bool) -> [a] -> ([a], [a])
+breakList func = spanList (not . func)
+
+split' :: Eq a => [a] -> [a] -> [[a]]
+split' _ [] = []
+split' delim str =
+    let (firstline, remainder) = breakList (isPrefixOf delim) str
+        in 
+        firstline : case remainder of
+                                   [] -> []
+                                   x -> if x == delim
+                                        then [] : []
+                                        else split' delim 
+                                                 (drop (length delim) x)
+
+join :: [a] -> [[a]] -> [a]
+join delim l = concat (intersperse delim l)
+
+replace :: Eq a => [a] -> [a] -> [a] -> [a]
+replace old new l = IPAddress.join new . split' old $ l
+
+split :: Eq a => a -> [a] -> [[a]]
+split d [] = []
+split d s = x : split d (drop 1 y)
+  where
+    (x, y) = Data.List.span (/= d) s
+
+twoRaised16Exp :: [Integer]
+twoRaised16Exp = fmap ((2 ^ 16) ^) [0,1 ..]
+
+validHexChars :: String
+validHexChars = "0123456789abcdefABCDEF"
+
+validHexCharsLowerOnly :: String
+validHexCharsLowerOnly = "0123456789abcdef"
+
+buildExpanded0s :: Int -> String
+buildExpanded0s i = intersperse ':' (take i (repeat '0'))
+
+ipv6NormedToIPAddress6 :: IPV6Normed -> IPAddress6
+ipv6NormedToIPAddress6 (IPV6Normed str) = IPAddress6 quotient remainder
+  where
+    asSegs = split ':' str
+    zippedWithExp = zip (reverse asSegs) twoRaised16Exp
+    asInteger = foldr (\(s, exp) acc -> hexToDec s * exp + acc) 0 zippedWithExp
+    (q, r) = quotRem asInteger word64Max
+    quotient = fromIntegral q
+    remainder = fromIntegral r
+
+hexToDec :: String -> Integer
+hexToDec s = toInteger asInt
+  where
+    asInt = baseNToDec 16 (\c -> fromMaybe 0 (Data.Map.lookup (toLower c) hexCharToValue)) s
+
+baseNToDec :: Num i => i -> (a -> i) -> [a] -> i
+baseNToDec base toInt = foldl' (\acc n -> base * acc + toInt n ) 0
+
+hexCharToValue :: Map Char Int
+hexCharToValue = Data.Map.fromList $ zip validHexCharsLowerOnly [0 ..]
+
+word64Max :: Integer
+word64Max = toInteger (maxBound :: Word64)
+
+mkIPV6Normed :: String -> Either String IPV6Normed
+mkIPV6Normed origS = result
+  where
+    expand s
+      | s == "::" = IPV6Normed $ buildExpanded0s 8
+      | isPrefixOf "::" s =
+          let expandCnt = 8 - (length $ split ':' s) + 2
+              filler = buildExpanded0s expandCnt ++ ":"
+              replaced = replace "::" filler s
+          in IPV6Normed replaced
+      | isSuffixOf "::" s =
+          let expandCnt = 8 - (length $ split ':' s) + 1
+              filler = ':' : buildExpanded0s expandCnt
+              replaced = replace "::" filler s
+          in IPV6Normed replaced
+      | isInfixOf "::" s =
+          let expandCnt = 8 - (length $ split ':' s) + 1
+              filler = ':' : buildExpanded0s expandCnt ++ ":"
+              replaced = replace "::" filler s
+          in IPV6Normed replaced
+      | otherwise = IPV6Normed s
+    expanded = expand origS
+    IPV6Normed expandedStr = expanded
+    result = if length (split ':' expandedStr) == 8
+               then Right expanded
+               else Left "invalid sections"
+
+parseIPV6Section :: Parser String
+parseIPV6Section = do
+  mL <- optional (try $ string "::" <|> string ":")
+  seq <- some (oneOf validHexChars)
+  mR <- optional (try $ string "::" <|> string ":")
+  let lowered = map toLower seq
+      l = fromMaybe "" mL
+      r = fromMaybe "" mR
+  return $ l ++ lowered ++ r
+
+parseIPV6Str :: Parser IPV6Str
+parseIPV6Str = do
+  s <- (try $ (fmap (: []) (string "::" <* eof))) <|> manyTill parseIPV6Section
+                                                        eof
+  if length s < 1
+    then fail "Did not find valid sections"
+    else return $ IPV6Str $ Control.Monad.join s
+
+parseIPV6Normed :: Parser IPV6Normed
+parseIPV6Normed = do
+  str <- parseIPV6Str
+  let IPV6Str (s) = str
+      full = mkIPV6Normed s
+  case full of
+    Left err      -> fail err
+    Right fullstr -> return fullstr
+
+parseIP6 :: Parser IPAddress6
+parseIP6 = do
+    normed <- parseIPV6Normed
+    return $ ipv6NormedToIPAddress6 normed
+
+-- 8. Remove the derived Show instances from the IPAddress/IPAddress6
+-- types, and write your own Show instance for each type that renders in the
+-- typical textual format appropriate to each.
+
+ipAddressToIPV4DotFields :: IPAddress -> [Integer]
+ipAddressToIPV4DotFields (IPAddress word) = repr
+  where
+    asInteger = toInteger word
+    repr = decToBaseN asInteger 0 [0 .. 255]
+
+instance Show IPAddress where
+  show ip = Control.Monad.join $ intersperse "." asStrings
+    where
+      repr = ipAddressToIPV4DotFields ip
+      asStrings = fmap show repr
+
+ipAddress6toInteger :: IPAddress6 -> Integer
+ipAddress6toInteger (IPAddress6 q r) = toInteger q * word64Max + toInteger r
+
+iPAddress6ToIPV6Normed :: IPAddress6 -> IPV6Normed
+iPAddress6ToIPV6Normed ip = IPV6Normed s
+  where
+    asInteger = ipAddress6toInteger ip
+    chopped = integerToChoppedUp asInteger
+    ss = fmap integerToHexString chopped
+    fillCnt = 8 - length ss
+    filled = (take fillCnt (repeat "0")) ++ ss
+    s = Control.Monad.join $ intersperse ":" filled
+
+instance Show IPAddress6 where
+  show ip = normed
+    where IPV6Normed normed = iPAddress6ToIPV6Normed ip
+
+-- 9. Write a function that converts between IPAddress and IPAddress6.
+
+decToBaseN :: Integral a => a -> b -> [b] -> [b]
+decToBaseN i zero digits = if base == 0
+                                  then []
+                                  else go i []
+  where
+    base = fromIntegral $ length digits
+    go 0 [] = [zero]
+    go 0 acc = acc
+    go curr acc =
+      let (q, r) = quotRem curr base
+      in go q ((digits !! fromIntegral r) : acc)
+
+integerToHexString :: Integer -> String
+integerToHexString i = decToBaseN i '0' validHexCharsLowerOnly
+
+integerToChoppedUp :: Integer -> [Integer]
+integerToChoppedUp i = go i []
+  where
+    go 0 [] = [0]
+    go 0 acc = acc
+    go curr acc =
+      let (q, r) = quotRem curr (2 ^ 16)
+       in go q (r : acc)
+
+ipV4ToIpV6Normed :: IPAddress -> IPV6Normed
+ipV4ToIpV6Normed (IPAddress word) = normed
+  where
+    asInteger = toInteger word
+    chopped = integerToChoppedUp asInteger
+    ss = fmap integerToHexString chopped
+    fillCnt = 8 - length ss - 1
+    -- - ffff signifies an ip4 to ip6 conversion
+    -- (http://www.tcpipguide.com/free/t_IPv6IPv4AddressEmbedding-2.htm)
+    filled = (take fillCnt $ repeat "0") ++ ["ffff"] ++ ss
+    s = Control.Monad.join $ intersperse ":" filled
+    normed = IPV6Normed s
+
+ipV4ToIpV6 :: IPAddress -> IPAddress6
+ipV4ToIpV6 ip = ipv6
+  where
+    normed = ipV4ToIpV6Normed ip
+    ipv6 = ipv6NormedToIPAddress6 normed
diff --git a/Haskell-book/24/ParserExercises/src/LogParser.hs b/Haskell-book/24/ParserExercises/src/LogParser.hs
new file mode 100644
index 0000000..480498d
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/src/LogParser.hs
@@ -0,0 +1,83 @@
+module LogParser where
+
+import Control.Applicative
+import Data.Time
+import Test.QuickCheck
+import Text.Trifecta
+
+-- 5. Write a parser for a log file format and sum the time spent in
+-- each activity. Additionally, provide an alternative aggregation
+-- of the data that provides average time spent per activity per day.
+-- The format supports the use of comments which your parser
+-- will have to ignore. The # characters followed by a date mark
+-- the beginning of a particular day.
+--
+-- You are to derive a reasonable datatype for representing this
+-- data yourself. For bonus points, make this bi-directional by
+-- making a Show representation for the datatype which matches
+-- the format you are parsing. Then write a generator for this data
+-- using QuickCheck’s Gen and see if you can break your parser
+-- with QuickCheck.
+
+data Statement = Statement TimeOfDay String deriving Eq
+data LogEntry = LogEntry Day [Statement] deriving Eq
+newtype Log = Log { getLog :: [LogEntry] }
+
+instance Show Statement where
+    show (Statement x y) = (formatTime defaultTimeLocale "%R" x) ++ " " ++ y
+
+instance Show LogEntry where
+    show (LogEntry x y) = "# " ++ (show x) ++ "\n"
+                      ++ (foldl (\acc v -> acc ++ (show v) ++ "\n") "" y)
+
+instance Show Log where
+    show (Log y) = (foldl (\acc v -> acc ++ (show v) ++ "\n") "" y)
+
+instance Arbitrary Statement where
+    arbitrary = do
+        h <- choose (0, 23)
+        m <- choose (0, 59)
+        text <- listOf1 $ elements ['.'..'~']
+        return $ Statement (TimeOfDay h m 0) text
+
+instance Arbitrary LogEntry where
+    arbitrary = do
+        day <- arbitrary
+        statements <- arbitrary
+        return $ LogEntry (ModifiedJulianDay day) statements
+
+skipEOL :: Parser ()
+skipEOL = skipMany (oneOf "\n")
+
+skipComments :: Parser ()
+skipComments =
+    skipMany (do _ <- char '-'
+                 _ <- char '-'
+                 skipMany (noneOf "\n")
+                 skipEOL)
+
+parseStatement :: Parser Statement
+parseStatement = do
+    h <- integer
+    _ <- char ':'
+    m <- integer
+    text <- manyTill anyChar (try (string "--") <|> (string "\n") <|> (eof >> return ""))
+    skipComments
+    skipEOL
+    return $ Statement (TimeOfDay (fromIntegral h) (fromIntegral m) 0) text
+
+parseLogEntry :: Parser LogEntry
+parseLogEntry = do
+    _ <- string "# "
+    y <- integer
+    _ <- char '-'
+    m <- integer
+    _ <- char '-'
+    d <- integer
+    skipComments
+    skipEOL
+    statements <- many parseStatement
+    return $ LogEntry (fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d)) statements
+
+parseLog :: Parser Log
+parseLog = Log <$> many parseLogEntry
diff --git a/Haskell-book/24/ParserExercises/src/PhoneNumber.hs b/Haskell-book/24/ParserExercises/src/PhoneNumber.hs
new file mode 100644
index 0000000..dad75a7
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/src/PhoneNumber.hs
@@ -0,0 +1,28 @@
+module PhoneNumber where
+
+import Control.Applicative
+import Text.Trifecta
+
+-- 4. Write a parser for US/Canada phone numbers with varying formats.
+-- Cf. Wikipeida's article on "National conventions for writing telephone
+-- numbers". You are encouraged to adapt the exercise to your locality's
+-- conventions if they are not part of the NNAP scheme.
+
+-- aka area code
+type NumberingPlanArea = Int
+type Exchange = Int
+type LineNumber = Int
+
+data PhoneNumber = PhoneNumber NumberingPlanArea Exchange LineNumber
+    deriving (Eq, Show)
+
+parsePhone :: Parser PhoneNumber
+parsePhone = do
+    _ <- optional ((try $ char '(') <|> (try (char '1' >> char '-')))
+    area <- count 3 digit
+    _ <- optional $ (try $ char ')')
+    _ <- optional $  (try $ char ' ') <|> (try $ char '-')
+    exchange <- count 3 digit
+    _ <- optional $ (char ' ') <|> (char '-')
+    lineNumber <- decimal
+    return $ PhoneNumber (read area) (read exchange) (fromIntegral lineNumber)
diff --git a/Haskell-book/24/ParserExercises/src/SemVer.hs b/Haskell-book/24/ParserExercises/src/SemVer.hs
new file mode 100644
index 0000000..47b49ab
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/src/SemVer.hs
@@ -0,0 +1,51 @@
+module SemVer where
+
+import Control.Applicative
+import Text.Trifecta
+
+-- 1. Write a parser for semantic versions as defined by http://semver.org/.
+-- After making a working parser, write an Ord instance for the SemVer type
+-- that obeys the specification outlined on the SemVer website.
+
+-- Relevant to precedence/ordering,
+-- cannot sort numbers like strings.
+data NumberOrString = NOSS String
+                    | NOSI Integer
+                    deriving (Eq, Show)
+
+type Major = Integer
+type Minor = Integer
+type Patch = Integer
+type Release = [NumberOrString]
+type Metadata = [NumberOrString]
+
+data SemVer = SemVer Major Minor Patch Release Metadata
+    deriving (Eq, Show)
+
+parseNos :: Parser NumberOrString
+parseNos = do
+    nos <- (NOSI <$> integer)
+       <|> (NOSS <$> some letter)
+    return nos
+
+parseRelease :: Parser [NumberOrString]
+parseRelease = do
+    _ <- char '-'
+    sepBy parseNos (char '.')
+
+parseMetadata :: Parser [NumberOrString]
+parseMetadata = do
+    _ <- char '+'
+    sepBy parseNos (char '.')
+
+parseSemVer :: Parser SemVer
+parseSemVer = do
+    major <- decimal
+    _ <- char '.'
+    minor <- decimal
+    _ <- char '.'
+    patch <- decimal
+    release <- option [] parseRelease
+    metadata <- option [] parseMetadata
+
+    return $ SemVer major minor patch release metadata
diff --git a/Haskell-book/24/ParserExercises/stack.yaml b/Haskell-book/24/ParserExercises/stack.yaml
new file mode 100644
index 0000000..e60ca15
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/stack.yaml
@@ -0,0 +1,66 @@
+# This file was automatically generated by 'stack init'
+#
+# Some commonly used options have been documented as comments in this file.
+# For advanced use and comprehensive documentation of the format, please see:
+# https://docs.haskellstack.org/en/stable/yaml_configuration/
+
+# Resolver to choose a 'specific' stackage snapshot or a compiler version.
+# A snapshot resolver dictates the compiler version and the set of packages
+# to be used for project dependencies. For example:
+#
+# resolver: lts-3.5
+# resolver: nightly-2015-09-21
+# resolver: ghc-7.10.2
+# resolver: ghcjs-0.1.0_ghc-7.10.2
+# resolver:
+#  name: custom-snapshot
+#  location: "./custom-snapshot.yaml"
+resolver: lts-11.1
+
+# User packages to be built.
+# Various formats can be used as shown in the example below.
+#
+# packages:
+# - some-directory
+# - https://example.com/foo/bar/baz-0.0.2.tar.gz
+# - location:
+#    git: https://github.com/commercialhaskell/stack.git
+#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
+#   extra-dep: true
+#  subdirs:
+#  - auto-update
+#  - wai
+#
+# A package marked 'extra-dep: true' will only be built if demanded by a
+# non-dependency (i.e. a user package), and its test suites and benchmarks
+# will not be run. This is useful for tweaking upstream packages.
+packages:
+- .
+# Dependency packages to be pulled from upstream that are not in the resolver
+# (e.g., acme-missiles-0.3)
+# extra-deps: []
+
+# Override default flag values for local packages and extra-deps
+# flags: {}
+
+# Extra package databases containing global packages
+# extra-package-dbs: []
+
+# Control whether we use the GHC we find on the path
+# system-ghc: true
+#
+# Require a specific version of stack, using version ranges
+# require-stack-version: -any # Default
+# require-stack-version: ">=1.6"
+#
+# Override the architecture used by stack, especially useful on Windows
+# arch: i386
+# arch: x86_64
+#
+# Extra directories used by stack for building
+# extra-include-dirs: [/path/to/dir]
+# extra-lib-dirs: [/path/to/dir]
+#
+# Allow a newer minor version of GHC than the snapshot specifies
+# compiler-check: newer-minor
\ No newline at end of file
diff --git a/Haskell-book/24/ParserExercises/test/LogTest/Main.hs b/Haskell-book/24/ParserExercises/test/LogTest/Main.hs
new file mode 100644
index 0000000..7d1d135
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/test/LogTest/Main.hs
@@ -0,0 +1,14 @@
+module Main where
+
+import LogParser
+import Test.QuickCheck
+import Text.Trifecta
+
+maybeSuccess :: Text.Trifecta.Result a -> Maybe a
+maybeSuccess (Text.Trifecta.Success a) = Just a
+maybeSuccess _ = Nothing
+
+main :: IO ()
+main = do
+    quickCheck ((\s -> (maybeSuccess $ parseString parseStatement mempty (show s)) == (Just s)) :: Statement -> Bool)
+    quickCheck ((\s -> (maybeSuccess $ parseString parseLogEntry mempty (show s)) == (Just s)) :: LogEntry -> Bool)
diff --git a/Haskell-book/24/ParserExercises/test/Spec/Main.hs b/Haskell-book/24/ParserExercises/test/Spec/Main.hs
new file mode 100644
index 0000000..23781c6
--- /dev/null
+++ b/Haskell-book/24/ParserExercises/test/Spec/Main.hs
@@ -0,0 +1,107 @@
+import SemVer
+import Base10Integer
+import PhoneNumber
+import IPAddress
+import Test.Hspec
+import Text.Trifecta
+
+maybeSuccess :: Result a -> Maybe a
+maybeSuccess (Success a) = Just a
+maybeSuccess _ = Nothing
+
+parseIP :: String -> Maybe IPAddress
+parseIP s = o
+    where r = parseString parseIP4 mempty s
+          o = case r of
+                (Success o) -> Just o
+                _           -> Nothing
+
+parseIP6' :: String -> Maybe IPAddress6
+parseIP6' s = o
+    where r = parseString parseIP6 mempty s
+          o = case r of
+                (Success o) -> Just o
+                _           -> Nothing
+
+main :: IO ()
+main = hspec $ do
+    describe "parseSemVer" $ do
+        it "parses minimum SemVer" $ do
+            let got = maybeSuccess $ parseString parseSemVer mempty "2.1.1"
+             in got `shouldBe` Just (SemVer 2 1 1 [] [])
+        it "parses release field" $ do
+            let got = maybeSuccess $ parseString parseSemVer mempty "1.0.0-x.7.z.92"
+                expected = Just $ SemVer 1 0 0 [NOSS "x", NOSI 7, NOSS "z", NOSI 92] []
+             in got `shouldBe` expected
+
+    describe "parseDigit" $ do
+        it "parses the first digit of '123'" $ do
+            let got = maybeSuccess $ parseString parseDigit mempty "123"
+                expected = Just '1'
+             in got `shouldBe` expected
+        it "fails on 'abc'" $ do
+            let got = maybeSuccess $ parseString parseDigit mempty "abc"
+                expected = Nothing
+             in got `shouldBe` expected
+
+    describe "base10Integer" $ do
+        it "parses the integer in '123abc'" $ do
+            let got = maybeSuccess $ parseString base10Integer mempty "123abc"
+                expected = Just 123
+             in got `shouldBe` expected
+        it "fails on 'abc'" $ do
+            let got = maybeSuccess $ parseString base10Integer mempty "abc"
+                expected = Nothing
+             in got `shouldBe` expected
+
+    describe "base10Integer'" $ do
+        it "parses negative numbers" $ do
+            let got = maybeSuccess $ parseString base10Integer' mempty "-123abc"
+                expected = Just (-123)
+             in got `shouldBe` expected
+
+    describe "parsePhone" $ do
+        it "parses '123-456-7890'" $ do
+            let actual = maybeSuccess $ parseString parsePhone mempty "123-456-7890"
+                expected = Just $ PhoneNumber 123 456 7890
+             in actual `shouldBe` expected
+        it "parses '1234567890'" $ do
+            let actual = maybeSuccess $ parseString parsePhone mempty "1234567890"
+                expected = Just $ PhoneNumber 123 456 7890
+             in actual `shouldBe` expected
+        it "parses '(123) 456-7890'" $ do
+            let actual = maybeSuccess $ parseString parsePhone mempty "(123) 456-7890"
+                expected = Just $ PhoneNumber 123 456 7890
+             in actual `shouldBe` expected
+        it "parses '1-123-456-7890'" $ do
+            let actual = maybeSuccess $ parseString parsePhone mempty "1-123-456-7890"
+                expected = Just $ PhoneNumber 123 456 7890
+             in actual `shouldBe` expected
+
+    describe "parseIP4" $ do
+        it "parses localhost" $ do
+            let actual = maybeSuccess $ parseString parseIP4 mempty "127.0.0.1"
+                expected = Just $ IPAddress 2130706433
+             in actual `shouldBe` expected
+
+    describe "parseIP6" $ do
+        it "parses localhost" $ do
+            let actual = maybeSuccess $ parseString parseIP6 mempty "::1"
+                expected = Just $ IPAddress6 0 1
+             in actual `shouldBe` expected
+
+    describe "ipV4ToIpV6" $
+        it "should work" $ do
+            (show . ipV4ToIpV6 <$> parseIP "124.155.107.12") `shouldBe` Just "0:0:0:0:0:ffff:7c9b:6b0c"
+            (show . ipV4ToIpV6 <$> parseIP "192.168.0.1") `shouldBe` Just "0:0:0:0:0:ffff:c0a8:1"
+
+    describe "show" $ do
+        it "should show IPAddress6 properly" $ do
+            (show <$> parseIP6' "ff39:0:0:0:2f2:b3ff:f23d:8d5") `shouldBe` Just "ff39:0:0:0:2f2:b3ff:f23d:8d5"
+            (show <$> parseIP6' "9ff3:EA8::8A:30:2F0C:1F7A") `shouldBe` Just "9ff3:ea8:0:0:8a:30:2f0c:1f7a"
+            (show <$> parseIP6' "::ffff:abc:fed9") `shouldBe` Just "0:0:0:0:0:ffff:abc:fed9"
+
+        it "should show IPAddress properly" $ do
+            (show <$> parseIP "152.163.254.3") `shouldBe` Just "152.163.254.3"
+            (show <$> parseIP "224.165.197.142") `shouldBe` Just "224.165.197.142"
+            (show <$> parseIP "124.155.107.12") `shouldBe` Just "124.155.107.12"
diff --git a/Haskell-book/24/language-dot/LICENSE b/Haskell-book/24/language-dot/LICENSE
new file mode 100644
index 0000000..59fd4e9
--- /dev/null
+++ b/Haskell-book/24/language-dot/LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2009, Galois, Inc.

+All rights reserved.

+

+Redistribution and use in source and binary forms, with or without

+modification, are permitted provided that the following conditions

+are met:

+

+  * Redistributions of source code must retain the above copyright

+    notice, this list of conditions and the following disclaimer.

+  * Redistributions in binary form must reproduce the above copyright

+    notice, this list of conditions and the following disclaimer in

+    the documentation and/or other materials provided with the

+    distribution.

+  * Neither the name of the Galois, Inc. nor the names of its

+    contributors may be used to endorse or promote products derived

+    from this software without specific prior written permission.

+

+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS

+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,

+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,

+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;

+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN

+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE

+POSSIBILITY OF SUCH DAMAGE.

diff --git a/Haskell-book/24/language-dot/Setup.hs b/Haskell-book/24/language-dot/Setup.hs
new file mode 100644
index 0000000..dba3cdf
--- /dev/null
+++ b/Haskell-book/24/language-dot/Setup.hs
@@ -0,0 +1,12 @@
+module Main where

+

+import Distribution.Simple (defaultMainWithHooks, simpleUserHooks, runTests)

+import System.Process      (system)

+

+main :: IO ()

+main =

+    defaultMainWithHooks $ simpleUserHooks { runTests = runTests' }

+  where

+    runTests' _ _ _ _ = do

+        system "runhaskell -DTEST -i./src src/test.hs"

+        return ()

diff --git a/Haskell-book/24/language-dot/language-dot.cabal b/Haskell-book/24/language-dot/language-dot.cabal
new file mode 100644
index 0000000..5463485
--- /dev/null
+++ b/Haskell-book/24/language-dot/language-dot.cabal
@@ -0,0 +1,59 @@
+name:         language-dot

+version:      0.0.8

+category:     Language

+synopsis:     A library for the analysis and creation of Graphviz DOT files

+description:  A library for the analysis and creation of Graphviz DOT files.

+author:       Brian Lewis <brian@lorf.org>

+maintainer:   Brian Lewis <brian@lorf.org>

+copyright:    (c) 2009 Galois, Inc.

+license:      BSD3

+license-file: LICENSE

+

+cabal-version: >= 1.6

+build-type:    Custom

+

+extra-source-files:

+  src/test.hs

+

+flag executable

+  description: Build the `ppdot' executable.

+  default:     True

+

+library

+  hs-source-dirs:

+    src

+

+  exposed-modules:

+    Language.Dot

+    Language.Dot.Parser

+    Language.Dot.Pretty

+    Language.Dot.Syntax

+

+  build-depends:

+    base    == 4.*,

+    mtl     == 1.* || == 2.*,

+    parsec  == 3.*,

+    pretty  == 1.*

+

+  ghc-options: -Wall

+  if impl(ghc >= 6.8)

+    ghc-options: -fwarn-tabs

+

+executable ppdot

+  if flag(executable)

+    buildable: True

+  else

+    buildable: False

+

+  hs-source-dirs:

+    src

+

+  main-is: ppdot.hs

+

+  ghc-options: -Wall

+  if impl(ghc >= 6.8)

+    ghc-options: -fwarn-tabs

+

+source-repository head

+  type:     git

+  location: git://github.com/bsl/language-dot.git

diff --git a/Haskell-book/24/language-dot/src/Language/Dot.hs b/Haskell-book/24/language-dot/src/Language/Dot.hs
new file mode 100644
index 0000000..b1a87a3
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/Language/Dot.hs
@@ -0,0 +1,10 @@
+module Language.Dot

+  ( module Language.Dot.Parser

+  , module Language.Dot.Pretty

+  , module Language.Dot.Syntax

+  )

+  where

+

+import Language.Dot.Parser

+import Language.Dot.Pretty

+import Language.Dot.Syntax

diff --git a/Haskell-book/24/language-dot/src/Language/Dot/Parser.hs b/Haskell-book/24/language-dot/src/Language/Dot/Parser.hs
new file mode 100644
index 0000000..a13d457
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/Language/Dot/Parser.hs
@@ -0,0 +1,486 @@
+{-# LANGUAGE CPP #-}

+

+module Language.Dot.Parser

+  ( parseDot

+#ifdef TEST

+  , parsePort

+  , parseCompass

+  , parseAttribute

+  , parseId

+#endif

+  )

+  where

+

+import Control.Applicative ((<$>), (<*>), (<*), (*>))

+import Control.Monad       (when)

+import Data.Char           (digitToInt, toLower)

+import Data.List           (foldl')

+import Data.Maybe          (fromJust, fromMaybe, isJust)

+import Numeric             (readFloat)

+

+import Text.Parsec

+import Text.Parsec.Language

+import Text.Parsec.String

+import Text.Parsec.Token

+

+import Language.Dot.Syntax

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseDot

+  :: String  -- ^ origin of the data, e.g., the name of a file

+  -> String  -- ^ DOT source code

+  -> Either ParseError Graph

+parseDot origin =

+    parse (whiteSpace' >> parseGraph) origin . preprocess

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+preprocess :: String -> String

+preprocess =

+    unlines . map commentPoundLines . lines

+  where

+    commentPoundLines []         = []

+    commentPoundLines line@(c:_) = if c == '#' then "// " ++ line else line

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseGraph :: Parser Graph

+parseGraph =

+    ( Graph <$>

+          parseGraphStrictness

+      <*> parseGraphDirectedness

+      <*> optionMaybe parseId

+      <*> parseStatementList

+    )

+    <?> "graph"

+

+parseGraphStrictness :: Parser GraphStrictness

+parseGraphStrictness =

+    ((reserved' "strict" >> return StrictGraph) <|> return UnstrictGraph)

+    <?> "graph strictness"

+

+parseGraphDirectedness :: Parser GraphDirectedness

+parseGraphDirectedness =

+    (   (reserved' "graph"   >> return UndirectedGraph)

+    <|> (reserved' "digraph" >> return DirectedGraph)

+    )

+    <?> "graph directedness"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseStatementList :: Parser [Statement]

+parseStatementList =

+    braces' (parseStatement `endBy` optional semi')

+    <?> "statement list"

+

+parseStatement :: Parser Statement

+parseStatement =

+    (   try parseEdgeStatement

+    <|> try parseAttributeStatement

+    <|> try parseAssignmentStatement

+    <|> try parseSubgraphStatement

+    <|>     parseNodeStatement

+    )

+    <?> "statement"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseNodeStatement :: Parser Statement

+parseNodeStatement =

+    ( NodeStatement <$>

+      parseNodeId <*> parseAttributeList

+    )

+    <?> "node statement"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseEdgeStatement :: Parser Statement

+parseEdgeStatement =

+    ( EdgeStatement <$>

+      parseEntityList <*> parseAttributeList

+    )

+    <?> "edge statement"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseAttributeStatement :: Parser Statement

+parseAttributeStatement =

+    ( AttributeStatement <$>

+      parseAttributeStatementType <*> parseAttributeList

+    )

+    <?> "attribute statement"

+

+parseAttributeStatementType :: Parser AttributeStatementType

+parseAttributeStatementType =

+    (   (reserved' "graph" >> return GraphAttributeStatement)

+    <|> (reserved' "node"  >> return NodeAttributeStatement)

+    <|> (reserved' "edge"  >> return EdgeAttributeStatement)

+    )

+    <?> "attribute statement type"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseAssignmentStatement :: Parser Statement

+parseAssignmentStatement =

+    ( AssignmentStatement <$>

+      parseId <*> (reservedOp' "=" *> parseId)

+    )

+    <?> "assignment statement"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseSubgraphStatement :: Parser Statement

+parseSubgraphStatement =

+    ( SubgraphStatement <$>

+       parseSubgraph

+    )

+    <?> "subgraph statement"

+

+parseSubgraph :: Parser Subgraph

+parseSubgraph =

+    (   try parseNewSubgraph

+    <|>     parseSubgraphRef

+    )

+    <?> "subgraph"

+

+parseNewSubgraph :: Parser Subgraph

+parseNewSubgraph =

+    ( NewSubgraph <$>

+      (optional (reserved' "subgraph") *> optionMaybe parseId) <*> parseStatementList

+    )

+    <?> "new subgraph"

+

+parseSubgraphRef :: Parser Subgraph

+parseSubgraphRef =

+    ( SubgraphRef <$>

+      (reserved' "subgraph" *> parseId)

+    )

+    <?> "subgraph ref"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseEntityList :: Parser [Entity]

+parseEntityList =

+    ( (:) <$>

+      parseEntity True <*> many1 (parseEntity False)

+    )

+    <?> "entity list"

+

+parseEntity :: Bool -> Parser Entity

+parseEntity first =

+    (   try (parseENodeId first)

+    <|>     parseESubgraph first

+    )

+    <?> "entity"

+

+parseENodeId :: Bool -> Parser Entity

+parseENodeId first =

+    ( ENodeId <$>

+      (if first then return NoEdge else parseEdgeType) <*> parseNodeId

+    )

+    <?> "entity node id"

+

+parseESubgraph :: Bool -> Parser Entity

+parseESubgraph first =

+    ( ESubgraph <$>

+      (if first then return NoEdge else parseEdgeType) <*> parseSubgraph

+    )

+    <?> "entity subgraph"

+

+parseEdgeType :: Parser EdgeType

+parseEdgeType =

+    (   try (reservedOp' "->" >> return DirectedEdge)

+    <|>     (reservedOp' "--" >> return UndirectedEdge)

+    )

+    <?> "edge operator"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseNodeId :: Parser NodeId

+parseNodeId =

+    ( NodeId <$>

+      parseId <*> optionMaybe parsePort

+    )

+    <?> "node id"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parsePort :: Parser Port

+parsePort =

+    (   try parsePortC

+    <|>     parsePortI

+    )

+    <?> "port"

+

+parsePortC :: Parser Port

+parsePortC =

+    ( PortC <$>

+      (colon' *> parseCompass)

+    )

+    <?> "port (compass variant)"

+

+parsePortI :: Parser Port

+parsePortI =

+    ( PortI <$>

+      (colon' *> parseId) <*> optionMaybe (colon' *> parseCompass)

+    )

+    <?> "port (id variant)"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseCompass :: Parser Compass

+parseCompass =

+    (fmap convert identifier' >>= maybe err return)

+    <?> "compass"

+  where

+    err = parserFail "invalid compass value"

+    convert =

+        flip lookup table . stringToLower

+      where

+        table =

+          [ ("n",  CompassN),  ("e",  CompassE),  ("s",  CompassS),  ("w",  CompassW)

+          , ("ne", CompassNE), ("nw", CompassNW), ("se", CompassSE), ("sw", CompassSW)

+          ]

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseAttributeList :: Parser [Attribute]

+parseAttributeList =

+    (brackets' (parseAttribute `sepBy` optional comma') <|> return [])

+    <?> "attribute list"

+

+parseAttribute :: Parser Attribute

+parseAttribute =

+    ( do

+      id0 <- parseId

+      id1 <- optionMaybe (reservedOp' "=" >> parseId)

+      return $ maybe (AttributeSetTrue id0) (AttributeSetValue id0) id1

+    )

+    <?> "attribute"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseId :: Parser Id

+parseId =

+    (   try parseNameId

+    <|> try parseStringId

+    <|> try parseFloatId

+    <|> try parseIntegerId

+    <|>     parseXmlId

+    )

+    <?> "id"

+

+parseNameId :: Parser Id

+parseNameId =

+    ( NameId <$>

+      identifier'

+    )

+    <?> "name"

+

+parseStringId :: Parser Id

+parseStringId =

+    ( StringId <$>

+      lexeme' (char '"' *> manyTill stringChar (char '"'))

+    )

+    <?> "string literal"

+  where

+    stringChar =

+        (try (string "\\\"" >> return '"') <|> noneOf "\"")

+        <?> "string character"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+-- | DOT allows floating point numbers having no whole part like @.123@, but

+--   Parsec 'float' does not accept them.

+parseFloatId :: Parser Id

+parseFloatId =

+    lexeme'

+      ( do s <- parseSign

+           l <- fmap (fromMaybe 0) (optionMaybe parseNatural)

+           _ <- char '.'

+           r <- many1 digit

+           maybe err return (make s (show l ++ "." ++ r))

+      )

+    <?> "float"

+  where

+    err = parserFail "invalid float value"

+    make s f =

+        case readFloat f of

+          [(v,"")] -> (Just . FloatId . s) v

+          _        -> Nothing

+

+parseSign :: (Num a) => Parser (a -> a)

+parseSign =

+    (   (char '-' >> return negate)

+    <|> (char '+' >> return id)

+    <|> return id

+    )

+    <?> "sign"

+

+-- | Non-'lexeme' variant of 'natural' for parsing the natural part of a float.

+parseNatural :: Parser Integer

+parseNatural =

+    (   (char '0' >> return 0)

+    <|> (convert <$> many1 digit)

+    )

+    <?> "natural"

+  where

+    convert = foldl' (\acc d -> 10 * acc + fromIntegral (digitToInt d)) 0

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseIntegerId :: Parser Id

+parseIntegerId =

+    ( IntegerId <$>

+      integer'

+    )

+    <?> "integer"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parseXmlId :: Parser Id

+parseXmlId =

+    ( XmlId <$>

+      angles' parseXml

+    )

+    <?> "XML id"

+

+parseXml :: Parser Xml

+parseXml =

+    (   try parseXmlEmptyTag

+    <|> try parseXmlTag

+    <|>     parseXmlText

+    )

+    <?> "XML"

+

+parseXmlEmptyTag :: Parser Xml

+parseXmlEmptyTag =

+    ( XmlEmptyTag <$>

+      (char '<' *> parseXmlName) <*> (parseXmlAttributes <* (char '/' >> char '>'))

+    )

+    <?> "XML empty tag"

+

+parseXmlTag :: Parser Xml

+parseXmlTag =

+    ( do (name, attributes) <- parseXmlTagOpen

+         elements           <- manyTill parseXml (lookAhead (try (parseXmlTagClose (Just name))))

+         parseXmlTagClose (Just name)

+         return $ XmlTag name attributes elements

+    )

+    <?> "XML tag"

+

+parseXmlTagOpen :: Parser (XmlName, [XmlAttribute])

+parseXmlTagOpen =

+    ( (,) <$>

+      (char '<' *> parseXmlName) <*> (parseXmlAttributes <* char '>')

+    )

+    <?> "XML opening tag"

+

+parseXmlTagClose :: Maybe XmlName -> Parser ()

+parseXmlTagClose mn0 =

+    ( do _  <- char '<'

+         _  <- char '/'

+         n1 <- parseXmlName

+         _  <- char '>'

+         when (isJust mn0 && fromJust mn0 /= n1) parserZero

+    )

+    <?> "XML closing tag " ++ "(" ++ which ++ ")"

+  where

+    which =

+        case mn0 of

+          Just (XmlName n) -> "for " ++ show n

+          Nothing          -> "any"

+

+parseXmlText :: Parser Xml

+parseXmlText =

+    ( XmlText <$>

+      anyChar `manyTill` lookAhead (   try (parseXmlEmptyTag >> return ())

+                                   <|> try (parseXmlTag      >> return ())

+                                   <|>      parseXmlTagClose Nothing

+                                   )

+    )

+    <?> "XML text"

+

+parseXmlAttributes :: Parser [XmlAttribute]

+parseXmlAttributes =

+    many parseXmlAttribute

+    <?> "XML attribute list"

+

+parseXmlAttribute :: Parser XmlAttribute

+parseXmlAttribute =

+    ( XmlAttribute <$>

+      (parseXmlName <* reservedOp' "=") <*> parseXmlAttributeValue

+    )

+    <?> "XML attribute"

+

+parseXmlAttributeValue :: Parser XmlAttributeValue

+parseXmlAttributeValue =

+    ( XmlAttributeValue <$>

+      stringLiteral'

+    )

+    <?> "XML attribute value"

+

+parseXmlName :: Parser XmlName

+parseXmlName =

+    ( XmlName <$>

+      ((:) <$> c0 <*> (many c1 <* whiteSpace'))

+    )

+    <?> "XML name"

+  where

+    c0 = letter   <|> cs

+    c1 = alphaNum <|> cs

+    cs = oneOf "-.:_"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+angles'        :: Parser a -> Parser a

+braces'        :: Parser a -> Parser a

+brackets'      :: Parser a -> Parser a

+colon'         :: Parser String

+comma'         :: Parser String

+identifier'    :: Parser String

+integer'       :: Parser Integer

+lexeme'        :: Parser a -> Parser a

+reserved'      :: String -> Parser ()

+reservedOp'    :: String -> Parser ()

+semi'          :: Parser String

+stringLiteral' :: Parser String

+whiteSpace'    :: Parser ()

+

+angles'        = angles        lexer

+braces'        = braces        lexer

+brackets'      = brackets      lexer

+colon'         = colon         lexer

+comma'         = comma         lexer

+identifier'    = identifier    lexer

+integer'       = integer       lexer

+lexeme'        = lexeme        lexer

+reserved'      = reserved      lexer

+reservedOp'    = reservedOp    lexer

+semi'          = semi          lexer

+stringLiteral' = stringLiteral lexer

+whiteSpace'    = whiteSpace    lexer

+

+lexer :: TokenParser ()

+lexer =

+    makeTokenParser dotDef

+  where

+    dotDef = emptyDef

+      { commentStart    = "/*"

+      , commentEnd      = "*/"

+      , commentLine     = "//"

+      , nestedComments  = True

+      , identStart      = letter   <|> char '_'

+      , identLetter     = alphaNum <|> char '_'

+      , opStart         = oneOf "-="

+      , opLetter        = oneOf ""

+      , reservedOpNames = ["->", "--", "="]

+      , reservedNames   = ["digraph", "edge", "graph", "node", "strict", "subgraph"]

+      , caseSensitive   = False

+      }

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+stringToLower :: String -> String

+stringToLower = map toLower

diff --git a/Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs b/Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs
new file mode 100644
index 0000000..84a4c0c
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs
@@ -0,0 +1,135 @@
+module Language.Dot.Pretty

+  ( prettyPrintDot

+  , renderDot

+  , PP(..)

+  )

+  where

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+import Numeric

+import Text.PrettyPrint

+

+import Language.Dot.Syntax

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+prettyPrintDot :: Graph -> Doc

+prettyPrintDot = pp

+

+renderDot :: Graph -> String

+renderDot = render . pp

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+class PP a where

+  pp :: a -> Doc

+

+instance (PP a) => PP (Maybe a) where

+  pp (Just v) = pp v

+  pp Nothing  = empty

+

+instance PP Graph where

+  pp (Graph s d mi ss) = pp s <+> pp d <+> pp mi <+> lbrace $+$ indent (vcat' ss) $+$ rbrace

+

+instance PP GraphStrictness where

+  pp StrictGraph   = text "strict"

+  pp UnstrictGraph = empty

+

+instance PP GraphDirectedness where

+  pp DirectedGraph   = text "digraph"

+  pp UndirectedGraph = text "graph"

+

+instance PP Id where

+  pp (NameId v)    = text v

+  pp (StringId v)  = doubleQuotes (text v)

+  pp (IntegerId v) = integer v

+  pp (FloatId v)   = ffloat v

+  pp (XmlId v)     = langle <> pp v <> rangle

+

+instance PP Statement where

+  pp (NodeStatement ni as)       = pp ni <+> if not (null as) then brackets (hsep' as) else empty

+  pp (EdgeStatement es as)       = hsep' es <+> if not (null as) then brackets (hsep' as) else empty

+  pp (AttributeStatement t as)   = pp t <+> brackets (hsep' as)

+  pp (AssignmentStatement i0 i1) = pp i0 <> equals <> pp i1

+  pp (SubgraphStatement s)       = pp s

+

+instance PP AttributeStatementType where

+  pp GraphAttributeStatement = text "graph"

+  pp NodeAttributeStatement  = text "node"

+  pp EdgeAttributeStatement  = text "edge"

+

+instance PP Attribute where

+  pp (AttributeSetTrue i)      = pp i

+  pp (AttributeSetValue i0 i1) = pp i0 <> equals <> pp i1

+

+instance PP NodeId where

+  pp (NodeId i mp) = pp i <> pp mp

+

+instance PP Port where

+  pp (PortI i mc) = colon <> pp i <> maybe empty ((colon <>) . pp) mc

+  pp (PortC c)    = colon <> pp c

+

+instance PP Compass where

+  pp CompassN  = text "n"

+  pp CompassE  = text "e"

+  pp CompassS  = text "s"

+  pp CompassW  = text "w"

+  pp CompassNE = text "ne"

+  pp CompassNW = text "nw"

+  pp CompassSE = text "se"

+  pp CompassSW = text "sw"

+

+instance PP Subgraph where

+  pp (NewSubgraph mi ss) = text "subgraph" <+> pp mi <+> lbrace $+$ indent (vcat' ss) $+$ rbrace

+  pp (SubgraphRef i)     = text "subgraph" <+> pp i

+

+instance PP Entity where

+  pp (ENodeId et ni)   = pp et <+> pp ni

+  pp (ESubgraph et sg) = pp et <+> pp sg

+

+instance PP EdgeType where

+  pp NoEdge         = empty

+  pp DirectedEdge   = text "->"

+  pp UndirectedEdge = text "--"

+

+instance PP Xml where

+  pp (XmlEmptyTag n as) = langle <> pp n <+> hsep' as <> slash <> rangle

+  pp (XmlTag n as xs)   = langle <> pp n <+> hsep' as <> rangle <> hcat' xs <> langle <> slash <> pp n <> rangle

+  pp (XmlText t)        = text t

+

+instance PP XmlName where

+  pp (XmlName n) = text n

+

+instance PP XmlAttribute where

+  pp (XmlAttribute n v) = pp n <> equals <> pp v

+

+instance PP XmlAttributeValue where

+  pp (XmlAttributeValue v) = doubleQuotes (text v)

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+indent :: Doc -> Doc

+indent = nest 2

+

+hcat' :: (PP a) => [a] -> Doc

+hcat' = hcat . map pp

+

+hsep' :: (PP a) => [a] -> Doc

+hsep' = hsep . map pp

+

+vcat' :: (PP a) => [a] -> Doc

+vcat' = vcat . map pp

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+langle :: Doc

+rangle :: Doc

+slash  :: Doc

+

+langle = char '<'

+rangle = char '>'

+slash  = char '/'

+

+ffloat :: Float -> Doc

+ffloat v = text (showFFloat Nothing v "")

diff --git a/Haskell-book/24/language-dot/src/Language/Dot/Syntax.hs b/Haskell-book/24/language-dot/src/Language/Dot/Syntax.hs
new file mode 100644
index 0000000..cca7d99
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/Language/Dot/Syntax.hs
@@ -0,0 +1,92 @@
+-- | DOT AST. See <http://www.graphviz.org/doc/info/lang.html>.

+

+module Language.Dot.Syntax where

+

+data Graph

+  = Graph GraphStrictness GraphDirectedness (Maybe Id) [Statement]

+  deriving (Eq, Show)

+

+data GraphStrictness

+  = StrictGraph

+  | UnstrictGraph

+  deriving (Eq, Show)

+

+data GraphDirectedness

+  = DirectedGraph

+  | UndirectedGraph

+  deriving (Eq, Show)

+

+data Id

+  = NameId    String

+  | StringId  String

+  | IntegerId Integer

+  | FloatId   Float

+  | XmlId     Xml

+  deriving (Eq, Show)

+

+data Statement

+  = NodeStatement       NodeId [Attribute]

+  | EdgeStatement       [Entity] [Attribute]

+  | AttributeStatement  AttributeStatementType [Attribute]

+  | AssignmentStatement Id Id

+  | SubgraphStatement   Subgraph

+  deriving (Eq, Show)

+

+data AttributeStatementType

+  = GraphAttributeStatement

+  | NodeAttributeStatement

+  | EdgeAttributeStatement

+  deriving (Eq, Show)

+

+data Attribute

+  = AttributeSetTrue  Id

+  | AttributeSetValue Id Id

+  deriving (Eq, Show)

+

+data NodeId

+  = NodeId Id (Maybe Port)

+  deriving (Eq, Show)

+

+data Port

+  = PortI Id (Maybe Compass)

+  | PortC Compass

+  deriving (Eq, Show)

+

+data Compass

+  = CompassN  | CompassE  | CompassS  | CompassW

+  | CompassNE | CompassNW | CompassSE | CompassSW

+  deriving (Eq, Show)

+

+data Subgraph

+  = NewSubgraph (Maybe Id) [Statement]

+  | SubgraphRef Id

+  deriving (Eq, Show)

+

+data Entity

+  = ENodeId   EdgeType NodeId

+  | ESubgraph EdgeType Subgraph

+  deriving (Eq, Show)

+

+data EdgeType

+  = NoEdge

+  | DirectedEdge

+  | UndirectedEdge

+  deriving (Eq, Show)

+

+data Xml

+  = XmlEmptyTag XmlName [XmlAttribute]

+  | XmlTag      XmlName [XmlAttribute] [Xml]

+  | XmlText     String

+  deriving (Eq, Show)

+

+data XmlName

+  = XmlName String

+  deriving (Eq, Show)

+

+data XmlAttribute

+  = XmlAttribute XmlName XmlAttributeValue

+  deriving (Eq, Show)

+

+data XmlAttributeValue

+  = XmlAttributeValue String

+  deriving (Eq, Show)

diff --git a/Haskell-book/24/language-dot/src/ppdot.hs b/Haskell-book/24/language-dot/src/ppdot.hs
new file mode 100644
index 0000000..6051845
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/ppdot.hs
@@ -0,0 +1,72 @@
+module Main (main) where

+

+import Control.Exception   (IOException, try)

+import Control.Monad.Error (ErrorT(..), MonadError(..))

+import System.Environment  (getArgs, getProgName)

+import System.Exit         (exitFailure, exitSuccess)

+import System.IO           (hPutStrLn, stderr)

+

+import Language.Dot (parseDot, renderDot)

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+main :: IO ()

+main =

+    getArgs >>= run

+

+run :: [String] -> IO ()

+run args =

+    case args of

+      [fp] -> renderDotFile fp

+      []   -> displayUsage >> exitSuccess

+      _    -> displayUsage >> exitFailure

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+renderDotFile :: FilePath -> IO ()

+renderDotFile fp =

+    runErrorT (renderDotFileET fp) >>= either exitError putStrLn

+

+renderDotFileET :: FilePath -> ErrorT String IO String

+renderDotFileET fp = do

+    contents <- readFile fp `liftCatch` show

+    graph    <- parseDot fp contents `liftEither` show

+    return $ renderDot graph

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+displayUsage :: IO ()

+displayUsage = do

+    programName <- getProgName

+    ePutStrLns

+      [ programName ++ ": Pretty-print a Graphviz DOT file."

+      , unwords ["Usage:", programName, "FILE"]

+      ]

+

+exitError :: String -> IO ()

+exitError e = do

+    displayUsage

+    ePutStrLn ""

+    let el = lines e

+    if length el == 1

+      then ePutStrLn  ("ERROR: " ++ e)

+      else ePutStrLns ("ERROR:" : indent el)

+    exitFailure

+  where

+    indent = map ("  "++)

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+liftCatch :: IO a -> (IOException -> e) -> ErrorT e IO a

+liftCatch a f = ErrorT $ fmap (either (Left . f) Right) (try a)

+

+liftEither :: (MonadError e m) => Either l r -> (l -> e) -> m r

+liftEither e f = either (throwError . f) return e

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+ePutStrLn :: String -> IO ()

+ePutStrLn = hPutStrLn stderr

+

+ePutStrLns :: [String] -> IO ()

+ePutStrLns = mapM_ (hPutStrLn stderr)

diff --git a/Haskell-book/24/language-dot/src/test.hs b/Haskell-book/24/language-dot/src/test.hs
new file mode 100644
index 0000000..2fa4e0b
--- /dev/null
+++ b/Haskell-book/24/language-dot/src/test.hs
@@ -0,0 +1,120 @@
+module Main (main) where

+

+import Control.Monad (unless)

+import Data.Char     (toLower, toUpper)

+

+import Text.Parsec

+import Text.Parsec.String

+

+import Language.Dot.Parser

+import Language.Dot.Syntax

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+main :: IO ()

+main = do

+    testParser "parsePort"      parsePort      parsePortTests

+    testParser "parseCompass"   parseCompass   parseCompassTests

+    testParser "parseAttribute" parseAttribute parseAttributeTests

+    testParser "parseId"        parseId        parseIdTests

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parsePortTests :: [(String, Port)]

+parsePortTests =

+    [ ( ":\"x\""          , PortI (StringId  "x"       ) Nothing          )

+    , ( ":\"\\t\\\"\":nw" , PortI (StringId  "\\t\""   ) (Just CompassNW) )

+    , ( ":-.0004"         , PortI (FloatId   (-0.0004) ) Nothing          )

+    , ( ":-1.23:sE"       , PortI (FloatId   (-1.23)   ) (Just CompassSE) )

+    , ( ":123"            , PortI (IntegerId 123       ) Nothing          )

+    , ( ":123:NE"         , PortI (IntegerId 123       ) (Just CompassNE) )

+    , ( ":__2xYz"         , PortI (NameId    "__2xYz"  ) Nothing          )

+    , ( ":__2xYz:S"       , PortI (NameId    "__2xYz"  ) (Just CompassS)  )

+    , ( ":n"              , PortC CompassN  )

+    , ( ":SE"             , PortC CompassSE )

+    ]

+

+parseCompassTests :: [(String, Compass)]

+parseCompassTests =

+    concat

+      [ [ (t, CompassN)  | t <- allCaps "n"  ]

+      , [ (t, CompassE)  | t <- allCaps "e"  ]

+      , [ (t, CompassS)  | t <- allCaps "s"  ]

+      , [ (t, CompassW)  | t <- allCaps "w"  ]

+      , [ (t, CompassNE) | t <- allCaps "ne" ]

+      , [ (t, CompassNW) | t <- allCaps "nw" ]

+      , [ (t, CompassSE) | t <- allCaps "se" ]

+      , [ (t, CompassSW) | t <- allCaps "sw" ]

+      ]

+

+parseAttributeTests :: [(String, Attribute)]

+parseAttributeTests =

+    [ ( "a"                      , AttributeSetTrue  (NameId "a")                           )

+    , ( "a=b"                    , AttributeSetValue (NameId "a")       (NameId "b")        )

+    , ( "-.003\t=\r\n  _xYz123_" , AttributeSetValue (FloatId (-0.003)) (NameId "_xYz123_") )

+    , ( "\"\\t\\\"\"  =-123"     , AttributeSetValue (StringId "\\t\"") (IntegerId (-123))  )

+    ]

+

+parseIdTests :: [(String, Id)]

+parseIdTests =

+    [ ( "a"             , NameId    "a"         )

+    , ( "A1"            , NameId    "A1"        )

+    , ( "_2X"           , NameId    "_2X"       )

+    , ( "\"\""          , StringId  ""          )

+    , ( "\"\\t\\r\\n\"" , StringId  "\\t\\r\\n" )

+    , ( ".0"            , FloatId   0.0         )

+    , ( ".123"          , FloatId   0.123       )

+    , ( "+.999"         , FloatId   0.999       )

+    , ( "-.001"         , FloatId   (-0.001)    )

+    , ( "+.001"         , FloatId   0.001       )

+    , ( "0.0"           , FloatId   0.0         )

+    , ( "1.2"           , FloatId   1.2         )

+    , ( "123.456"       , FloatId   123.456     )

+    , ( "0"             , IntegerId 0           )

+    , ( "+0"            , IntegerId 0           )

+    , ( "-0"            , IntegerId 0           )

+    , ( "123"           , IntegerId 123         )

+    , ( "-123"          , IntegerId (-123)      )

+    ]

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+testParser :: (Eq a, Show a) => String -> Parser a -> [(String, a)] -> IO ()

+testParser name parser tests =

+    help tests [] (0 :: Int) (0 :: Int)

+  where

+    help [] es np nf = do

+        putStrLn $ name ++ ": " ++ show np ++ " passed, " ++ show nf ++ " failed"

+        mapM_ (putStrLn . ("  "++)) (reverse es)

+        unless (null es) (putStrLn "")

+    help ((i,o):ts) es np nf =

+        case parse' parser i of

+          Left  _ -> help ts (makeFailureMessage name i o : es) np (succ nf)

+          Right v ->

+            if v /= o

+              then help ts (makeFailureMessage' name i o v : es) np (succ nf)

+              else help ts es (succ np) nf

+

+makeFailureMessage :: (Show a) => String -> String -> a -> String

+makeFailureMessage name i o =

+    "(" ++ name ++ " " ++ show i ++ ")" ++

+    " should have returned " ++ "(" ++ show o ++ ")"

+

+makeFailureMessage' :: (Show a) => String -> String -> a -> a -> String

+makeFailureMessage' name i o v =

+    "(" ++ name ++ " " ++ show i ++ ")" ++

+    " returned "  ++ "(" ++ show v ++ ")" ++

+    ", expected " ++ "(" ++ show o ++ ")"

+

+-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- --

+

+parse' :: Parser a -> String -> Either ParseError a

+parse' p = parse p ""

+

+allCaps :: String -> [String]

+allCaps []     = [[]]

+allCaps (c:cs) =

+    concatMap (\t -> [l:t, u:t]) (allCaps cs)

+  where

+    l = toLower c

+    u = toUpper c