From 98329e0a3dd4f78b5d815ac3896272ec70904901 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Thu, 11 Dec 2025 10:28:11 +0100 Subject: Add remaining haskell book exercises --- Haskell-book/24/LearnParsers/.gitignore | 3 + Haskell-book/24/LearnParsers/ChangeLog.md | 3 + Haskell-book/24/LearnParsers/Setup.hs | 2 + Haskell-book/24/LearnParsers/app/Main.hs | 24 + Haskell-book/24/LearnParsers/package.yaml | 24 + Haskell-book/24/LearnParsers/src/LearnParsers.hs | 45 ++ Haskell-book/24/LearnParsers/src/Text/Fractions.hs | 31 ++ Haskell-book/24/LearnParsers/stack.yaml | 66 +++ Haskell-book/24/ParserExercises/.gitignore | 3 + Haskell-book/24/ParserExercises/Setup.hs | 2 + Haskell-book/24/ParserExercises/package.yaml | 38 ++ .../24/ParserExercises/src/Base10Integer.hs | 52 +++ Haskell-book/24/ParserExercises/src/IPAddress.hs | 260 +++++++++++ Haskell-book/24/ParserExercises/src/LogParser.hs | 83 ++++ Haskell-book/24/ParserExercises/src/PhoneNumber.hs | 28 ++ Haskell-book/24/ParserExercises/src/SemVer.hs | 51 +++ Haskell-book/24/ParserExercises/stack.yaml | 66 +++ .../24/ParserExercises/test/LogTest/Main.hs | 14 + Haskell-book/24/ParserExercises/test/Spec/Main.hs | 107 +++++ Haskell-book/24/language-dot/LICENSE | 29 ++ Haskell-book/24/language-dot/Setup.hs | 12 + Haskell-book/24/language-dot/language-dot.cabal | 59 +++ Haskell-book/24/language-dot/src/Language/Dot.hs | 10 + .../24/language-dot/src/Language/Dot/Parser.hs | 486 +++++++++++++++++++++ .../24/language-dot/src/Language/Dot/Pretty.hs | 135 ++++++ .../24/language-dot/src/Language/Dot/Syntax.hs | 92 ++++ Haskell-book/24/language-dot/src/ppdot.hs | 72 +++ Haskell-book/24/language-dot/src/test.hs | 120 +++++ 28 files changed, 1917 insertions(+) create mode 100644 Haskell-book/24/LearnParsers/.gitignore create mode 100644 Haskell-book/24/LearnParsers/ChangeLog.md create mode 100644 Haskell-book/24/LearnParsers/Setup.hs create mode 100644 Haskell-book/24/LearnParsers/app/Main.hs create mode 100644 Haskell-book/24/LearnParsers/package.yaml create mode 100644 Haskell-book/24/LearnParsers/src/LearnParsers.hs create mode 100644 Haskell-book/24/LearnParsers/src/Text/Fractions.hs create mode 100644 Haskell-book/24/LearnParsers/stack.yaml create mode 100644 Haskell-book/24/ParserExercises/.gitignore create mode 100644 Haskell-book/24/ParserExercises/Setup.hs create mode 100644 Haskell-book/24/ParserExercises/package.yaml create mode 100644 Haskell-book/24/ParserExercises/src/Base10Integer.hs create mode 100644 Haskell-book/24/ParserExercises/src/IPAddress.hs create mode 100644 Haskell-book/24/ParserExercises/src/LogParser.hs create mode 100644 Haskell-book/24/ParserExercises/src/PhoneNumber.hs create mode 100644 Haskell-book/24/ParserExercises/src/SemVer.hs create mode 100644 Haskell-book/24/ParserExercises/stack.yaml create mode 100644 Haskell-book/24/ParserExercises/test/LogTest/Main.hs create mode 100644 Haskell-book/24/ParserExercises/test/Spec/Main.hs create mode 100644 Haskell-book/24/language-dot/LICENSE create mode 100644 Haskell-book/24/language-dot/Setup.hs create mode 100644 Haskell-book/24/language-dot/language-dot.cabal create mode 100644 Haskell-book/24/language-dot/src/Language/Dot.hs create mode 100644 Haskell-book/24/language-dot/src/Language/Dot/Parser.hs create mode 100644 Haskell-book/24/language-dot/src/Language/Dot/Pretty.hs create mode 100644 Haskell-book/24/language-dot/src/Language/Dot/Syntax.hs create mode 100644 Haskell-book/24/language-dot/src/ppdot.hs create mode 100644 Haskell-book/24/language-dot/src/test.hs (limited to 'Haskell-book/24') 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 +maintainer: Brian Lewis +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 . + +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 -- cgit v1.2.3