├── .github └── workflows │ └── ci.yml ├── .stylish-haskell.yaml ├── LICENSE ├── Main.hs └── README.md /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | on: [push, pull_request] 3 | 4 | jobs: 5 | build-ghc: 6 | runs-on: ubuntu-18.04 7 | steps: 8 | - uses: actions/checkout@master 9 | - uses: actions/setup-haskell@v1 10 | with: 11 | ghc-version: '8.6.5' # Exact version of ghc to use 12 | cabal-version: '3.0' 13 | - run: wget https://github.com/ndmitchell/hlint/releases/download/v2.2.4/hlint-2.2.4-x86_64-linux.tar.gz 14 | - run: tar fvx hlint-2.2.4-x86_64-linux.tar.gz 15 | - run: wget https://github.com/jaspervdj/stylish-haskell/releases/download/v0.9.4.4/stylish-haskell-v0.9.4.4-linux-x86_64.tar.gz 16 | - run: tar fvx stylish-haskell-v0.9.4.4-linux-x86_64.tar.gz 17 | - run: runghc -Wall -Werror Main.hs 18 | - run: ./hlint-2.2.4/hlint Main.hs 19 | - run: diff -u Main.hs <(./stylish-haskell-v0.9.4.4-linux-x86_64/stylish-haskell Main.hs) 20 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: global 43 | 44 | # The following options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Right-pad the module names to align imports in a group: 68 | # 69 | # - true: a little more readable 70 | # 71 | # > import qualified Data.List as List (concat, foldl, foldr, 72 | # > init, last, length) 73 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 74 | # > init, last, length) 75 | # 76 | # - false: diff-safe 77 | # 78 | # > import qualified Data.List as List (concat, foldl, foldr, init, 79 | # > last, length) 80 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 81 | # > init, last, length) 82 | # 83 | # Default: true 84 | pad_module_names: true 85 | 86 | # Long list align style takes effect when import is too long. This is 87 | # determined by 'columns' setting. 88 | # 89 | # - inline: This option will put as much specs on same line as possible. 90 | # 91 | # - new_line: Import list will start on new line. 92 | # 93 | # - new_line_multiline: Import list will start on new line when it's 94 | # short enough to fit to single line. Otherwise it'll be multiline. 95 | # 96 | # - multiline: One line per import list entry. 97 | # Type with constructor list acts like single import. 98 | # 99 | # > import qualified Data.Map as M 100 | # > ( empty 101 | # > , singleton 102 | # > , ... 103 | # > , delete 104 | # > ) 105 | # 106 | # Default: inline 107 | long_list_align: inline 108 | 109 | # Align empty list (importing instances) 110 | # 111 | # Empty list align has following options 112 | # 113 | # - inherit: inherit list_align setting 114 | # 115 | # - right_after: () is right after the module name: 116 | # 117 | # > import Vector.Instances () 118 | # 119 | # Default: inherit 120 | empty_list_align: inherit 121 | 122 | # List padding determines indentation of import list on lines after import. 123 | # This option affects 'long_list_align'. 124 | # 125 | # - : constant value 126 | # 127 | # - module_name: align under start of module name. 128 | # Useful for 'file' and 'group' align settings. 129 | list_padding: 4 130 | 131 | # Separate lists option affects formatting of import list for type 132 | # or class. The only difference is single space between type and list 133 | # of constructors, selectors and class functions. 134 | # 135 | # - true: There is single space between Foldable type and list of it's 136 | # functions. 137 | # 138 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 139 | # 140 | # - false: There is no space between Foldable type and list of it's 141 | # functions. 142 | # 143 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 144 | # 145 | # Default: true 146 | separate_lists: true 147 | 148 | # Space surround option affects formatting of import lists on a single 149 | # line. The only difference is single space after the initial 150 | # parenthesis and a single space before the terminal parenthesis. 151 | # 152 | # - true: There is single space associated with the enclosing 153 | # parenthesis. 154 | # 155 | # > import Data.Foo ( foo ) 156 | # 157 | # - false: There is no space associated with the enclosing parenthesis 158 | # 159 | # > import Data.Foo (foo) 160 | # 161 | # Default: false 162 | space_surround: false 163 | 164 | # Language pragmas 165 | - language_pragmas: 166 | # We can generate different styles of language pragma lists. 167 | # 168 | # - vertical: Vertical-spaced language pragmas, one per line. 169 | # 170 | # - compact: A more compact style. 171 | # 172 | # - compact_line: Similar to compact, but wrap each line with 173 | # `{-#LANGUAGE #-}'. 174 | # 175 | # Default: vertical. 176 | style: vertical 177 | 178 | # Align affects alignment of closing pragma brackets. 179 | # 180 | # - true: Brackets are aligned in same column. 181 | # 182 | # - false: Brackets are not aligned together. There is only one space 183 | # between actual import and closing bracket. 184 | # 185 | # Default: true 186 | align: true 187 | 188 | # stylish-haskell can detect redundancy of some language pragmas. If this 189 | # is set to true, it will remove those redundant pragmas. Default: true. 190 | remove_redundant: true 191 | 192 | # Replace tabs by spaces. This is disabled by default. 193 | # - tabs: 194 | # # Number of spaces to use for each tab. Default: 8, as specified by the 195 | # # Haskell report. 196 | # spaces: 8 197 | 198 | # Remove trailing whitespace 199 | - trailing_whitespace: {} 200 | 201 | # Squash multiple spaces between the left and right hand sides of some 202 | # elements into single spaces. Basically, this undoes the effect of 203 | # simple_align but is a bit less conservative. 204 | # - squash: {} 205 | 206 | # A common setting is the number of columns (parts of) code will be wrapped 207 | # to. Different steps take this into account. Default: 80. 208 | columns: 80 209 | 210 | # By default, line endings are converted according to the OS. You can override 211 | # preferred format here. 212 | # 213 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 214 | # 215 | # - lf: Convert to LF ("\n"). 216 | # 217 | # - crlf: Convert to CRLF ("\r\n"). 218 | # 219 | # Default: native. 220 | newline: native 221 | 222 | # Sometimes, language extensions are specified in a cabal file or from the 223 | # command line instead of using language pragmas in the file. stylish-haskell 224 | # needs to be aware of these, so it can parse the file correctly. 225 | # 226 | # No language extensions are enabled by default. 227 | # language_extensions: 228 | # - TemplateHaskell 229 | # - QuasiQuotes 230 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 Alexey Kutepov 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be 12 | included in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 | NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 18 | LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION 19 | OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION 20 | WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE ViewPatterns #-} 3 | 4 | module Main where 5 | 6 | import Control.Applicative 7 | import Data.Char 8 | import Numeric 9 | import System.Exit 10 | 11 | data Input = Input 12 | { inputLoc :: Int 13 | , inputStr :: String 14 | } deriving (Show, Eq) 15 | 16 | -- | Pull the first character of the input if there is one still input 17 | inputUncons :: Input -- input to check 18 | -> Maybe (Char, Input) 19 | inputUncons (Input _ []) = Nothing 20 | inputUncons (Input loc (x:xs)) = Just (x, Input (loc + 1) xs) 21 | 22 | data JsonValue 23 | = JsonNull 24 | | JsonBool Bool 25 | | JsonNumber Double 26 | | JsonString String 27 | | JsonArray [JsonValue] 28 | | JsonObject [(String, JsonValue)] 29 | deriving (Show, Eq) 30 | 31 | data ParserError = ParserError Int String deriving (Show) 32 | 33 | newtype Parser a = Parser 34 | { runParser :: Input -> Either ParserError (Input, a) 35 | } 36 | 37 | instance Functor Parser where 38 | fmap f (Parser p) = 39 | Parser $ \input -> do 40 | (input', x) <- p input 41 | return (input', f x) 42 | 43 | instance Applicative Parser where 44 | pure x = Parser $ \input -> Right (input, x) 45 | (Parser p1) <*> (Parser p2) = 46 | Parser $ \input -> do 47 | (input', f) <- p1 input 48 | (input'', a) <- p2 input' 49 | return (input'', f a) 50 | 51 | instance Alternative (Either ParserError) where 52 | empty = Left $ ParserError 0 "empty" 53 | Left _ <|> e2 = e2 54 | e1 <|> _ = e1 55 | 56 | instance Alternative Parser where 57 | empty = Parser $ const empty 58 | (Parser p1) <|> (Parser p2) = 59 | Parser $ \input -> p1 input <|> p2 input 60 | 61 | -- | Parser for null json 62 | jsonNull :: Parser JsonValue 63 | jsonNull = JsonNull <$ stringP "null" 64 | 65 | -- | Create a parser for a single specific character 66 | charP :: Char -- The single character to find in the input 67 | -> Parser Char 68 | charP x = Parser f 69 | where 70 | f input@(inputUncons -> Just (y, ys)) 71 | | y == x = Right (ys, x) 72 | | otherwise = 73 | Left $ 74 | ParserError 75 | (inputLoc input) 76 | ("Expected '" ++ [x] ++ "', but found '" ++ [y] ++ "'") 77 | f input = 78 | Left $ 79 | ParserError 80 | (inputLoc input) 81 | ("Expected '" ++ [x] ++ "', but reached end of string") 82 | 83 | -- | Create a parser for a specific string 84 | stringP :: String -- String to find in the input 85 | -> Parser String 86 | stringP str = 87 | Parser $ \input -> 88 | case runParser (traverse charP str) input of 89 | Left _ -> 90 | Left $ 91 | ParserError 92 | (inputLoc input) 93 | ("Expected \"" ++ str ++ "\", but found \"" ++ inputStr input ++ "\"") 94 | result -> result 95 | 96 | -- | Create a parser for boolean values 97 | jsonBool :: Parser JsonValue 98 | jsonBool = jsonTrue <|> jsonFalse 99 | where 100 | jsonTrue = JsonBool True <$ stringP "true" 101 | jsonFalse = JsonBool False <$ stringP "false" 102 | 103 | -- | Parser of strings where all characters satifsfy a predicate 104 | spanP :: String -- description 105 | -> (Char -> Bool) -- predicate 106 | -> Parser String 107 | spanP desc = many . parseIf desc 108 | 109 | -- | Parser of a character that satisfies a predicate 110 | parseIf :: String -- Description of the predicate 111 | -> (Char -> Bool) -- predicate 112 | -> Parser Char 113 | parseIf desc f = 114 | Parser $ \input -> 115 | case input of 116 | (inputUncons -> Just (y, ys)) 117 | | f y -> Right (ys, y) 118 | | otherwise -> 119 | Left $ 120 | ParserError 121 | (inputLoc input) 122 | ("Expected " ++ desc ++ ", but found '" ++ [y] ++ "'") 123 | _ -> 124 | Left $ 125 | ParserError 126 | (inputLoc input) 127 | ("Expected " ++ desc ++ ", but reached end of string") 128 | 129 | {- 130 | See page 12 of 131 | http://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf 132 | -} 133 | -- | Parser for doubles 134 | doubleLiteral :: Parser Double 135 | doubleLiteral = 136 | doubleFromParts 137 | <$> (minus <|> pure 1) 138 | <*> (read <$> digits) 139 | <*> ((read <$> (('0':) <$> ((:) <$> charP '.' <*> digits))) <|> pure 0) 140 | <*> ((e *> ((*) <$> (plus <|> minus <|> pure 1) <*> (read <$> digits))) <|> pure 0) 141 | where 142 | digits = some $ parseIf "digit" isDigit 143 | minus = (-1) <$ charP '-' 144 | plus = 1 <$ charP '+' 145 | e = charP 'e' <|> charP 'E' 146 | 147 | -- | Build a Double from its parts (sign, integral part, decimal part, exponent) 148 | doubleFromParts :: Integer -- sign 149 | -> Integer -- integral part 150 | -> Double -- decimal part 151 | -> Integer -- exponent 152 | -> Double 153 | doubleFromParts sign int dec expo = 154 | fromIntegral sign * (fromIntegral int + dec) * (10 ^^ expo) 155 | 156 | -- | Parser for json number values 157 | jsonNumber :: Parser JsonValue 158 | jsonNumber = JsonNumber <$> doubleLiteral 159 | 160 | -- | Parser for characters as unicode in input 161 | escapeUnicode :: Parser Char 162 | escapeUnicode = chr . fst . head . readHex <$> sequenceA (replicate 4 (parseIf "hex digit" isHexDigit)) 163 | 164 | -- | Parser for characters that are scaped in the input 165 | escapeChar :: Parser Char 166 | escapeChar = ('"' <$ stringP "\\\"") <|> 167 | ('\\' <$ stringP "\\\\") <|> 168 | ('/' <$ stringP "\\/") <|> 169 | ('\b' <$ stringP "\\b") <|> 170 | ('\f' <$ stringP "\\f") <|> 171 | ('\n' <$ stringP "\\n") <|> 172 | ('\r' <$ stringP "\\r") <|> 173 | ('\t' <$ stringP "\\t") <|> 174 | (stringP "\\u" *> escapeUnicode) 175 | 176 | -- | Parser of a character that is not " or \\ 177 | normalChar :: Parser Char 178 | normalChar = parseIf "non-special character" ((&&) <$> (/= '"') <*> (/= '\\')) 179 | 180 | -- | Parser of a string that is between double quotes (not considering any double quots that are scaped) 181 | stringLiteral :: Parser String 182 | stringLiteral = charP '"' *> many (normalChar <|> escapeChar) <* charP '"' 183 | 184 | -- | Parser of literal json string values 185 | jsonString :: Parser JsonValue 186 | jsonString = JsonString <$> stringLiteral 187 | 188 | -- | Parser for white spaces 189 | ws :: Parser String 190 | ws = spanP "whitespace character" isSpace 191 | 192 | -- | Creates a parser for a string of type "element1 sep1 element2 sep2 element3" 193 | -- from a parser for separators (sep1, sep2) and and a parser form elements (element1, element2, element3). 194 | sepBy :: Parser a -- Parser for the separators 195 | -> Parser b -- Parser for elements 196 | -> Parser [b] 197 | sepBy sep element = (:) <$> element <*> many (sep *> element) <|> pure [] 198 | 199 | -- | Parser for json arrays 200 | jsonArray :: Parser JsonValue 201 | jsonArray = JsonArray <$> (charP '[' *> ws *> elements <* ws <* charP ']') 202 | where 203 | elements = sepBy (ws *> charP ',' <* ws) jsonValue 204 | 205 | -- | Parser for json objects 206 | jsonObject :: Parser JsonValue 207 | jsonObject = 208 | JsonObject <$> 209 | (charP '{' *> ws *> sepBy (ws *> charP ',' <* ws) pair <* ws <* charP '}') 210 | where 211 | pair = liftA2 (,) (stringLiteral <* ws <* charP ':' <* ws) jsonValue 212 | 213 | -- | Parser for any json 214 | jsonValue :: Parser JsonValue 215 | jsonValue = 216 | jsonNull <|> jsonBool <|> jsonNumber <|> jsonString <|> jsonArray <|> 217 | jsonObject 218 | 219 | -- | Apply parser to content of file 220 | parseFile :: FilePath -- File path to parse 221 | -> Parser a -- Parser to use 222 | -> IO (Either ParserError a) 223 | parseFile fileName parser = do 224 | input <- readFile fileName 225 | case runParser parser $ Input 0 input of 226 | Left e -> return $ Left e 227 | Right (_, x) -> return $ Right x 228 | 229 | -- >>> main 230 | -- [INFO] JSON: 231 | -- { 232 | -- "hello": [false, true, null, 42, "foo\n\u1234\"", [1, -2, 3.1415, 4e-6, 5E6, 0.123e+1]], 233 | -- "world": null 234 | -- } 235 | -- 236 | -- [INFO] Parsed as: JsonObject [("hello",JsonArray [JsonBool False,JsonBool True,JsonNull,JsonNumber 42.0,JsonString "foo\n\4660\"",JsonArray [JsonNumber 1.0,JsonNumber (-2.0),JsonNumber 3.1415,JsonNumber 4.0e-6,JsonNumber 5000000.0,JsonNumber 1.23]]),("world",JsonNull)] 237 | -- [INFO] Remaining input (codes): [10] 238 | -- [SUCCESS] Parser produced expected result. 239 | -- 240 | 241 | main :: IO () 242 | main = do 243 | putStrLn "[INFO] JSON:" 244 | putStrLn testJsonText 245 | case runParser jsonValue $ Input 0 testJsonText of 246 | Right (input, actualJsonAst) -> do 247 | putStrLn ("[INFO] Parsed as: " ++ show actualJsonAst) 248 | putStrLn 249 | ("[INFO] Remaining input (codes): " ++ show (map ord $ inputStr input)) 250 | if actualJsonAst == expectedJsonAst 251 | then putStrLn "[SUCCESS] Parser produced expected result." 252 | else do 253 | putStrLn 254 | ("[ERROR] Parser produced unexpected result. Expected result was: " ++ 255 | show expectedJsonAst) 256 | exitFailure 257 | Left (ParserError loc msg) -> do 258 | putStrLn $ 259 | "[ERROR] Parser failed at character " ++ show loc ++ ": " ++ msg 260 | exitFailure 261 | where 262 | testJsonText = 263 | unlines 264 | [ "{" 265 | , " \"hello\": [false, true, null, 42, \"foo\\n\\u1234\\\"\", [1, -2, 3.1415, 4e-6, 5E6, 0.123e+1]]," 266 | , " \"world\": null" 267 | , "}" 268 | ] 269 | expectedJsonAst = 270 | JsonObject 271 | [ ( "hello" 272 | , JsonArray 273 | [ JsonBool False 274 | , JsonBool True 275 | , JsonNull 276 | , JsonNumber 42 277 | , JsonString "foo\n\4660\"" 278 | , JsonArray 279 | [ JsonNumber 1.0 280 | , JsonNumber (-2.0) 281 | , JsonNumber 3.1415 282 | , JsonNumber 4e-6 283 | , JsonNumber 5000000 284 | , JsonNumber 1.23 285 | ] 286 | ]) 287 | , ("world", JsonNull) 288 | ] 289 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | [![Build Status](https://github.com/tsoding/haskell-json/workflows/CI/badge.svg)](https://github.com/tsoding/haskell-json/actions) 2 | 3 | # haskell-json 4 | 5 | Source Code for JSON Parser Video 6 | 7 | **WARNING! The latest code in this repo may differ from what has been 8 | shown in the video above due to additional contributions from the 9 | viewers! The original code from the video can be found in commit 10 | [bafd97d96b792edd3e170525a7944b9f01de7e34](https://github.com/tsoding/haskell-json/commit/bafd97d96b792edd3e170525a7944b9f01de7e34).** 11 | 12 | ## Testing 13 | 14 | ```console 15 | $ runghc -Wall -Werror Main.hs 16 | ``` 17 | 18 | ## Contribution Notes 19 | 20 | - Pull Requests that do not add any new functionality to the parser or fix bugs will be rejected without any further discussion. Examples are refactoring, renaming, reformating, restyling, etc. Sorry for any inconveniences. 21 | --------------------------------------------------------------------------------