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

Simplify recursive `Interpret` instance (#1298) 

* Simplify recursive `Interpret` instance

Related to https://github.com/dhall-lang/dhall-haskell/issues/1297

The motivation behind this change is to:

* Remove the dependency on `free` and `distributive`
* Simplify the API and the implementation

* Fix `stack-lts-6` build

* Remove now-unused test files

... as caught by @sjakobi
This commit is contained in:
Gabriel Gonzalez 2019-09-10 20:24:10 -07:00 committed by mergify[bot]
parent 70948b3cba
commit 4458cf04a2
8 changed files with 173 additions and 201 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
dhall/dhall.cabal
View File

@ -450,6 +450,7 @@ Library
containers >= 0.5.0.0 && < 0.7 ,
contravariant < 1.6 ,
cryptonite >= 0.23 && < 1.0 ,
data-fix < 0.3 ,
deepseq < 1.5 ,
Diff >= 0.2 && < 0.4 ,
directory >= 1.2.2.0 && < 1.4 ,
@ -457,7 +458,6 @@ Library
either >= 5 && < 5.1,
exceptions >= 0.8.3 && < 0.11,
filepath >= 1.4 && < 1.5 ,
free >= 4.0 && < 6.0 ,
haskeline >= 0.7.2.1 && < 0.8 ,
lens-family-core >= 1.0.0 && < 2.1 ,
megaparsec >= 6.5.0 && < 7.1 ,
@ -469,7 +469,6 @@ Library
prettyprinter >= 1.2.0.1 && < 1.3 ,
prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 ,
profunctors >= 3.1.2 && < 5.6 ,
recursion-schemes >= 5.0.1 && < 6.0 ,
repline >= 0.2.1.0 && < 0.3 ,
serialise >= 0.2.0.0 && < 0.3 ,
scientific >= 0.3.0.0 && < 0.4 ,
@ -593,6 +592,7 @@ Test-Suite tasty
bytestring < 0.11,
cborg >= 0.2.0.0 && < 0.3 ,
containers ,
data-fix ,
deepseq >= 1.2.0.1 && < 1.5 ,
dhall ,
directory ,
@ -608,7 +608,6 @@ Test-Suite tasty
semigroups ,
serialise ,
spoon < 0.4 ,
recursion-schemes >= 5.0.1 && < 6.0 ,
tasty >= 0.11.2 && < 1.3 ,
tasty-expected-failure < 0.12,
tasty-hunit >= 0.10 && < 0.11,

231
dhall/src/Dhall.hs
View File

@ -15,7 +15,7 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}
{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
how to use the language, the compiler, and this library
@ -56,8 +56,6 @@ module Dhall
, toMonadic
, fromMonadic
, auto
, InterpretFix
, autoWithFix
, genericAuto
, InterpretOptions(..)
, defaultInterpretOptions
@ -110,14 +108,13 @@ module Dhall
import Control.Applicative (empty, liftA2, Alternative)
import Control.Exception (Exception)
import Control.Monad.Trans.Free (FreeF (..))
import Control.Monad.Trans.State.Strict
import Control.Monad (guard, (<=<))
import Control.Monad (guard)
import Data.Coerce (coerce)
import Data.Either.Validation (Validation(..), ealt, eitherToValidation, validationToEither)
import Data.Fix (Fix(..))
import Data.Functor.Contravariant (Contravariant(..), (>$<), Op(..))
import Data.Functor.Contravariant.Divisible (Divisible(..), divided)
import Data.Functor.Foldable (Base, Corecursive, elgot)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Monoid ((<>))
import Data.Scientific (Scientific)
@ -128,7 +125,7 @@ import Data.Text.Prettyprint.Doc (Pretty)
import Data.Typeable (Typeable)
import Data.Vector (Vector)
import Data.Word (Word8, Word16, Word32, Word64)
import Dhall.Core (Expr(..), Chunks(..), Var(..))
import Dhall.Core (Expr(..), Chunks(..))
import Dhall.Import (Imported(..))
import Dhall.Parser (Src(..))
import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X)
@ -143,7 +140,6 @@ import qualified Control.Exception
import qualified Control.Monad.Trans.State.Strict as State
import qualified Data.Foldable
import qualified Data.Functor.Compose
import qualified Data.Functor.Foldable
import qualified Data.Functor.Product
import qualified Data.Maybe
import qualified Data.List.NonEmpty
@ -909,120 +905,113 @@ instance (Interpret a, Interpret b) => Interpret (a, b)
auto :: Interpret a => Type a
auto = autoWith defaultInterpretOptions
newtype DhallFix f t = DhallFix { unDhallFix :: t }
newtype FixVar = FixVar { unFixVar :: Expr Src X }
-- This is a helper instance used for implementation of Interpret for DhallFix
instance Interpret FixVar where
autoWith _ = Type {..}
where
extract (App (Var (V "_" 0)) e0) = pure (FixVar e0)
extract e = typeError expected e
expected = "t"
type InterpretFix f t =
( Traversable f
, Corecursive t
, Interpret (f FixVar)
, Base t ~ f
)
instance InterpretFix f t => Interpret (DhallFix f t) where
autoWith opts = Type
{ extract = extr . Dhall.Core.alphaNormalize, expected = expe }
where
extr (Lam _ _ (Lam _ _ e)) = DhallFix <$> buildF e
extr e = typeError expe e
-- buildF = elgot f g <=< extract (auto @FixVar)
viaMonadic a b = fromMonadic . (toMonadic . a <=< toMonadic . b)
buildF = elgot f g `viaMonadic` extract (auto :: Type FixVar)
g = repack . extract xF_t . unFixVar
repack (Failure e) = Left (Failure e)
repack (Success s) = Right (Free s)
f (Free s) = Data.Functor.Foldable.embed <$> sequenceA s
f (Pure x) = typeError expe x
expe = Pi "t" (Dhall.Core.Const Dhall.Core.Type) -- = ∀(t : Type)
$ Pi "_" (Pi "_" (expected xF_t) "t") -- → ∀(F t → t)
$ "t" -- → t
xF_t = autoWith opts :: Type (f FixVar)
{-| `autoWithFix` allows you to implement `Interpret` instance for a recursive
data type. For example, given a Haskell expression:
> data Expr
> = Lit Natural
> | Add Expr Expr
> | Mul Expr Expr
> deriving (Generic, Show)
>
> makeBaseFunctor ''Expr
> deriving instance Generic (ExprF a)
> instance Interpret a => Interpret (ExprF a)
> instance Interpret Expr where autoWith = autoWithFix
And a dhall file:
> -- expr.dhall
> λ(t : Type) →
> let ExprF =
> < LitF : { _1 : Natural }
> | AddF : { _1 : t, _2 : t }
> | MulF : { _1 : t, _2 : t }
> >
>
> in λ(Fix : ExprF → t) →
> let Lit = λ(x : Natural) → Fix (ExprF.LitF { _1 = x })
> let Add = λ(a : t) → λ(b : t) → Fix (ExprF.AddF { _1 = a, _2 = b })
> let Mul = λ(a : t) → λ(b : t) → Fix (ExprF.MulF { _1 = a, _2 = b })
> in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2))
We're now able to interpret it:
> > input @Expr auto "./expr.dhall"
> Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2))
Alternatively, we could factor out some helper expressions:
> let ExprF =
> λ(t : Type) →
> < LitF : { _1 : Natural }
> | AddF : { _1 : t, _2 : t }
> | MulF : { _1 : t, _2 : t }
> >
>
> let Expr
> = λ(t : Type)
> → λ(Fix : ExprF t → t)
> → let E = ExprF t in
> { Lit = λ(x : Natural) → Fix (E.LitF { _1 = x })
> , Add = λ(a : t) → λ(b : t) → Fix (E.AddF { _1 = a, _2 = b })
> , Mul = λ(a : t) → λ(b : t) → Fix (E.MulF { _1 = a, _2 = b })
> }
And then the use location becomes:
> λ(t : Type)
> → λ(Fix : ExprF t → t)
> → let E = Expr t Fix in
> E.Add
> (E.Mul (E.Lit 3) (E.Lit 7))
> (E.Add (E.Lit 1) (E.Lit 2))
>
In general your dhall expression needs to be of type:
> ∀(t : Type) → ∀(F t → t) → t
Where F is an F-Algebra generating your data type.
{-| This type is exactly the same as `Data.Fix.Fix` except with a different
`Interpret` instance. This intermediate type simplies the implementation
of the inner loop for the `Interpret` instance for `Fix`
-}
autoWithFix :: forall f t. InterpretFix f t => InterpretOptions -> Type t
autoWithFix opts = unDhallFix <$> (autoWith opts :: Type (DhallFix f t))
newtype Result f = Result { _unResult :: f (Result f) }
resultToFix :: Functor f => Result f -> Fix f
resultToFix (Result x) = Fix (fmap resultToFix x)
instance Interpret (f (Result f)) => Interpret (Result f) where
autoWith options = Type { expected = expected_, extract = extract_ }
where
expected_ = "result"
extract_ (App _ expression) = do
fmap Result (extract (autoWith options) expression)
extract_ expression = do
typeError expression expected_
-- | You can use this instance to marshal recursive types from Dhall to Haskell.
--
-- Here is an example use of this instance:
--
-- > {-# LANGUAGE DeriveAnyClass #-}
-- > {-# LANGUAGE DeriveFoldable #-}
-- > {-# LANGUAGE DeriveFunctor #-}
-- > {-# LANGUAGE DeriveTraversable #-}
-- > {-# LANGUAGE DeriveGeneric #-}
-- > {-# LANGUAGE KindSignatures #-}
-- > {-# LANGUAGE QuasiQuotes #-}
-- > {-# LANGUAGE StandaloneDeriving #-}
-- > {-# LANGUAGE TypeFamilies #-}
-- > {-# LANGUAGE TemplateHaskell #-}
-- >
-- > import Data.Fix (Fix(..))
-- > import Data.Text (Text)
-- > import Dhall (Interpret)
-- > import GHC.Generics (Generic)
-- > import Numeric.Natural (Natural)
-- >
-- > import qualified Data.Fix as Fix
-- > import qualified Data.Functor.Foldable as Foldable
-- > import qualified Data.Functor.Foldable.TH as TH
-- > import qualified Dhall
-- > import qualified NeatInterpolation
-- >
-- > data Expr
-- > = Lit Natural
-- > | Add Expr Expr
-- > | Mul Expr Expr
-- > deriving (Show)
-- >
-- > TH.makeBaseFunctor ''Expr
-- >
-- > deriving instance Generic (ExprF a)
-- > deriving instance Interpret a => Interpret (ExprF a)
-- >
-- > example :: Text
-- > example = [NeatInterpolation.text|
-- > \(Expr : Type)
-- > -> let ExprF =
-- > < LitF :
-- > { _1 : Natural }
-- > | AddF :
-- > { _1 : Expr, _2 : Expr }
-- > | MulF :
-- > { _1 : Expr, _2 : Expr }
-- > >
-- >
-- > in \(Fix : ExprF -> Expr)
-- > -> let Lit = \(x : Natural) -> Fix (ExprF.LitF { _1 = x })
-- >
-- > let Add =
-- > \(x : Expr)
-- > -> \(y : Expr)
-- > -> Fix (ExprF.AddF { _1 = x, _2 = y })
-- >
-- > let Mul =
-- > \(x : Expr)
-- > -> \(y : Expr)
-- > -> Fix (ExprF.MulF { _1 = x, _2 = y })
-- >
-- > in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2))
-- > |]
-- >
-- > convert :: Fix ExprF -> Expr
-- > convert = Fix.cata Foldable.embed
-- >
-- > main :: IO ()
-- > main = do
-- > x <- Dhall.input Dhall.auto example :: IO (Fix ExprF)
-- >
-- > print (convert x :: Expr)
instance (Functor f, Interpret (f (Result f))) => Interpret (Fix f) where
autoWith options = Type { expected = expected_, extract = extract_ }
where
expected_ =
Pi "result" (Const Dhall.Core.Type)
(Pi "Make" (Pi "_" (expected (autoWith options :: Type (f (Result f)))) "result")
"result"
)
extract_ expression0 = go0 (Dhall.Core.alphaNormalize expression0)
where
go0 (Lam _ _ (Lam _ _ expression1)) =
fmap resultToFix (extract (autoWith options) expression1)
go0 _ = typeError expected_ expression0
{-| `genericAuto` is the default implementation for `auto` if you derive
`Interpret`. The difference is that you can use `genericAuto` without

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

@ -17,10 +17,8 @@
module Dhall.Test.Dhall where
import Control.Exception (SomeException, try)
import Data.Functor.Foldable.TH (makeBaseFunctor)
import Data.Monoid ((<>))
import Data.Fix (Fix(..))
import Data.Sequence (Seq)
import Data.String (fromString)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Vector (Vector)
@ -31,7 +29,6 @@ import Numeric.Natural (Natural)
import Test.Tasty
import Test.Tasty.HUnit
import qualified Data.Text
import qualified Data.Text.Lazy
import qualified Dhall
import qualified Dhall.Core
@ -39,23 +36,18 @@ import qualified Dhall.Import
import qualified Dhall.Map
import qualified Dhall.Parser
data AExpr
= Lit Natural
| Add AExpr AExpr
| Mul AExpr AExpr
deriving (Generic, Show, Eq)
makeBaseFunctor ''AExpr
deriving instance Generic (AExprF a)
instance Interpret a => Interpret (AExprF a)
instance Interpret AExpr where autoWith = Dhall.autoWithFix
data ExprF expr
= LitF Natural
| AddF expr expr
| MulF expr expr
deriving (Eq, Functor, Generic, Interpret, Show)
tests :: TestTree
tests =
testGroup "Input"
[ shouldShowDetailedTypeError
, shouldHandleUnionLiteral
, shouldHaveWorkingAutoWithFix
, shouldHaveWorkingRecursiveInterpret
, shouldHaveWorkingGenericAuto
, shouldHandleUnionsCorrectly
, shouldTreatAConstructorStoringUnitAsEmptyAlternative
@ -124,34 +116,24 @@ shouldTreatAConstructorStoringUnitAsEmptyAlternative = testCase "Handle unit con
Dhall.embed exampleInputType () @=? Field (Union (Dhall.Map.singleton "A" Nothing)) "A"
makeExprDhall :: AExpr -> Text
makeExprDhall expr = Data.Text.unlines
[ "let ExprF = ./tests/recursive/exprf.dhall"
, "let Expr = ./tests/recursive/expr.dhall"
, "in"
, "λ(t : Type) →"
, "λ(fix : ExprF t → t) →"
, "let E = Expr t fix"
, "let Lit = E.Lit"
, "let Add = E.Add"
, "let Mul = E.Mul in " <> (fromString $ show expr)
]
shouldHaveWorkingAutoWithFix :: TestTree
shouldHaveWorkingAutoWithFix = testGroup "autoWithFix"
shouldHaveWorkingRecursiveInterpret :: TestTree
shouldHaveWorkingRecursiveInterpret = testGroup "recursive Interpret instance"
[ testCase "works for a recursive expression" $ do
-- This expression could theoretically by generated by quickcheck
-- but I don't think that would provide much value, and would only slow
-- things down. Thoughts?
let expectedExpr = Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2))
expr <- Dhall.input Dhall.auto (makeExprDhall expectedExpr)
assertEqual "autoWithFix didn't give us what we wanted" expectedExpr expr
actual <- Dhall.input Dhall.auto "./tests/recursive/expr0.dhall"
expected @=? actual
, testCase "passes a shadowing sanity check" $ do
let expectedExpr = Lit 2
expr <- Dhall.input Dhall.auto "./tests/recursive/expr0.dhall"
assertEqual "autoWithFix didn't give us what we wanted" expectedExpr expr
actual <- Dhall.input Dhall.auto "./tests/recursive/expr1.dhall"
expected @=? actual
]
where
expected =
Fix
(AddF
(Fix (MulF (Fix (LitF 3)) (Fix (LitF 7))))
(Fix (AddF (Fix (LitF 1)) (Fix (LitF 2))))
)
data CompilerFlavor3 =
GHC3 | GHCJS3 | Helium3

12
dhall/tests/recursive/expr.dhall
View File

@ -1,12 +0,0 @@
let ExprF = ./exprf.dhall
let Expr
= λ(e : Type)
→ λ(f : ExprF e → e)
→ let E = ExprF e in
{ Lit = λ(x : Natural) → f (E.LitF { _1 = x })
, Add = λ(a : e) → λ(b : e) → f (E.AddF { _1 = a, _2 = b })
, Mul = λ(a : e) → λ(b : e) → f (E.MulF { _1 = a, _2 = b })
}
in Expr

37
dhall/tests/recursive/expr0.dhall
View File

@ -1,17 +1,20 @@
let ExprF = ./exprf.dhall
let Expr = ./expr.dhall
-- This code is deliberately convoluted to test shadowing, normalization, etc.
let h = 8
let result
= λ(a : Type)
→ λ(h : ExprF a → a)
→ let f = h
let g = a
let a = 1
let h = 1
let E = Expr g f
in E.Lit (h + a)
in result
λ(Expr : Type)
→ let ExprF =
< LitF :
{ _1 : Natural }
| AddF :
{ _1 : Expr, _2 : Expr }
| MulF :
{ _1 : Expr, _2 : Expr }
>
in λ(Fix : ExprF → Expr)
→ let Lit = λ(x : Natural) → Fix (ExprF.LitF { _1 = x })
let Add =
λ(x : Expr) → λ(y : Expr) → Fix (ExprF.AddF { _1 = x, _2 = y })
let Mul =
λ(x : Expr) → λ(y : Expr) → Fix (ExprF.MulF { _1 = x, _2 = y })
in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2))

18
dhall/tests/recursive/expr1.dhall Normal file
View File

@ -0,0 +1,18 @@
λ(a : Type)
→ let ExprF =
< LitF :
{ _1 : Natural }
| AddF :
{ _1 : a, _2 : a }
| MulF :
{ _1 : a, _2 : a }
>
in λ(a : ExprF → a)
→ let Lit = λ(x : Natural) → a (ExprF.LitF { _1 = x })
let Add = λ(x : a@1) → λ(y : a@1) → a (ExprF.AddF { _1 = x, _2 = y })
let Mul = λ(x : a@1) → λ(y : a@1) → a (ExprF.MulF { _1 = x, _2 = y })
in Add (Mul (Lit 3) (Lit 7)) (Add (Lit 1) (Lit 2))

8
dhall/tests/recursive/exprf.dhall
View File

@ -1,8 +0,0 @@
let ExprF
= λ(a : Type) →
< LitF : { _1 : Natural }
| AddF : { _1 : a, _2 : a }
| MulF : { _1 : a, _2 : a }
>
in ExprF

1
stack-lts-6.yaml
View File

@ -22,6 +22,7 @@ extra-deps:
- cborg-json-0.2.1.0
- contravariant-1.5.2
- cryptonite-0.24
- data-fix-0.2.0
- directory-1.3.4.0
- dlist-0.8.0.6
- dotgen-0.4.2