mirror of
https://github.com/pavelchristof/syntax-example-json.git
synced 2024-10-03 18:17:12 +03:00
120 lines
3.8 KiB
Haskell
120 lines
3.8 KiB
Haskell
{-# 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 ()
|