ehmry/dhall-haskell
ehmry/dhall-haskell
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix Inject instance for lists (#1261)

Browse Source 
* Fix `Inject` instance for lists

Fixes #1254

This also adds tests for conversions back and forth between Dhall and
Haskell values

* Add `Inject` instances for `Scientific` and `String`

... so that we don't need to comment them out!
This commit is contained in:
Gabriel Gonzalez 2019-08-29 23:15:43 -05:00 committed by mergify[bot]
parent 4445eee871
commit dbcfe7019d
3 changed files with 82 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
dhall/dhall.cabal
View File

@ -598,6 +598,7 @@ Test-Suite tasty
prettyprinter ,
QuickCheck >= 2.10 && < 2.14,
quickcheck-instances >= 0.3.12 && < 0.4 ,
scientific ,
semigroups ,
serialise ,
spoon < 0.4 ,

14
dhall/src/Dhall.hs
View File

@ -1350,6 +1350,10 @@ instance Inject Text where
declared = Text
instance {-# OVERLAPS #-} Inject String where
injectWith options =
contramap Data.Text.pack (injectWith options :: InputType Text)
instance Inject Natural where
injectWith _ = InputType {..}
where
@ -1406,6 +1410,10 @@ instance Inject Double where
declared = Double
instance Inject Scientific where
injectWith options =
contramap Data.Scientific.toRealFloat (injectWith options :: InputType Double)
instance Inject () where
injectWith _ = InputType {..}
where
@ -1426,7 +1434,11 @@ instance Inject a => Inject (Maybe a) where
instance Inject a => Inject (Seq a) where
injectWith options = InputType embedOut declaredOut
where
embedOut xs = ListLit (Just declaredIn) (fmap embedIn xs)
embedOut xs = ListLit listType (fmap embedIn xs)
where
listType
| null xs = Just (App List declaredIn)
| otherwise = Nothing
declaredOut = App List declaredIn

68
dhall/tests/Dhall/Test/Dhall.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
@ -18,8 +19,11 @@ module Dhall.Test.Dhall where
import Control.Exception (SomeException, try)
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Monoid ((<>))
import Data.Sequence (Seq)
import Data.String (fromString)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Vector (Vector)
import Dhall (Inject, Interpret)
import Dhall.Core (Expr(..))
import GHC.Generics (Generic)
@ -28,6 +32,7 @@ import Test.Tasty
import Test.Tasty.HUnit
import qualified Data.Text
import qualified Data.Text.Lazy
import qualified Dhall
import qualified Dhall.Core
import qualified Dhall.Import
@ -54,6 +59,8 @@ tests =
, shouldHaveWorkingGenericAuto
, shouldHandleUnionsCorrectly
, shouldTreatAConstructorStoringUnitAsEmptyAlternative
, shouldConvertDhallToHaskellCorrectly
, shouldConvertHaskellToDhallCorrectly
]
data MyType = MyType { foo :: String , bar :: Natural }
@ -239,3 +246,64 @@ shouldHandleUnionsCorrectly =
resolvedExpression <- Dhall.Import.assertNoImports parsedExpression
Dhall.Core.denote resolvedExpression @=? Dhall.embed Dhall.inject value
shouldConvertDhallToHaskellCorrectly :: TestTree
shouldConvertDhallToHaskellCorrectly =
testGroup
"Marshall Dhall code to Haskell"
[ "True" `correspondsTo` True
, "False" `correspondsTo` False
, "2" `correspondsTo` (2 :: Natural)
, "+2" `correspondsTo` (2 :: Integer)
, "2.0" `correspondsTo` (2.0 :: Double)
, "2.0" `correspondsTo` (2.0 :: Scientific)
, "\"ABC\"" `correspondsTo` ("ABC" :: Data.Text.Text)
, "\"ABC\"" `correspondsTo` ("ABC" :: Data.Text.Lazy.Text)
, "\"ABC\"" `correspondsTo` ("ABC" :: String)
, "Some 2" `correspondsTo` (Just 2 :: Maybe Natural)
, "None Natural" `correspondsTo` (Nothing :: Maybe Natural)
, "[ 2, 3, 5 ]" `correspondsTo` ([ 2, 3, 5 ] :: Seq Natural)
, "[ 2, 3, 5 ]" `correspondsTo` ([ 2, 3, 5 ] :: [Natural])
, "[ 2, 3, 5 ]" `correspondsTo` ([ 2, 3, 5 ] :: Vector Natural)
, "[] : List Natural" `correspondsTo` ([] :: [Natural])
, "{=}" `correspondsTo` ()
, "{ _1 = True, _2 = {=} }" `correspondsTo` (True, ())
]
where
correspondsTo :: (Eq a, Interpret a, Show a) => Text -> a -> TestTree
dhallCode `correspondsTo` expectedHaskellValue =
testCase "Marshall Dhall code to Haskell" $ do
actualHaskellValue <- Dhall.input Dhall.auto dhallCode
expectedHaskellValue @=? actualHaskellValue
shouldConvertHaskellToDhallCorrectly :: TestTree
shouldConvertHaskellToDhallCorrectly =
testGroup
"Marshall Haskell to Dhall code"
[ "True" `correspondsTo` True
, "False" `correspondsTo` False
, "2" `correspondsTo` (2 :: Natural)
, "+2" `correspondsTo` (2 :: Integer)
, "2.0" `correspondsTo` (2.0 :: Double)
, "2.0" `correspondsTo` (2.0 :: Scientific)
, "\"ABC\"" `correspondsTo` ("ABC" :: Data.Text.Text)
, "\"ABC\"" `correspondsTo` ("ABC" :: Data.Text.Lazy.Text)
, "\"ABC\"" `correspondsTo` ("ABC" :: String)
, "Some 2" `correspondsTo` (Just 2 :: Maybe Natural)
, "None Natural" `correspondsTo` (Nothing :: Maybe Natural)
, "[ 2, 3, 5 ]" `correspondsTo` ([ 2, 3, 5 ] :: Seq Natural)
, "[ 2, 3, 5 ]" `correspondsTo` ([ 2, 3, 5 ] :: [Natural])
, "[ 2, 3, 5 ]" `correspondsTo` ([ 2, 3, 5 ] :: Vector Natural)
, "[] : List Natural" `correspondsTo` ([] :: [Natural])
, "{=}" `correspondsTo` ()
, "{ _1 = True, _2 = {=} }" `correspondsTo` (True, ())
]
where
correspondsTo :: Inject a => Text -> a -> TestTree
expectedDhallCode `correspondsTo` haskellValue =
testCase "Marshall Haskell to Dhall code" $ do
let actualDhallCode =
Dhall.Core.pretty (Dhall.embed Dhall.inject haskellValue)
expectedDhallCode @=? actualDhallCode