diff --git a/24-parser-combination/24.11-chapter-exercises.md b/24-parser-combination/24.11-chapter-exercises.md new file mode 100644 index 0000000..995ebac --- /dev/null +++ b/24-parser-combination/24.11-chapter-exercises.md @@ -0,0 +1,11 @@ +# Chapter Exercises +1. see src/SemVer.hs +2. see src/PosInt.hs +3. see src/PosInt.hs +4. see src/PhoneNumber.hs +5. see src/ParseLog.hs +6. see src/IPAddress.hs +7. see src/IPAddress.hs +8. see src/IPAddress.hs +9. see src/IPAddress.hs +10. Not done (yet). \ No newline at end of file diff --git a/24-parser-combination/24.3-parsing-practise.md b/24-parser-combination/24.3-parsing-practise.md new file mode 100644 index 0000000..09b6116 --- /dev/null +++ b/24-parser-combination/24.3-parsing-practise.md @@ -0,0 +1,2 @@ +# Exercises: Parsing Practise +see src/LearnParsers.hs \ No newline at end of file diff --git a/24-parser-combination/24.4-unit-of-success.md b/24-parser-combination/24.4-unit-of-success.md new file mode 100644 index 0000000..aa0d175 --- /dev/null +++ b/24-parser-combination/24.4-unit-of-success.md @@ -0,0 +1,4 @@ +# Exercise: Unit of Success +`(>>)` is actually `(*>)` from `Applicative` and `Applicative` also has `(<*)` which has type `Applicative f => f a -> f b -> f a` + +So the solution here is: `integer <* eof` \ No newline at end of file diff --git a/24-parser-combination/24.6-try-try.md b/24-parser-combination/24.6-try-try.md new file mode 100644 index 0000000..9077ec0 --- /dev/null +++ b/24-parser-combination/24.6-try-try.md @@ -0,0 +1,2 @@ +# Exercise: Try Try +see src/TryTry.hs \ No newline at end of file diff --git a/24-parser-combination/src/AltParsing.hs b/24-parser-combination/src/AltParsing.hs new file mode 100644 index 0000000..c57b361 --- /dev/null +++ b/24-parser-combination/src/AltParsing.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE QuasiQuotes #-} +module AltParsing where + +import Control.Applicative +import Text.RawString.QQ +import Text.Trifecta + +type NumberOrString = Either Integer String + +a :: String +a = "blah" +b :: String +b = "123" +c :: String +c = "123blah789" + +eitherOr :: String +eitherOr = [r| +123 +abc +456 +def +|] + +parseNos :: Parser NumberOrString +parseNos = do + skipMany (oneOf "\n") + v <- (Left <$> integer) <|> (Right <$> some letter) + skipMany (oneOf "\n") + return v + +main :: IO () +main = do + let p f i = parseString f mempty i + print $ p (some letter) a + print $ p integer b + print $ p parseNos a + print $ p parseNos b + print $ p (many parseNos) c + print $ p (some parseNos) c + print $ p (some parseNos) eitherOr diff --git a/24-parser-combination/src/BT.hs b/24-parser-combination/src/BT.hs new file mode 100644 index 0000000..26a169d --- /dev/null +++ b/24-parser-combination/src/BT.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE OverloadedStrings #-} +module BT where + +import Control.Applicative +import qualified Data.Attoparsec.ByteString as A +import Data.Attoparsec.ByteString (parseOnly) +import Data.ByteString (ByteString) +import Text.Trifecta hiding (parseTest) +import Text.Parsec (Parsec, parseTest) + +-- Helper function to run a trifecta parser and print the result +trifP :: Show a => Parser a -> String -> IO () +trifP p i = print $ parseString p mempty i + +-- Helper function to run a parsec parser and print the result +parsecP :: Show a => Parsec String () a -> String -> IO () +parsecP = parseTest + +-- Helper function to runan attoparsec and print the result +attoP :: Show a => A.Parser a -> ByteString -> IO () +attoP p i = print $ parseOnly p i + +-- Parsers +nobackParse :: (Monad f, CharParsing f) => f Char +nobackParse = (char '1' >> char '2') <|> char '3' + +tryParse :: (Monad f, CharParsing f) => f Char +tryParse = try (char '1' >> char '2') <|> char '3' + +tryAnnot :: (Monad f, CharParsing f) => f Char +tryAnnot = (try (char '1' >> char '2') "Tried 12") + <|> (char '3' "Tried 3") + +-- Main +main :: IO () +main = do + -- trifecta + trifP nobackParse "13" + trifP tryParse "13" + trifP tryAnnot "13" + -- parsec + parsecP nobackParse "13" + parsecP tryParse "13" + parsecP tryAnnot "13" + -- attoparsec + attoP nobackParse "13" + attoP tryParse "13" + attoP tryAnnot "13" diff --git a/24-parser-combination/src/Fractions.hs b/24-parser-combination/src/Fractions.hs new file mode 100644 index 0000000..5ee23bd --- /dev/null +++ b/24-parser-combination/src/Fractions.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +module Text.Fractions where + +import Data.Attoparsec.Text (parseOnly) +import Data.Ratio ((%)) +import Data.String (IsString) +import Text.Trifecta + +badFraction :: IsString a => a +badFraction = "1/0" +alsoBad :: IsString a => a +alsoBad = "10" +shouldWork :: IsString a => a +shouldWork = "1/2" +shouldAlsoWork :: IsString a => a +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) + +parseFraction :: (Monad m, TokenParsing m) => m Rational +parseFraction = do + numerator <- decimal + char '/' + denominator <- decimal + case denominator of + 0 -> fail "Denominator cannot be zero" + _ -> return (numerator % denominator) + +main :: IO () +main = do + -- parseOnly is Attoparsec + let attoP = parseOnly parseFraction + print $ attoP badFraction + print $ attoP shouldWork + print $ attoP shouldAlsoWork + print $ attoP alsoBad + + -- parseString is Trifecta + let p = parseString parseFraction mempty + print $ p badFraction + print $ p shouldWork + print $ p shouldAlsoWork + print $ p alsoBad + -- let p = parseString parseFraction mempty + -- print $ p shouldWork + -- print $ p shouldAlsoWork + -- print $ p alsoBad + -- print $ p badFraction + +-- testVirtuous :: IO () +-- testVirtuous = do +-- let virtuousFraction' = parseString virtuousFraction mempty +-- print $ virtuousFraction' shouldWork +-- print $ virtuousFraction' shouldAlsoWork +-- print $ virtuousFraction' alsoBad +-- print $ virtuousFraction' badFraction \ No newline at end of file diff --git a/24-parser-combination/src/GraphViz.hs b/24-parser-combination/src/GraphViz.hs new file mode 100644 index 0000000..78d6160 --- /dev/null +++ b/24-parser-combination/src/GraphViz.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GraphViz where + diff --git a/24-parser-combination/src/IPAddress.hs b/24-parser-combination/src/IPAddress.hs new file mode 100644 index 0000000..45043ae --- /dev/null +++ b/24-parser-combination/src/IPAddress.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE OverloadedStrings #-} + +module IPAddress where + +import Text.Trifecta hiding (span) +import Data.Word +import Data.Bits +import Data.List (splitAt) +import Numeric (readHex, showHex) +import Control.Monad.State +import Data.Maybe (fromMaybe) +-- import Data.List (group, span) +import Data.Either (lefts) +-- import qualified Data.Sequence as S + +import Test.Hspec + +-- Exercise 6 +data IPAddress = IPAddress Word32 deriving (Eq, Ord) +instance Show IPAddress where + show (IPAddress w32) = + let n = toInteger w32 + in show ((n `shiftR` 24) .&. 0xFF) ++ "." ++ + show ((n `shiftR` 16) .&. 0xFF) ++ "." ++ + show ((n `shiftR` 8) .&. 0xFF) ++ "." ++ + show (n .&. 0xFF) + +parseValidIPByte :: Parser Word8 +parseValidIPByte = do + i <- decimal + let max' = toInteger (maxBound :: Word8) + min' = toInteger (minBound :: Word8) + if i <= max' && i >= min' + then return (fromInteger i) + else unexpected "Invalid byte" + +parseIPv4Address :: Parser IPAddress +parseIPv4Address = do + b1 <- toInteger <$> parseValidIPByte + _ <- char '.' + b2 <- toInteger <$> parseValidIPByte + _ <- char '.' + b3 <- toInteger <$> parseValidIPByte + _ <- char '.' + b4 <- toInteger <$> parseValidIPByte + return $ IPAddress . fromInteger $ (b1 `shiftL` 24) + + (b2 `shiftL` 16) + + (b3 `shiftL` 8) + + b4 + +maybeSuccess :: Result a -> Maybe a +maybeSuccess (Success a) = Just a +maybeSuccess _ = Nothing + +testByteHelper :: String -> Maybe Word8 -> Expectation +testByteHelper s r = do + let m = parseString parseValidIPByte mempty s + r' = maybeSuccess m + r' `shouldBe` r + +testIPv4Helper :: String -> Maybe IPAddress -> Expectation +testIPv4Helper s r = do + let m = parseString parseIPv4Address mempty s + r' = maybeSuccess m + r' `shouldBe` r + +testByte :: IO () +testByte = hspec $ do + describe "Test parsing of byte" $ do + it "Can parse 0" $ testByteHelper "0" (Just 0) + it "Can parse 255" $ testByteHelper "255" (Just 255) + it "Can't parse 256" $ testByteHelper "256" Nothing + it "Can't parse -1" $ testByteHelper "-1" Nothing + it "Can't parse empty" $ testByteHelper "" Nothing + +testIPv4 :: IO () +testIPv4 = hspec $ do + describe "Test parsing of IPv4" $ do + it "Can parse 0.0.0.0" $ do + testIPv4Helper "0.0.0.0" (Just (IPAddress 0)) + it "Can parse 255.255.255.255" $ do + testIPv4Helper "255.255.255.255" (Just (IPAddress (2^32 - 1))) + it "Can parse 0.0.0.255.1" $ do + testIPv4Helper "0.0.0.255.1" (Just (IPAddress 255)) + it "Can't parse .0.0.0.0" $ do + testIPv4Helper ".0.0.0.0" Nothing + it "Can't parse 0..0.0.0" $ do + testIPv4Helper "0..0.0.0" Nothing + +toIPAddress6 :: IPAddress -> IPAddress6 +toIPAddress6 (IPAddress w32) = IPAddress6 0 (fromIntegral w32) + +-- Exercise 7 + +-- Datatypes: +data IPAddress6 = IPAddress6 Word64 Word64 deriving (Eq, Ord) +-- An IPv6Piece is the part between ':', it can be either +-- "::" or "ABCD" +type IPv6Piece = Either () Word16 + +-- +toArray :: IPAddress6 -> [Word16] +toArray (IPAddress6 w64 w64') = + let n = toInteger w64 + m = toInteger w64' + mask = fromInteger . (\a -> (.&.) a 0xFFFF) + in mask (n `shiftR` 48) : + mask (n `shiftR` 32) : + mask (n `shiftR` 16) : + mask n : + mask (m `shiftR` 48) : + mask (m `shiftR` 32) : + mask (m `shiftR` 16) : + mask m : [] + +toArray' :: [Word16] -> [Either Int Word16] +toArray' [] = [] +toArray' s@(0:0:_) = (Left $ length ys) : (toArray' zs) + where (ys, zs) = span (==0) s +toArray' (x:xs) = (Right x) : toArray' xs + +findMax :: [Either Int Word16] -> Maybe Int +findMax xs = go $ lefts xs + where go [] = Nothing + go ys = Just $ maximum ys + +replaceLeft :: Int -> [Either Int Word16] -> [IPv6Piece] +replaceLeft m xs = go m xs False + where go _ [] _ = [] + go i ((Right c):ys) b = (Right c) : (go i ys b) + go i ((Left c):ys) False = + if (c == i) + then (Left ()) : (go i ys True) + else (replicate c (Right 0)) ++ (go i ys False) + go i ((Left c):ys) True = (replicate c (Right 0)) ++ (go i ys True) + +showPieces :: [IPv6Piece] -> String +showPieces [] = "" +showPieces ((Right c):ys) = (showHex c "") ++ (go ys) + where go [] = [] + go (Right c':zs) = ":" ++ (showHex c' "") ++ (go zs) + go zs = showPieces zs +showPieces ((Left ():ys)) = "::" ++ (showPieces ys) + + +instance Show IPAddress6 where + show p = let xs = toArray' (toArray p) + in showPieces $ (case findMax xs of + Nothing -> replaceLeft 0 xs + (Just i) -> replaceLeft i xs) + +validHex :: String +validHex = "abcdefABCDEF0123456789" + +-- Helper functions +-- only parses [0-9A-Fa-f]{1,4} +readWord16 :: String -> Maybe Word16 +readWord16 s = + let r = readHex (take 4 s) :: [(Word16, String)] + in case r of + ((w,s'):[]) -> if s' == "" then Just w else Nothing + _ -> Nothing + +mkWord64 :: Word16 -> Word16 -> Word16 -> Word16 -> Word64 +mkWord64 a b c d = (fromIntegral a `shiftL` 48) + + (fromIntegral b `shiftL` 32) + + (fromIntegral c `shiftL` 16) + + (fromIntegral d) + +mkIPAddress6 :: [Word16] -> Maybe IPAddress6 +mkIPAddress6 xs = + case length xs of + 8 -> let (a,b) = splitAt 4 xs + w1 = (mkWord64 (a !! 0) (a !! 1) (a !! 2) (a !! 3)) + w2 = (mkWord64 (b !! 0) (b !! 1) (b !! 2) (b !! 3)) + in Just $ IPAddress6 w1 w2 + _ -> Nothing + +expandIPv6Pieces :: [IPv6Piece] -> Maybe [Word16] +expandIPv6Pieces xs = + case length $ filter (==(Left ())) xs of + 0 -> Just $ foldr f [] xs + 1 -> Just $ foldr g [] xs + _ -> Nothing + where f (Left _) s = s + f (Right c) s = c:s + n = max (9 - (length xs)) 0 + g (Left _) s = (take n $ repeat 0) ++ s + g (Right c) s = c:s + +getIPAddress6 :: [IPv6Piece] -> Maybe IPAddress6 +getIPAddress6 xs = expandIPv6Pieces xs >>= mkIPAddress6 + +type IPv6State = Bool +type IPv6Parser a = StateT IPv6State Parser a + +-- Parsing the individual pieces: +-- hex, 1-4 hexes, ':', '::' +parseSingleHex :: IPv6Parser Char +parseSingleHex = do + c <- oneOf validHex + return c + +parseIPv6Hex :: IPv6Parser Word16 +parseIPv6Hex = do + c1 <- parseSingleHex "At least one hex" + o <- mapStateT f $ count 3 $ optional parseSingleHex + let s = c1 : (fromMaybe "" o) + case readWord16 s of + Just w -> return w + Nothing -> unexpected $ "Invalid piece: " ++ s + where f :: Parser ([Maybe Char], IPv6State) + -> Parser (Maybe [Char], IPv6State) + f = fmap (\(c,b) -> (sequence c, b)) + +parseSep :: IPv6Parser String +parseSep = do + c <- string ":" + return c + +parseCons :: IPv6Parser (Maybe IPv6Piece) +parseCons = do + b <- get + c <- optional $ string "::" + case c of + Nothing -> return Nothing + Just _ -> if b + then unexpected "Only one '::' allowed" + else do + put True + return (Just $ Left ()) + +-- Parses: +-- ::ABCD +-- :ABCD +parseInnerParts :: IPv6Parser [IPv6Piece] +parseInnerParts = do + c <- parseCons + case c of + Nothing -> do + parseSep + w <- parseIPv6Hex + return [Right w] + Just _ -> do + w <- parseIPv6Hex + return [Left (), Right w] + + +parseIPv6Address :: IPv6Parser IPAddress6 +parseIPv6Address = do + c <- parseCons + w <- parseIPv6Hex + a <- case c of + Nothing -> do + xs <- mapStateT f $ many parseInnerParts + c' <- parseCons + case c' of + Nothing -> return ([Right w] ++ xs) + Just _ -> return ([Right w] ++ xs ++ [Left ()]) + Just _ -> do + xs <- mapStateT f $ many parseInnerParts + return $ ([Left ()] ++ [Right w] ++ xs) + case getIPAddress6 a of + Nothing -> unexpected "Invalid format" + Just a' -> return a' + where f :: Parser ([[IPv6Piece]], IPv6State) + -> Parser ([IPv6Piece], IPv6State) + f = fmap (\(xs, b) -> (concat xs, b)) + +toIPAddress :: IPAddress6 -> Maybe IPAddress +toIPAddress (IPAddress6 w64 w64') + | w64 /= 0 = Nothing + | w64' > (fromIntegral $ (maxBound :: Word32)) = Nothing + | otherwise = Just $ IPAddress (fromIntegral w64') \ No newline at end of file diff --git a/24-parser-combination/src/Ini.hs b/24-parser-combination/src/Ini.hs new file mode 100644 index 0000000..ae63dff --- /dev/null +++ b/24-parser-combination/src/Ini.hs @@ -0,0 +1,152 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Data.Ini where + +import Control.Applicative +import Data.ByteString (ByteString) +import Data.Char (isAlpha) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Text (Text) +import qualified Data.Text.IO as TIO +import Test.Hspec +import Text.RawString.QQ +import Text.Trifecta + +headerEx :: ByteString +headerEx = "[blah]" + +newtype Header = Header String deriving (Eq, Ord, Show) + +parseBracketPair :: Parser a -> Parser a +parseBracketPair p = char '[' *> p <* char ']' + +parseHeader :: Parser Header +parseHeader = parseBracketPair (Header <$> some letter) + +assignmentEx :: ByteString +assignmentEx = "woot=1" + +type Name = String +type Value = String +type Assignments = Map Name Value + +parseAssignment :: Parser (Name, Value) +parseAssignment = do + name <- some letter + _ <- char '=' + val <- some (noneOf "\n") + skipEOL -- important! + return (name, val) + + -- | Skip end of lien and whitespace beyond. +skipEOL :: Parser () +skipEOL = skipMany (oneOf "\n") + +commentEx :: ByteString +commentEx = "; last modified 11 November 2017 by John Doe" + +commentEx' :: ByteString +commentEx' = "; blah\n; woot\n \n; hah" + +-- | Skip comments starting at the beginning of the line +skipComments :: Parser () +skipComments = skipMany $ do + _ <- char ';' <|> char '#' + skipMany (noneOf "\n") + skipEOL + +sectionEx :: ByteString +sectionEx = "; ignore me\n[languages]\nGael=Haskell" + +sectionEx' :: ByteString +sectionEx' = [r| +; ignore me +[languages] +Gael=Haskell +|] + +sectionEx'' :: ByteString +sectionEx'' = [r| +; comment +[section] +host=wikipedia.org +alias=claw + +[whatisit] +red=intoothandclaw +|] + +data Section = Section Header Assignments deriving (Eq, Show) + +newtype Config = Config (Map Header Assignments) deriving (Eq, Show) + +skipWhitespace :: Parser () +skipWhitespace = skipMany (char ' ' <|> char '\n') + +parseSection :: Parser Section +parseSection = do + skipWhitespace + skipComments + h <- parseHeader + skipEOL + assignments <- some parseAssignment + return $ Section h (M.fromList assignments) + +rollup :: Section -> Map Header Assignments -> Map Header Assignments +rollup (Section h a) m = M.insert h a m + +parseIni :: Parser Config +parseIni = do + sections <- some parseSection + let mapOfSections = foldr rollup M.empty sections + return $ Config mapOfSections + +maybeSuccess :: Result a -> Maybe a +maybeSuccess (Success a) = Just a +maybeSuccess _ = Nothing + +main :: IO () +main = hspec $ do + describe "Assignment Parsing" $ + it "can parse a simple assignment" $ do + let m = parseByteString parseAssignment mempty assignmentEx + r' = maybeSuccess m + print m + r' `shouldBe` Just ("woot", "1") + describe "Header Parsing" $ + it "can parse a simple header" $ do + let m = parseByteString parseHeader mempty headerEx + r' = maybeSuccess m + print m + r' `shouldBe` Just (Header "blah") + describe "Comment parsing" $ + it "Skips comment before header" $ do + let p = skipComments >> parseHeader + i = "; woot\n[blah]" + m = parseByteString p mempty i + r' = maybeSuccess m + print m + r' `shouldBe` Just (Header "blah") + describe "Section parsing" $ + it "can parse a simple section" $ do + let m = parseByteString parseSection mempty sectionEx + r' = maybeSuccess m + languages = M.fromList [("Gael", "Haskell")] + expected' = Just (Section (Header "languages") languages) + print m + r' `shouldBe` expected' + describe "INI parsing" $ + it "Can parse multiple sections" $ do + let m = parseByteString parseIni mempty sectionEx'' + r' = maybeSuccess m + sectionValues = M.fromList + [ ("alias", "claw") , ("host", "wikipedia.org")] + whatisitValues = M.fromList [("red", "intoothandclaw")] + expected' = Just (Config (M.fromList [ (Header "section" + , sectionValues) + , (Header "whatisit" + , whatisitValues)])) + print m + r' `shouldBe` expected' \ No newline at end of file diff --git a/24-parser-combination/src/LearnParsers.hs b/24-parser-combination/src/LearnParsers.hs new file mode 100644 index 0000000..34f0759 --- /dev/null +++ b/24-parser-combination/src/LearnParsers.hs @@ -0,0 +1,81 @@ +module LearnParsers where + +import Text.Trifecta +import Text.Parser.Combinators (eof) + +import Control.Applicative ((<|>)) + +stop :: Parser a +stop = unexpected "stop" + +one :: Parser Char +one = char '1' + +one' :: Parser Char +one' = one >> stop + +oneTwo :: Parser Char +oneTwo = char '1' >> char '2' + +oneTwo' :: Parser Char +oneTwo' = oneTwo >> stop + +testParse :: Show a => Parser a -> IO () +testParse p = print $ parseString p mempty "123" + +-- testEOFParse :: Parser () -> IO () +-- testEOFParse p = print $ parseString p mempty "123" + +pNL :: String -> IO () +pNL s = putStrLn ('\n' : s) + +-- 1 +one'' :: Parser () +one'' = one >> eof + +oneTwo'' :: Parser () +oneTwo'' = oneTwo >> eof + +-- 2 +-- Looking at the documentation you can combine strings with <|> +oneTwoThree :: Parser String +-- Put the biggest string first as it matches from from left to right +oneTwoThree = string "123" <|> string "12" <|> string "1" + +-- Other solution is to use choice to create a parser from other parser +-- choice :: [Parser a] -> Parser a +oneTwoThree' :: Parser String +oneTwoThree' = choice [string "1", string "12", string "123"] + +-- 3 +-- Using foldr: +string' :: String -> Parser String +string' = foldr (\c p -> (:) c <$> p) (pure []) + +-- We haven't used the `char` function, if we do want to use it, we have +-- to use <*>: +string'' :: String -> Parser String +string'' = foldr (\c p -> (:) <$> char c <*> p) (pure []) + +-- Which is basically: +string''' :: String -> Parser String +string''' = traverse char + + + +main :: IO () +main = do + pNL "stop:" + testParse (stop :: Parser Char) + pNL "one:" + testParse one + pNL "one':" + testParse one' + pNL "oneTwo:" + testParse oneTwo + pNL "oneTwo'" + testParse oneTwo' + pNL "one'':" + testParse one'' + pNL "oneTwo'':" + testParse oneTwo'' diff --git a/24-parser-combination/src/Marshalling.hs b/24-parser-combination/src/Marshalling.hs new file mode 100644 index 0000000..f63ea46 --- /dev/null +++ b/24-parser-combination/src/Marshalling.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module Marshalling where + +import Control.Applicative +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import qualified Data.Text as T +import Data.Text (Text) +import Text.RawString.QQ + +sectionJson :: ByteString +sectionJson = [r| +{ "section": {"host": "wikipedia.org"}, + "whatisit": {"red": "intoothandclaw"} +} +|] + +data TestData = TestData { section :: Host, what :: Color } deriving (Eq, Show) + +instance FromJSON TestData where + parseJSON (Object v) = + TestData <$> v .: "section" + <*> v .: "whatisit" + parseJSON _ = fail "Expected an object for TestData" + +newtype Host = Host String deriving (Eq, Show) + +instance FromJSON Host where + parseJSON (Object v) = + Host <$> v .: "host" + parseJSON _ = fail "Expected an object for Host" + +type Annotation = String + +data Color = Red Annotation + | Blue Annotation + | Yellow Annotation + deriving (Eq, Show) + +instance FromJSON Color where + parseJSON (Object v) = + (Red <$> v .: "red") <|> + (Blue <$> v .: "blue") <|> + (Yellow <$> v .: "yellow") + parseJSON _ = fail "Expected an object for Color" + +main :: IO () +main = do + let d :: Maybe TestData + d = decode sectionJson + print d \ No newline at end of file diff --git a/24-parser-combination/src/NumberOrString.hs b/24-parser-combination/src/NumberOrString.hs new file mode 100644 index 0000000..f56111f --- /dev/null +++ b/24-parser-combination/src/NumberOrString.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module NumberOrString where + +import Control.Applicative +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import qualified Data.Text as T +import Data.Text (Text) +import Text.RawString.QQ +import Data.Scientific (floatingOrInteger) + +data NumberOrString = Numba Integer| Stringy Text deriving (Eq, Show) +instance FromJSON NumberOrString where + parseJSON (Number i) = + case floatingOrInteger i of + (Left _) -> fail "Must be integral number" + (Right integer) -> return $ Numba integer + parseJSON (String s) = return $ Stringy s + parseJSON _ = fail "NumberOrString must be number or string" + +dec :: ByteString -> Maybe NumberOrString +dec = decode + +eitherDec :: ByteString -> Either String NumberOrString +eitherDec = eitherDecode + +main = do + print $ dec "blah" + print $ eitherDec "blah" \ No newline at end of file diff --git a/24-parser-combination/src/ParseLog.hs b/24-parser-combination/src/ParseLog.hs new file mode 100644 index 0000000..704125e --- /dev/null +++ b/24-parser-combination/src/ParseLog.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +module ParseLog where + +import Control.Applicative ((<|>), liftA2) +import Data.Monoid ((<>)) +import Text.Trifecta +import Data.Time.Format +import Data.Time +import Data.List (intersperse) +import Text.RawString.QQ + +import Test.QuickCheck + +data LogEntry = LogEntry TimeOfDay String deriving Eq +instance Show LogEntry where + show (LogEntry t s) = + let time = formatTime defaultTimeLocale "%H:%M" t + in time ++ " " ++ s +instance Arbitrary LogEntry where + arbitrary = do + tod <- TimeOfDay <$> choose (0,23) <*> choose (0,59) <*> pure 0 + s <- liftA2 (++) + arbitrary + (oneof [((++) "--") <$> arbitrary, arbitrary]) + return $ LogEntry tod (filter (\c -> c /= '\n') s) + +data DayEntry = DayEntry Day [LogEntry] deriving Eq +instance Show DayEntry where + show (DayEntry d es) = + let day = formatTime defaultTimeLocale "%Y-%m-%d" d + entries = concat . intersperse "\n" . map show $ es + in "# " ++ day ++ "\n" ++ entries +instance Arbitrary DayEntry where + arbitrary = do + day <- ModifiedJulianDay <$> (2000 +) <$> arbitrary + es <- listOf arbitrary + return $ DayEntry day es + +data Log = Log [DayEntry] deriving Eq +instance Show Log where + show (Log ds) = concat . intersperse "\n\n" . map show $ ds +instance Arbitrary Log where + arbitrary = do + es <- listOf arbitrary + return $ Log es + +countTimeSpentDay :: [LogEntry] -> DiffTime +countTimeSpentDay [] = 0 +countTimeSpentDay (_:[]) = 0 +countTimeSpentDay (x:y:xs) = + let (LogEntry t1 _) = x + (LogEntry t2 _) = y + in (timeOfDayToTime t2) + - (timeOfDayToTime t1) + + (countTimeSpentDay (y:xs)) + +countDay :: DayEntry -> DiffTime +countDay (DayEntry _ e) = countTimeSpentDay e + +countTime :: Log -> DiffTime +countTime (Log ds) = sum $ map countDay ds + +skipBlankLines :: Parser () +skipBlankLines = + skipMany $ (skipWhiteSpace >> skipComment >> newline) <|> + (skipWhiteSpace >> newline) + +skipComment :: Parser () +skipComment = skipMany $ do + _ <- count 2 $ char '-' + skipMany $ notChar '\n' + +skipWhiteSpace :: Parser () +skipWhiteSpace = skipMany $ oneOf "\t " + +removeComment :: String -> String +removeComment [] = [] +removeComment (x:xs) = go "" x False xs + where go s '-' True _ = s -- skip comment + go s '-' False [] = s ++ "-" -- ended with '-' + go s c _ [] = s ++ [c] -- ended without comment + go s '-' False (y:ys) = go s y True ys -- possible start of comment + go s c _ (y:ys) = go (s ++ [c]) y False ys + + +parseLogEntry :: Parser LogEntry +parseLogEntry = do + t <- count 2 digit <> string ":" <> count 2 digit + let m = parseTimeM True defaultTimeLocale "%H:%M" t + timeOfDay <- case m of + Just time -> return time + Nothing -> unexpected "Incorrect time format" + _ <- space + s <- some $ notChar '\n' + _ <- newline + return $ LogEntry timeOfDay (removeComment s) + +parseDayEntry :: Parser DayEntry +parseDayEntry = do + _ <- char '#' + _ <- space + d <- some digit <> string "-" + <> count 2 digit <> string "-" + <> count 2 digit + let m = parseTimeM True defaultTimeLocale "%Y-%m-%d" d + day <- case m of + Just day' -> return day' + Nothing -> unexpected "Incorrect day format" + -- only thing allowed after day is whitespace and comments + skipWhiteSpace + skipComment + _ <- newline + -- Followed by a list of paserLogEntries + logEntries <- many parseLogEntry + skipBlankLines + return $ DayEntry day logEntries + +parseLog :: Parser Log +parseLog = do + skipBlankLines + dayEntries <- many parseDayEntry + return $ Log dayEntries + +testLog :: String +testLog = [r|-- wheee a comment + + +# 2025-02-05 +08:00 Breakfast +09:00 Sanitizing moisture collector +11:00 Exercising in high-grav gym +12:00 Lunch +13:00 Programming +17:00 Commuting home in rover +17:30 R&R +19:00 Dinner +21:00 Shower +21:15 Read +22:00 Sleep + +# 2025-02-07 -- dates not nececessarily sequential +08:00 Breakfast -- should I try skippin bfast? +09:00 Bumped head, passed out +13:36 Wake up, headache +13:37 Go to medbay +13:40 Patch self up +13:45 Commute home for rest +14:15 Read +21:00 Dinner +21:15 Read +22:00 Sleep +|] + +-- Generator for Log files +genBlankLine :: Gen String +genBlankLine = oneof [return "\t -- comment!\n", return " \t\n"] +genDayLine :: Gen String +genDayLine = do + day <- ModifiedJulianDay <$> (2000 +) <$> arbitrary + let day_string = formatTime defaultTimeLocale "%Y-%m-%d" day + oneof [ return $ "# " ++ day_string ++ "\t \n" + , return $ "# " ++ day_string ++ "\t -- comment!\n" ] +genLogEntry :: Gen String +genLogEntry = do + time <- TimeOfDay <$> choose (0,23) <*> choose (0,59) <*> pure 0 + let time_string = formatTime defaultTimeLocale "%H:%M" time + oneof [ return $ time_string ++ " some description \t \n" + , return $ time_string ++ " some description \t -- with comment\n"] +genDayEntry :: Gen String +genDayEntry = do + day <- genDayLine + logEntry <- genLogEntry -- at least one log entry + logEntryList <- concat <$> listOf genLogEntry + blankLines <- concat <$> listOf genBlankLine + return $ day ++ logEntry ++ logEntryList ++ blankLines +genLog :: Gen String +genLog = do + blankLines <- concat <$> listOf genBlankLine + dayEntries <- concat <$> listOf genDayEntry + return $ blankLines ++ dayEntries + +newtype LogExample = LogExample String deriving (Show) +instance Arbitrary LogExample where + arbitrary = LogExample <$> genLog + +propLog :: LogExample -> Bool +propLog (LogExample s) = case parseString parseLog mempty s of + Text.Trifecta.Success _ -> True + _ -> False + +main :: IO () +main = do + quickCheck propLog \ No newline at end of file diff --git a/24-parser-combination/src/PhoneNumber.hs b/24-parser-combination/src/PhoneNumber.hs new file mode 100644 index 0000000..537037c --- /dev/null +++ b/24-parser-combination/src/PhoneNumber.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PhoneNumber where + +import Control.Applicative ((<|>)) +import Text.Trifecta +import Test.Hspec + +-- This is an exercise for the Belgian Phone numbers system +-- From wikipedia +{- +Belgian telephone numbers consist of two major parts: Firstly '0', secondly the +"zone prefix" (A) which is 1 or 2 digits long for landlines and 3 digits long +for mobile phones and thirdly the "subscriber's number" (B). + +Land lines are always 9 digits long. They are prefixed by a zero, followed by +the zone prefix. Depending on the length of the zone prefix, the subscriber's +number consists of either 6 or 7 digits. Hence land line numbers are written +either 0AA BB BB BB or 0A BBB BB BB. + +Mobile Phone numbers always consist of 10 digits. The first digit of the "zone +prefix" of a mobile number is always '4'. Then follows 2 digits indicating to +which Mobile Operator's pool the number originally belonged when it was taken +into usage. The fourth digit represents a "sub-group" of this pool and has no +additional meaning other than increasing the amount of possible numbers. The +subscriber's number consists of 6 digits. Hence, mobile phone numbers are +written 04AA BB BB BB. Sometimes, the last 6 digits are written in two groups +of 3 digits to increase readability: 04AA BBB BBB. + +Numbers are sometimes written with a slash in between the zone prefix and the +subscriber's number. This is the case for both land lines and mobile phone +numbers. Sometimes, dots are written between the blocks of the subscriber's +number. Examples: 0AA/BB BB BB, 0AA/BB.BB.BB; for mobile numbers: +04AA/BB BB BB, 04AA/BB.BB.BB or 04AA/BBB.BBB. + +The international country code prefix for Belgium is "+32". When dialing a +number with the prefix, the 0 can be dropped, e.g.: +32 4AA BB BB BB. +-} + +-- see also https://en.wikipedia.org/wiki/Telephone_numbers_in_Belgium + + +-- Will only look at landlines and phonelines +-- not special numbers or non-geographic numbers +data ZonePrefix = MobileZP String + | LandOneZP String + | LandTwoZP String + deriving (Eq) +instance Show ZonePrefix where + show (MobileZP s) = "0" ++ s + show (LandOneZP s) = " 0" ++ s + show (LandTwoZP s) = " 0" ++ s + +data SubscribersNumber = MobileSN String + | LandOneSN String + | LandTwoSN String + deriving (Eq) +instance Show SubscribersNumber where + show (LandOneSN (a:b:c:d:e:f:g:[])) = a:b:c:" " ++ d:e:" " ++ f:g:[] + show (LandOneSN s) = "Invalid format: " ++ s + show (MobileSN (a:b:c:d:e:f:[])) = " " ++ a:b:" " ++ c:d:" " ++ e:f:[] + show (MobileSN s) = "Invalid format: " ++ s + show (LandTwoSN (a:b:c:d:e:f:[])) = " " ++ a:b:" " ++ c:d:" " ++ e:f:[] + show (LandTwoSN s) = "Invalid format: " ++ s + +data PhoneNumberBE = PhoneNumberBE ZonePrefix SubscribersNumber deriving Eq +instance Show PhoneNumberBE where + show (PhoneNumberBE z s) = "(PhoneNumberBE " ++ show z + ++ " " + ++ show s + ++ ")" + + +-- Mobile numbers are: 046x 047x 048x 049x +-- Land lines are most other things where: +-- 02,03,04 and 09 are single digit land line area codes +-- the rest are two digit land line phone +parseZonePrefix :: Parser ZonePrefix +parseZonePrefix = + let mobile = MobileZP <$> do + one <- char '4' + two <- oneOf ['6', '7', '8', '9'] + three <- digit + return $ [one, two, three] + landOne = LandOneZP . (:[]) <$> oneOf ['2', '3', '4', '9'] + landTwo = LandTwoZP <$> count 2 digit + -- Order is important, we want to check mobile first, followed by + -- landOne. Everything else is assumed to be land two + in mobile <|> landOne <|> landTwo + +parseMobileSN :: Parser SubscribersNumber +parseMobileSN = do + let p = count 2 digit + skip = skipOptional $ char ' ' <|> char '.' + p1 <- p + skip + p2 <- p + skip + p3 <- p + return . MobileSN $ p1 ++ p2 ++ p3 + +parseLandTwoSN :: Parser SubscribersNumber +parseLandTwoSN = do + let p = count 2 digit + skip = skipOptional $ char ' ' <|> char '.' + p1 <- p + skip + p2 <- p + skip + p3 <- p + return . LandTwoSN $ p1 ++ p2 ++ p3 + +parseLandOneSN :: Parser SubscribersNumber +parseLandOneSN = do + let p = count 2 digit + skip = skipOptional $ char ' ' <|> char '.' + p1 <- count 3 digit + skip + p2 <- p + skip + p3 <- p + return . LandTwoSN $ p1 ++ p2 ++ p3 + +parsePhone :: Parser PhoneNumberBE +parsePhone = do + -- Country code + m <- optional $ string "+32" + -- white space + skipMany $ char ' ' + -- Leading zero depends on country code + skipOptional $ char ' ' + _ <- case m of + Just _ -> do + a <- optional $ char '0' + case a of + Nothing -> return Nothing + Just _ -> unexpected "0 not expected here" + Nothing -> Just <$> char '0' + z <- parseZonePrefix + skipOptional $ char ' ' <|> char '/' + s <- case z of + MobileZP _ -> parseMobileSN + LandOneZP _ -> parseLandOneSN + LandTwoZP _ -> parseLandTwoSN + return $ PhoneNumberBE z s + +maybeSuccess :: Result a -> Maybe a +maybeSuccess (Success a) = Just a +maybeSuccess _ = Nothing + +-- Should test all options for mobile and single-digit land lines, +-- but that is just copy-paste... QuickCheck could also help. +main :: IO () +main = hspec $ do + describe "Parse Zone Prefix" $ do + it "Mobile starts with 4[6-9]x " $ do + let m = parseString parseZonePrefix mempty "472" + r = maybeSuccess m + r `shouldBe` Just (MobileZP "472") + it "Incorrect mobile zone prefix should fail" $ do + let m = parseString parseZonePrefix mempty "47" + r = maybeSuccess m + r `shouldBe` Nothing + it "Land line with single digit" $ do + let m = parseString parseZonePrefix mempty "2" + r = maybeSuccess m + r `shouldBe` Just (LandOneZP "2") + it "Land line with double digit" $ do + let m = parseString parseZonePrefix mempty "55" + r = maybeSuccess m + r `shouldBe` Just (LandTwoZP "55") + -- ... \ No newline at end of file diff --git a/24-parser-combination/src/PosInt.hs b/24-parser-combination/src/PosInt.hs new file mode 100644 index 0000000..86725f8 --- /dev/null +++ b/24-parser-combination/src/PosInt.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PosInt where + +import Text.Trifecta +import Test.Hspec + +parseDigit :: Parser Char +parseDigit = oneOf ['0'..'9'] + +base10Integer :: Parser Integer +base10Integer = do + xs <- some $ (\a -> read (a:"")) <$> parseDigit + return $ + fst $ foldr (\a (b,i) -> (a * i + b, i*10)) (0,1) xs + +parseSign :: Parser Char +parseSign = oneOf ['+', '-'] + +base10Integer' :: Parser Integer +base10Integer' = do + c <- option '+' parseSign + let f = if c == '-' then negate else id + f <$> base10Integer + +maybeSuccess :: Result a -> Maybe a +maybeSuccess (Success a) = Just a +maybeSuccess _ = Nothing + +main :: IO () +main = hspec $ do + describe "Parse Digit" $ do + it "can parse a 0" $ do + let m = parseString parseDigit mempty "0" + r = maybeSuccess m + r `shouldBe` Just '0' + it "can parse a 1" $ do + let m = parseString parseDigit mempty "1" + r = maybeSuccess m + r `shouldBe` Just '1' + it "can parse a 2" $ do + let m = parseString parseDigit mempty "2" + r = maybeSuccess m + r `shouldBe` Just '2' + it "can parse a 3" $ do + let m = parseString parseDigit mempty "3" + r = maybeSuccess m + r `shouldBe` Just '3' + it "can parse a 4" $ do + let m = parseString parseDigit mempty "4" + r = maybeSuccess m + r `shouldBe` Just '4' + it "can parse a 5" $ do + let m = parseString parseDigit mempty "5" + r = maybeSuccess m + r `shouldBe` Just '5' + it "can parse a 6" $ do + let m = parseString parseDigit mempty "6" + r = maybeSuccess m + r `shouldBe` Just '6' + it "can parse a 7" $ do + let m = parseString parseDigit mempty "7" + r = maybeSuccess m + r `shouldBe` Just '7' + it "can parse a 8" $ do + let m = parseString parseDigit mempty "8" + r = maybeSuccess m + r `shouldBe` Just '8' + it "can parse a 9" $ do + let m = parseString parseDigit mempty "9" + r = maybeSuccess m + r `shouldBe` Just '9' + it "other values fail" $ do + let m = parseString parseDigit mempty "a" + r = maybeSuccess m + r `shouldBe` Nothing + + describe "Parse Integer" $ do + it "can parse single digit" $ do + let m = parseString base10Integer mempty "3" + r = maybeSuccess m + r `shouldBe` Just 3 + it "can parse multiple digits" $ do + let m = parseString base10Integer mempty "123" + r = maybeSuccess m + r `shouldBe` Just 123 + it "fails when no digit" $ do + let m = parseString base10Integer mempty "x23" + r = maybeSuccess m + r `shouldBe` Nothing + + describe "Parse Sign" $ do + it "Minus" $ do + let m = parseString parseSign mempty "-" + r = maybeSuccess m + r `shouldBe` Just '-' + it "Plus" $ do + let m = parseString parseSign mempty "+" + r = maybeSuccess m + r `shouldBe` Just '+' + it "other" $ do + let m = parseString parseSign mempty "1" + r = maybeSuccess m + r `shouldBe` Nothing + + describe "Parse Positive Integer" $ do + it "positive without +" $ do + let m = parseString base10Integer' mempty "123abc" + r = maybeSuccess m + r `shouldBe` Just 123 + it "positive with -" $ do + let m = parseString base10Integer' mempty "+123abc" + r = maybeSuccess m + r `shouldBe` Just 123 + + describe "Parse negative integer" $ do + it "negative" $ do + let m = parseString base10Integer' mempty "-123abc" + r = maybeSuccess m + r `shouldBe` Just (-123) + \ No newline at end of file diff --git a/24-parser-combination/src/SemVer.hs b/24-parser-combination/src/SemVer.hs new file mode 100644 index 0000000..bde0d31 --- /dev/null +++ b/24-parser-combination/src/SemVer.hs @@ -0,0 +1,229 @@ +{-# LANGUAGE OverloadedStrings #-} + +module SemVer where + +import Data.Char (isDigit) +import Text.Trifecta +import Test.Hspec + +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) + +-- Probably nicer ways of doing this? +instance Ord SemVer where + compare (SemVer major minor patch _ _) + (SemVer major' minor' patch' _ _) = + -- case compare major major' of + -- GT -> GT + -- LT -> LT + -- EQ -> + -- case compare minor minor' of + -- GT -> GT + -- LT -> LT + -- EQ -> + -- case compare patch patch' of + -- GT -> GT + -- LT -> LT + -- EQ -> EQ + mconcat $ + zipWith compare [major, minor, patch] [major', minor', patch'] + +validChars :: [Char] +validChars = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] + +-- According to SemVer identifiers comprise of [0-9a-zA-Z] +-- Looks like the exercises wants us to differentiate between numbers +-- and strings, even though it can be mixed: e.g 1.0.0-beta+exp.sha.5114f85 +-- Therefore we will only treat it as a number if the entire identifier can +-- be identified as a number +parseNumberOrString :: Parser NumberOrString +parseNumberOrString = do + s <- some $ oneOf validChars + return $ if all isDigit s + then NOSI (read s) + else NOSS s + +parserNumberOrStringList :: Parser [NumberOrString] +parserNumberOrStringList = do + x <- parseNumberOrString + xs <- many $ char '.' >> parseNumberOrString + return $ x : xs + +parseRelease :: Parser Release +parseRelease = char '-' >> parserNumberOrStringList + +parseMetadata :: Parser Metadata +parseMetadata = char '+' >> parserNumberOrStringList + +parseSemVer :: Parser SemVer +parseSemVer = do + major <- decimal + _ <- char '.' + minor <- decimal + _ <- char '.' + patch <- decimal + rel <- option [] parseRelease + metadata <- option [] parseMetadata + _ <- eof -- not really necessary, but just makes it nice to test :) + return $ SemVer major minor patch rel metadata + +maybeSuccess :: Result a -> Maybe a +maybeSuccess (Success a) = Just a +maybeSuccess _ = Nothing + +main :: IO () +main = hspec $ do + describe "Number or String parsing" $ do + it "can parse string" $ do + let m = parseString parseNumberOrString mempty "abc" + r = maybeSuccess m + print m + r `shouldBe` Just (NOSS "abc") + it "can parse number" $ do + let m = parseString parseNumberOrString mempty "123" + r = maybeSuccess m + print m + r `shouldBe` Just (NOSI 123) + it "can parse mixed number and string" $ do + let m = parseString parseNumberOrString mempty "123abc" + r = maybeSuccess m + print m + r `shouldBe` Just (NOSS "123abc") + it "fails on non alphanumeric" $ do + let m = parseString parseNumberOrString mempty "+" + r = maybeSuccess m + print m + r `shouldBe` Nothing + + describe "Number or String parsing" $ do + it "can parse one number or string" $ do + let m = parseString parserNumberOrStringList mempty "123abc" + r = maybeSuccess m + print m + r `shouldBe` Just [NOSS "123abc"] + it "can parse more than one number or string" $ do + let m = parseString parserNumberOrStringList mempty "123.abc" + r = maybeSuccess m + print m + r `shouldBe` Just [NOSI 123, NOSS "abc"] + it "fails when no number or string" $ do + let m = parseString parserNumberOrStringList mempty "+" + r = maybeSuccess m + print m + r `shouldBe` Nothing + + describe "Release parsing" $ do + it "can parse release" $ do + let m = parseString parseRelease mempty "-123.abc.123abc" + r = maybeSuccess m + print m + r `shouldBe` Just [NOSI 123, NOSS "abc", NOSS "123abc"] + it "fails when doesn't start with '-'" $ do + let m = parseString parseRelease mempty "123.abc.123abc" + r = maybeSuccess m + print m + r `shouldBe` Nothing + + describe "Metadata parsing" $ do + it "can parse metadata" $ do + let m = parseString parseMetadata mempty "+123.abc.123abc" + r = maybeSuccess m + print m + r `shouldBe` Just [NOSI 123, NOSS "abc", NOSS "123abc"] + it "fails when doesn't start with '+'" $ do + let m = parseString parseRelease mempty "123.abc.123abc" + r = maybeSuccess m + print m + r `shouldBe` Nothing + + describe "SemVer parsing" $ do + it "can parse just version" $ do + let m = parseString parseSemVer mempty "1.2.3" + r = maybeSuccess m + print m + r `shouldBe` Just (SemVer 1 2 3 [] []) + it "fails on invalid version" $ do + let m = parseString parseSemVer mempty "1.2" + r = maybeSuccess m + print m + r `shouldBe` Nothing + it "fails with invalid data after version" $ do + let m = parseString parseSemVer mempty "1.2.3[" + r = maybeSuccess m + print m + r `shouldBe` Nothing + it "can parse with release" $ do + let m = parseString parseSemVer mempty "1.2.3-abc" + r = maybeSuccess m + print m + r `shouldBe` Just (SemVer 1 2 3 [NOSS "abc"] []) + it "fails with more than one release" $ do + let m = parseString parseSemVer mempty "1.2.3-abc-abc" + r = maybeSuccess m + print m + r `shouldBe` Nothing + it "fails with invalid data after release" $ do + let m = parseString parseSemVer mempty "1.2.3-abc]" + r = maybeSuccess m + print m + r `shouldBe` Nothing + it "can parse with metadata" $ do + let m = parseString parseSemVer mempty "1.2.3+abc" + r = maybeSuccess m + print m + r `shouldBe` Just (SemVer 1 2 3 [] [NOSS "abc"]) + it "fails with more than one metadata" $ do + let m = parseString parseSemVer mempty "1.2.3+abc+123" + r = maybeSuccess m + print m + r `shouldBe` Nothing + it "fails with non number or string after release" $ do + let m = parseString parseSemVer mempty "1.2.3+abc[" + r = maybeSuccess m + print m + r `shouldBe` Nothing + it "can parse with release and metadata" $ do + let m = parseString parseSemVer mempty "1.2.3-abc+123" + r = maybeSuccess m + print m + r `shouldBe` Just (SemVer 1 2 3 [NOSS "abc"] [NOSI 123]) + + describe "Comparing SemVer" $ do + it "Bigger Major" $ do + let a = SemVer 2 1 0 [] [] + b = SemVer 1 2 1 [] [] + compare a b `shouldBe` GT + it "Smaller Major" $ do + let a = SemVer 1 2 1 [] [] + b = SemVer 2 1 0 [] [] + compare a b `shouldBe` LT + it "Bigger Minor" $ do + let a = SemVer 1 2 0 [] [] + b = SemVer 1 1 1 [] [] + compare a b `shouldBe` GT + it "Smaller Major" $ do + let a = SemVer 1 1 1 [] [] + b = SemVer 1 2 0 [] [] + compare a b `shouldBe` LT + it "Bigger Patch" $ do + let a = SemVer 1 1 2 [] [] + b = SemVer 1 1 1 [] [] + compare a b `shouldBe` GT + it "Smaller Patch" $ do + let a = SemVer 1 1 1 [] [] + b = SemVer 1 1 2 [] [] + compare a b `shouldBe` LT + it "Equal Patch" $ do + let a = SemVer 1 1 1 [] [] + compare a a `shouldBe` EQ + it "Release and Major don't matter" $ do + let a = SemVer 1 1 1 [NOSI 3] [NOSI 3] + b = SemVer 1 1 1 [NOSI 2, NOSI 1] [NOSI 2, NOSI 1] + compare a b `shouldBe` EQ \ No newline at end of file diff --git a/24-parser-combination/src/TryTry.hs b/24-parser-combination/src/TryTry.hs new file mode 100644 index 0000000..1daf39a --- /dev/null +++ b/24-parser-combination/src/TryTry.hs @@ -0,0 +1,23 @@ +module TryTry where + +import Control.Applicative ((<|>)) +import Text.Trifecta +import Data.Ratio ((%)) + +parseFraction :: Parser Rational +parseFraction = do + numerator <- decimal + char '/' + denominator <- decimal + case denominator of + 0 -> fail "Denominator cannot be zero" + _ -> return (numerator % denominator) + +type DecimalOrFraction = Either Integer Rational + +parseDecimalOrFraction :: Parser DecimalOrFraction +parseDecimalOrFraction = (Right <$> (try parseFraction)) + <|> (Left <$> decimal) + + +