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

Teach genericAuto about new-style union construction. (#927)

Browse Source 
The underlying bug is very similar to #915, and in fact this builds on
the fix for that in #918.

Closes #926.
This commit is contained in:
quasicomputational 2019-05-02 17:26:53 +01:00 committed by Gabriel Gonzalez
parent 8fa233336d
commit c9ea8b99ca
2 changed files with 51 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
dhall/src/Dhall.hs
View File

@ -4,6 +4,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
@ -941,6 +942,16 @@ possible e = case e of
RecordLit m | null m -> Nothing
_ -> Just e
extractUnionConstructor
:: Expr s a
-> Maybe (Text, Expr s a, Dhall.Map.Map Text (Maybe (Expr s a)))
extractUnionConstructor (UnionLit fld e rest) =
return (fld, e, rest)
extractUnionConstructor (App (Field (Union kts) fld) e) =
return (fld, e, Dhall.Map.delete fld kts)
extractUnionConstructor _ =
empty
instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret f2) => GenericInterpret (M1 C c1 f1 :+: M1 C c2 f2) where
genericAutoWith options@(InterpretOptions {..}) = pure (Type {..})
where
@ -953,11 +964,12 @@ instance (Constructor c1, Constructor c2, GenericInterpret f1, GenericInterpret
nameL = constructorModifier (Data.Text.pack (conName nL))
nameR = constructorModifier (Data.Text.pack (conName nR))
extract (UnionLit name e _)
| name == nameL = fmap (L1 . M1) (extractL e)
| name == nameR = fmap (R1 . M1) (extractR e)
| otherwise = Nothing
extract _ = Nothing
extract e0 = do
(name, e1, _) <- extractUnionConstructor e0
if
| name == nameL -> fmap (L1 . M1) (extractL e1)
| name == nameR -> fmap (R1 . M1) (extractR e1)
| otherwise -> Nothing
expected =
Union
@ -976,10 +988,11 @@ instance (Constructor c, GenericInterpret (f :+: g), GenericInterpret h) => Gene
name = constructorModifier (Data.Text.pack (conName n))
extract u@(UnionLit name' e _)
| name == name' = fmap (R1 . M1) (extractR e)
| otherwise = fmap L1 (extractL u)
extract _ = Nothing
extract u = do
(name', e, _) <- extractUnionConstructor u
if
| name == name' -> fmap (R1 . M1) (extractR e)
| otherwise -> fmap L1 (extractL u)
expected =
Union (Dhall.Map.insert name (possible expectedR) ktsL)
@ -997,10 +1010,11 @@ instance (Constructor c, GenericInterpret f, GenericInterpret (g :+: h)) => Gene
name = constructorModifier (Data.Text.pack (conName n))
extract u@(UnionLit name' e _)
| name == name' = fmap (L1 . M1) (extractL e)
| otherwise = fmap R1 (extractR u)
extract _ = Nothing
extract u = do
(name', e, _) <- extractUnionConstructor u
if
| name == name' -> fmap (L1 . M1) (extractL e)
| otherwise -> fmap R1 (extractR u)
expected =
Union (Dhall.Map.insert name (possible expectedL) ktsR)
@ -1542,14 +1556,7 @@ union (UnionType (Data.Functor.Compose.Compose mp)) = Type
where
expect = (possible . Dhall.expected) <$> mp
extractF e0 = do
(fld, e1, rest) <- do
case e0 of
UnionLit fld e1 rest ->
return (fld, e1, rest)
App (Field (Union kts) fld) e1 ->
return (fld, e1, Dhall.Map.delete fld kts)
_ ->
empty
(fld, e1, rest) <- extractUnionConstructor e0
t <- Dhall.Map.lookup fld mp
guard $ Dhall.Core.Union rest `Dhall.Core.judgmentallyEqual`

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

@ -1,9 +1,11 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Dhall.Test.Dhall where
import Control.Exception (SomeException, try)
import GHC.Generics (Generic)
import Numeric.Natural (Natural)
import Test.Tasty
import Test.Tasty.HUnit
@ -17,6 +19,7 @@ tests =
testGroup "Input"
[ shouldShowDetailedTypeError
, shouldHandleBothUnionLiterals
, shouldHaveWorkingGenericAuto
]
data MyType = MyType { foo :: String , bar :: Natural }
@ -67,3 +70,23 @@ shouldHandleBothUnionLiterals = testCase "Marshal union literals" $ do
_ <- Dhall.input license "< AllRightsReserved : {} >.AllRightsReserved {=}"
_ <- Dhall.input license "< AllRightsReserved = {=} >"
return ()
data CompilerFlavor3 =
GHC3 | GHCJS3 | Helium3
deriving (Generic, Show, Eq)
data CompilerFlavor2 =
GHC2 | GHCJS2
deriving (Generic, Show, Eq)
-- https://github.com/dhall-lang/dhall-haskell/issues/926
shouldHaveWorkingGenericAuto :: TestTree
shouldHaveWorkingGenericAuto = testGroup "genericAuto"
[ testCase "works for a three-constructor enum" $ do
compiler <- Dhall.input Dhall.genericAuto "< GHC3 : {} | GHCJS3 : {} | Helium3 : {} >.GHC3 {=}"
assertEqual "genericAuto didn't give us what we wanted" GHC3 compiler
, testCase "works for a two-constructor enum" $ do
compiler <- Dhall.input Dhall.genericAuto "< GHC2 : {} | GHCJS2 : {} >.GHC2 {=}"
assertEqual "genericAuto didn't give us what we wanted" GHC2 compiler
]