mirror of
https://github.com/github/semantic.git
synced 2024-12-21 05:41:54 +03:00
61 lines
1.9 KiB
Haskell
61 lines
1.9 KiB
Haskell
|
{-# LANGUAGE TypeOperators, TypeFamilies #-}
|
||
|
|
|
||
|
|
module Rewriting.JSON.Spec (spec) where
|
||
|
|
|
||
|
|
import Prelude hiding (id, (.))
|
||
|
|
|
||
|
|
import SpecHelpers
|
||
|
|
|
||
|
|
import qualified Data.ByteString as B
|
||
|
|
import Data.Either
|
||
|
|
import Data.Text (Text)
|
||
|
|
|
||
|
|
import Control.Category
|
||
|
|
import Control.Rewriting as Rewriting
|
||
|
|
import Data.History as History
|
||
|
|
import qualified Data.Source as Source
|
||
|
|
import Data.Sum
|
||
|
|
import qualified Data.Syntax.Literal as Literal
|
||
|
|
import Language.JSON.PrettyPrint
|
||
|
|
import Reprinting.Pipeline
|
||
|
|
|
||
|
|
-- Adds a "hi": "bye" key-value pair to any empty Hash.
|
||
|
|
onTrees :: ( Literal.TextElement :< syn
|
||
|
|
, Literal.Hash :< syn
|
||
|
|
, Literal.KeyValue :< syn
|
||
|
|
, Apply Functor syn
|
||
|
|
, term ~ Term (Sum syn) History
|
||
|
|
) => Rule term
|
||
|
|
onTrees = do
|
||
|
|
Literal.Hash els <- Rewriting.target >>= guardTerm
|
||
|
|
guard (null els)
|
||
|
|
k <- create $ Literal.TextElement "\"hi\""
|
||
|
|
v <- create $ Literal.TextElement "\"bye\""
|
||
|
|
pair <- create $ (Literal.KeyValue k v)
|
||
|
|
create (Literal.Hash (pair : els))
|
||
|
|
|
||
|
|
-- Matches only "hi" string literals.
|
||
|
|
isHi :: ( Literal.TextElement :< fs
|
||
|
|
) => Rewrite (Term (Sum fs) History) Text
|
||
|
|
isHi = enter Literal.textElementContent
|
||
|
|
>>> ensure (== "\"hi\"")
|
||
|
|
|
||
|
|
spec :: Spec
|
||
|
|
spec = describe "rewriting" $ do
|
||
|
|
let path = "test/fixtures/json/rewriting/add_keys.json"
|
||
|
|
|
||
|
|
bytes <- runIO $ Source.fromUTF8 <$> B.readFile path
|
||
|
|
|
||
|
|
refactored <- runIO $ do
|
||
|
|
json <- parseFile jsonParser path
|
||
|
|
let result = rewrite @Maybe (History.mark Unmodified json) (topDownAny onTrees)
|
||
|
|
maybe (fail "rewrite failed") pure result
|
||
|
|
|
||
|
|
it "should add keys to JSON values" $ do
|
||
|
|
length (recursively @[] isHi refactored) `shouldBe` 1
|
||
|
|
|
||
|
|
it "should round-trip correctly" $ do
|
||
|
|
let res = runReprinter bytes defaultJSONPipeline refactored
|
||
|
|
expected <- Source.fromUTF8 <$> B.readFile "test/fixtures/json/rewriting/add_keys_expected.json"
|
||
|
|
res `shouldBe` Right expected
|