my horrible 4th challenge code

2020/4-2.hs

@@ -0,0 +1,37 @@
+import Text.Read
+import Data.Char
+
+hgt (a:b:'i':'n':[]) = (readMaybe [a,b] :: Maybe Int) >>= \a -> return $ a >= 59 && a <= 76
+hgt ('1':b:c:'c':'m':[]) = (readMaybe [b,c] :: Maybe Int) >>= \a -> return $ a >= 50 && a <= 93
+hgt _ = Nothing
+
+hcl ('#':xs) = return $ all isHexDigit xs
+hcl _ = Nothing
+
+fields = [("byr", \x -> (readMaybe x :: Maybe Int) >>= \x -> return $ x >= 1920 && x <= 2002)
+         ,("iyr", \x -> (readMaybe x :: Maybe Int) >>= \x -> return $ x >= 2010 && x <= 2020)
+         ,("eyr", \x -> (readMaybe x :: Maybe Int) >>= \x -> return $ x >= 2020 && x <= 2030)
+         ,("hgt", hgt)
+         ,("hcl", hcl)
+         ,("ecl", \x -> return $ x `elem` ["amb", "blu", "brn", "gry", "grn", "hzl", "oth"])
+         ,("pid", \x -> return $ length x == 9 && (readMaybe x :: Maybe Int) /= Nothing)]
+
+main = readFile "4" >>= putStrLn . show . parse 0 []
+  where
+    parse :: Integer -> [(String, String)] -> String -> Integer
+    parse i lst ('\n':xs) = parse (fin i lst) [] xs
+    parse i lst (' ':xs) = parse i lst xs
+    parse i lst [] = fin i lst
+    parse i lst xs = key i lst "" xs
+    key :: Integer -> [(String, String)] -> String -> String -> Integer
+    key i lst k (':':xs) = val i lst k "" xs
+    key i lst k (x:xs) = key i lst (k ++ [x]) xs
+    val :: Integer -> [(String, String)] -> String -> String -> String -> Integer
+    val i lst k v (' ':xs) = parse i ((k, v):lst) xs
+    val i lst k v ('\n':xs) = parse i ((k, v):lst) xs
+    val i lst k v (x:xs) = val i lst k (v ++ [x]) xs
+    fin i lst = if all ((==) (Just True))
+                   $ map (\(x, f) -> lookup x lst >>= f) fields then
+                  i + 1
+                else
+                  i

2020/4.hs

@@ -0,0 +1,16 @@
+fields = ["byr", "iyr", "eyr", "hgt", "hcl", "ecl", "pid"]
+
+main = readFile "4" >>= putStrLn . show . parse 0 []
+  where
+    parse :: Integer -> [String] -> String -> Integer
+    parse i lst ('\n':xs) = parse (if all id $ map (\x -> x `elem` lst) fields then i + 1 else i) [] xs
+    parse i lst (' ':xs) = parse i lst xs
+    parse i lst [] = if all id $ map (\x -> x `elem` lst) fields then i + 1 else i
+    parse i lst xs = str i lst "" xs
+    str :: Integer -> [String] -> String -> String -> Integer
+    str i lst buf (':':xs) = eat i (buf:lst) xs
+    str i lst buf (x:xs) = str i lst (buf ++ [x]) xs
+    eat :: Integer -> [String] -> String -> Integer
+    eat i lst (' ':xs) = parse i lst xs
+    eat i lst ('\n':xs) = parse i lst xs
+    eat i lst (_:xs) = eat i lst xs