-
Notifications
You must be signed in to change notification settings - Fork 0
/
Main.hs
119 lines (104 loc) · 3.81 KB
/
Main.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Applicative
import Control.Category.Structures
import Control.Lens
import Control.Lens.SemiIso
import Control.SIArrow
import qualified Data.Attoparsec.Text.Lazy as AP
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Scientific (Scientific)
import qualified Data.Syntax as S
import qualified Data.Syntax.Attoparsec.Text.Lazy as S
import Data.Syntax.Char (SyntaxText)
import qualified Data.Syntax.Char as S
import qualified Data.Syntax.Combinator as S
import Data.Syntax.Indent (Indent)
import qualified Data.Syntax.Indent as S
import qualified Data.Syntax.Printer.Text as S
import Data.Text (Text)
import qualified Data.Text.Lazy.Builder as T
import qualified Data.Text.Lazy.IO as T
-- | A JSON value.
data Value = Object (Map Text Value)
| Array [Value]
| String Text
| Number Scientific
| Bool Bool
| Null
deriving (Show)
$(makePrisms ''Value)
-- Indent is basically a Reader transformer.
-- S.breakLine inserts a new line and correct indentation,
-- but does not require any formatting when parsing (it just
-- skips all white space).
-- S.indented increases the indentation level.
-- | Char encoded as 4 hex digits.
hexCode :: SyntaxText syn => Indent syn () Char
hexCode = from enum . bifoldl1_ (iso u f) /$/ sireplicate 4 S.digitHex
where
f (x, y) = 16 * x + y
u 0 = Nothing
u n = Just (n `quotRem` 16)
string :: SyntaxText syn => Indent syn () Text
string = S.packed /$/ S.char '"' */ simany character /* S.char '"'
where
character = S.satisfy (\x -> x /= '"' && x /= '\\')
/+/ S.char '\\' */ escapedChar
escapedChar = S.char 'u' */ hexCode
/+/ S.choice
[ exact v /$/ S.char e
| (v, e) <- [ ('"', '"'), ('\\', '\\'), ('/', '/'), ('\b', 'b')
, ('\f', 'f'), ('\n', 'n') , ('\r', 'r'), ('\t', 't')]
]
mapFromList :: Ord i => Iso' (Map i v) [(i, v)]
mapFromList = iso Map.toList Map.fromList
object :: SyntaxText syn => Indent syn () Value
object = _Object . mapFromList
/$~ S.char '{'
/*/ S.indented (
S.breakLine /*/
S.sepBy field (S.spaces_ /* S.char ',' /* S.breakLine)
)
/*/ S.breakLine /*/ S.char '}'
where field = string /* S.spaces_ /* S.char ':' /* S.spaces /*/ value
array :: SyntaxText syn => Indent syn () Value
array = _Array
/$~ S.char '['
/*/ S.indented (
S.breakLine /*/
S.sepBy value (S.spaces_ /* S.char ',' /* S.breakLine)
)
/*/ S.breakLine /*/ S.char ']'
value :: SyntaxText syn => Indent syn () Value
value = _String /$/ string
/+/ _Number /$/ S.scientific
/+/ object
/+/ array
/+/ _Bool . exact True /$/ S.string "true"
/+/ _Bool . exact False /$/ S.string "false"
/+/ _Null /$/ S.string "null"
/?/ "Invalid JSON."
main :: IO ()
main = do
-- Load the standard input.
t <- T.getContents
-- Indent with 2 spaces.
let tab :: SyntaxText syn => syn () ()
tab = sireplicate_ 2 (S.char ' ')
parser = S.getParser_ $ S.runIndent value tab
printer = S.runPrinter_ $ S.runIndent value tab
-- Try to parse it.
case AP.parse (AP.skipSpace *> parser <* AP.skipSpace <* AP.endOfInput) t of
AP.Fail _ _ err -> putStrLn err
AP.Done _ val -> do
-- Try to pretty print it.
-- (Printing cannot really fail in this example)
case printer val of
Left err -> putStrLn err
Right bld -> T.putStrLn (T.toLazyText bld)
return ()