Skip to content
Permalink
Browse files

Merge pull request #916 from input-output-hk/fix-gist-loading

Bugfix for JSON-encoding of KnownCurrencies.
  • Loading branch information...
krisajenkins committed Apr 15, 2019
2 parents 4beea94 + 4db1ad2 commit 2f64af0738b9778e0ea4c57350f0636cac24e12b
@@ -7,12 +7,15 @@ import Control.MonadPlus (empty, (=<<))
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Aeson as Aeson
import Data.Argonaut.Generic.Decode (genericDecodeJson)
import Data.Argonaut.Generic.Encode (genericEncodeJson)
import Data.Argonaut.Generic.Options (Options(..))
import Data.Argonaut.Parser (jsonParser)
import Data.Array (intercalate)
import Data.Array as Array
import Data.Either (Either(Right, Left), note)
import Data.Generic (class Generic, GenericSignature(SigProd), GenericSpine(SProd), fromSpine, isValidSpine, toSignature, toSpine)
import Data.List as List
import Data.List.NonEmpty (NonEmptyList)
import Data.List.NonEmpty as NonEmpty
import Data.Maybe (Maybe(..), fromMaybe)
import Gist (GistId)
@@ -31,6 +34,7 @@ ajaxSettings :: SPSettings_ SPParams_
ajaxSettings = SPSettings_ $ settings
{ toURLPiece = SPSettingsToUrlPiece_ gCustomToURLPiece
, decodeJson = SPSettingsDecodeJson_ (genericDecodeJson $ Options $ options {userDecoding = userDecoding})
, encodeJson = SPSettingsEncodeJson_ (genericEncodeJson $ Options $ options {userEncoding = userEncoding})
}
where
SPSettings_ settings = defaultSettings $ SPParams_ { baseURL: "/api/" }
@@ -73,6 +77,19 @@ decodeTokenIdLists opts (SigProd "Data.List.Types.NonEmptyList" [{sigValues: [l]
_ -> empty
decodeTokenIdLists _ _ _ = Nothing

userEncoding :: Options -> GenericSignature -> GenericSpine -> Maybe Json
userEncoding opts sig spine =
encodeTokenIdLists opts sig spine
<|>
Aeson.userEncoding opts sig spine

encodeTokenIdLists :: Options -> GenericSignature -> GenericSpine -> Maybe Json
encodeTokenIdLists opts sig@(SigProd "Data.List.Types.NonEmptyList" [{sigValues: [l]}]) spine =
case fromSpine spine of
Nothing -> Nothing
Just (xs :: NonEmptyList TokenId) -> Just $ encodeJson $ Array.fromFoldable xs
encodeTokenIdLists _ _ _ = Nothing

-- | Generally we want the default parameter encoding behaviour. But
-- sometimes we need to do something special.
gCustomToURLPiece :: forall a. Generic a => a -> URLPiece
@@ -80,14 +80,13 @@ instance atLedgerMap :: Eq k => At (LedgerMap k a) k a where
matching tuple = fst tuple == key
get (LedgerMap xs) = map snd $ Array.find matching xs
set (LedgerMap xs) Nothing = LedgerMap $ Array.filter (not matching) xs
set (LedgerMap []) (Just new) = LedgerMap [ Tuple key new ]
set (LedgerMap xs) (Just new) =
set (LedgerMap xs) (Just new) = LedgerMap $
case Array.findIndex matching xs of
Nothing -> LedgerMap $ Array.snoc xs (Tuple key new)
_ -> LedgerMap $ map (\(Tuple k v) ->
Tuple k (if k == key
then new
else v)) xs
Nothing -> Array.snoc xs (Tuple key new)
_ -> map (\(Tuple k v) ->
Tuple k (if k == key
then new
else v)) xs

collapse ::
forall m n i j a.
@@ -5,29 +5,37 @@ module AjaxUtilsTests
import Prelude

import AjaxUtils (decodeJson, encodeJson)
import AjaxUtils as AjaxUtils
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Random (RANDOM)
import Data.Argonaut.Core as Argonaut
import Data.Either (Either(..))
import Data.Generic (class Generic, gShow)
import Data.List (List)
import Data.List as List
import Data.List.NonEmpty (NonEmptyList(..))
import Data.List.Types (NonEmptyList)
import Data.NonEmpty ((:|))
import Data.Tuple (Tuple(..))
import Language.Haskell.Interpreter (CompilationError, InterpreterError, InterpreterResult)
import Ledger.Extra (LedgerMap(..))
import Ledger.Value.TH (CurrencySymbol(..), TokenName(..), Value(..))
import Node.FS (FS)
import Playground.API (CompilationResult, EvaluationResult, KnownCurrency, TokenId)
import Playground.API (CompilationResult, EvaluationResult, KnownCurrency(..), TokenId(..))
import Test.QuickCheck (arbitrary, withHelp)
import Test.QuickCheck.Gen (Gen, chooseInt, vectorOf)
import Test.Unit (TestSuite, suite, test)
import Test.Unit.QuickCheck (quickCheck)
import TestUtils (assertDecodesTo, assertEncodesTo, equalGShow)
import Type.Proxy (Proxy(..))

all :: forall eff. TestSuite (exception :: EXCEPTION, fs :: FS, random :: RANDOM | eff)
all =
suite "AjaxUtils" do
jsonHandling
jsonHandlingTests

jsonHandling :: forall eff. TestSuite (exception :: EXCEPTION, fs :: FS, random :: RANDOM | eff)
jsonHandling = do
jsonHandlingTests :: forall eff. TestSuite (exception :: EXCEPTION, fs :: FS, random :: RANDOM | eff)
jsonHandlingTests = do
suite "Json handling" do
test "Decode a List." do
assertDecodesTo
@@ -71,3 +79,62 @@ jsonHandling = do
assertEncodesTo
aValue
"test/value1.json"
suite "Roundtrips" do
testRoundTrip "CurrencySymbol" arbitraryCurrencySymbol
testRoundTrip "TokenId" arbitraryTokenId
testRoundTrip "TokenName" arbitraryTokenName
testRoundTrip "Value" arbitraryValue
testRoundTrip "KnownCurrency" arbitraryKnownCurrency

testRoundTrip ::
forall eff a.
Eq a =>
Generic a =>
String ->
Gen a ->
TestSuite (random :: RANDOM | eff)
testRoundTrip title gen = do
test title do
quickCheck do
value <- gen
let expect = Right value
let actual = AjaxUtils.decodeJson (AjaxUtils.encodeJson value)
pure $ withHelp (expect == actual) $ "Expected: " <> gShow expect <> "Got: " <> gShow actual

arbitraryCurrencySymbol :: Gen CurrencySymbol
arbitraryCurrencySymbol = do
str <- arbitrary
pure $ CurrencySymbol { unCurrencySymbol: str }

arbitraryTokenId :: Gen TokenId
arbitraryTokenId = TokenId <$> arbitrary

arbitraryTokenName :: Gen TokenName
arbitraryTokenName = do
str <- arbitrary
pure $ TokenName { unTokenName: str }

arbitraryLedgerMap :: forall k v. Gen k -> Gen v -> Gen (LedgerMap k v)
arbitraryLedgerMap genK genV = do
n <- chooseInt 0 5
xs <- vectorOf n (Tuple <$> genK <*> genV)
pure $ LedgerMap xs

arbitraryValue :: Gen Value
arbitraryValue = do
ledgerMap <- arbitraryLedgerMap arbitraryCurrencySymbol (arbitraryLedgerMap arbitraryTokenName arbitrary)
pure $ Value { getValue: ledgerMap }

arbitraryKnownCurrency :: Gen KnownCurrency
arbitraryKnownCurrency = do
hash <- arbitrary
friendlyName <- arbitrary
knownTokens <- arbitraryNonEmptyList arbitraryTokenId
pure $ KnownCurrency { hash, friendlyName, knownTokens }

arbitraryNonEmptyList :: forall a. Gen a -> Gen (NonEmptyList a)
arbitraryNonEmptyList genX = do
n <- chooseInt 0 5
x <- genX
xs <- List.fromFoldable <$> vectorOf n genX
pure $ NonEmptyList $ x :| xs
@@ -211,6 +211,10 @@ evalTests =
steps

assert "Gist gets loaded." $ isSuccess (view _createGistResult finalState)
equal'
"Simulations gets loaded."
1
(Cursor.length (view _simulations finalState))
let sourceFile = unsafePartial $ fromJust $ Array.head (unwrap gist)._gistFiles >>= (unwrap >>> _._gistFileContent)
equal' "Editor gets update."
(Just sourceFile)
Oops, something went wrong.

0 comments on commit 2f64af0

Please sign in to comment.
You can’t perform that action at this time.