* Add autoWithFix helper function (#1161) * Fix some dependencies. Remove TypeApplications extension. * Pin recursion-schemes to appease hydra. * Implement review suggestions. * Fix error in documentation.
This commit is contained in:
MaxOw
mergify[bot]
parent
268c79631d
commit
ec8bcf0d63
|
|
@ -413,6 +413,7 @@ Extra-Source-Files:
|
|||
tests/lint/success/*.dhall
|
||||
tests/diff/*.dhall
|
||||
tests/diff/*.txt
|
||||
tests/recursive/*.dhall
|
||||
tests/regression/*.dhall
|
||||
tests/tutorial/*.dhall
|
||||
|
||||
|
|
@ -451,6 +452,7 @@ 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 ,
|
||||
|
|
@ -461,6 +463,7 @@ Library
|
|||
prettyprinter >= 1.2.0.1 && < 1.3 ,
|
||||
prettyprinter-ansi-terminal >= 1.1.1 && < 1.2 ,
|
||||
profunctors >= 3.1.2 && < 5.5 ,
|
||||
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 ,
|
||||
|
|
@ -597,6 +600,7 @@ Test-Suite tasty
|
|||
semigroups ,
|
||||
serialise ,
|
||||
spoon < 0.4 ,
|
||||
recursion-schemes >= 5.0.1 && < 6.0 ,
|
||||
tasty >= 0.11.2 && < 1.3 ,
|
||||
tasty-hunit >= 0.9.2 && < 0.11,
|
||||
tasty-quickcheck >= 0.9.2 && < 0.11,
|
||||
|
|
|
|||
|
|
@ -1,3 +1,4 @@
|
|||
{-# LANGUAGE ConstraintKinds #-}
|
||||
{-# LANGUAGE DefaultSignatures #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
|
|
@ -6,13 +7,16 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
|
||||
{-| Please read the "Dhall.Tutorial" module, which contains a tutorial explaining
|
||||
how to use the language, the compiler, and this library
|
||||
-}
|
||||
|
|
@ -52,6 +56,8 @@ module Dhall
|
|||
, toMonadic
|
||||
, fromMonadic
|
||||
, auto
|
||||
, InterpretFix
|
||||
, autoWithFix
|
||||
, genericAuto
|
||||
, InterpretOptions(..)
|
||||
, defaultInterpretOptions
|
||||
|
|
@ -104,12 +110,14 @@ 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.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)
|
||||
|
|
@ -120,7 +128,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(..))
|
||||
import Dhall.Core (Expr(..), Chunks(..), Var(..))
|
||||
import Dhall.Import (Imported(..))
|
||||
import Dhall.Parser (Src(..))
|
||||
import Dhall.TypeCheck (DetailedTypeError(..), TypeError, X)
|
||||
|
|
@ -135,6 +143,7 @@ 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
|
||||
|
|
@ -900,6 +909,121 @@ 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.
|
||||
|
||||
-}
|
||||
autoWithFix :: forall f t. InterpretFix f t => InterpretOptions -> Type t
|
||||
autoWithFix opts = unDhallFix <$> (autoWith opts :: Type (DhallFix f t))
|
||||
|
||||
{-| `genericAuto` is the default implementation for `auto` if you derive
|
||||
`Interpret`. The difference is that you can use `genericAuto` without
|
||||
having to explicitly provide an `Interpret` instance for a type as long as
|
||||
|
|
|
|||
|
|
@ -1,16 +1,23 @@
|
|||
{-# LANGUAGE DeriveAnyClass #-}
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE DeriveTraversable #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Dhall.Test.Dhall where
|
||||
|
||||
import Control.Exception (SomeException, try)
|
||||
import Data.Functor.Foldable.TH (makeBaseFunctor)
|
||||
import Data.String (fromString)
|
||||
import Data.Text (Text)
|
||||
import Dhall (Inject, Interpret)
|
||||
import Dhall.Core (Expr(..))
|
||||
|
|
@ -19,17 +26,30 @@ import Numeric.Natural (Natural)
|
|||
import Test.Tasty
|
||||
import Test.Tasty.HUnit
|
||||
|
||||
import qualified Data.Text
|
||||
import qualified Dhall
|
||||
import qualified Dhall.Core
|
||||
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
|
||||
|
||||
tests :: TestTree
|
||||
tests =
|
||||
testGroup "Input"
|
||||
[ shouldShowDetailedTypeError
|
||||
, shouldHandleUnionLiteral
|
||||
, shouldHaveWorkingAutoWithFix
|
||||
, shouldHaveWorkingGenericAuto
|
||||
, shouldHandleUnionsCorrectly
|
||||
, shouldTreatAConstructorStoringUnitAsEmptyAlternative
|
||||
|
|
@ -37,7 +57,7 @@ tests =
|
|||
|
||||
data MyType = MyType { foo :: String , bar :: Natural }
|
||||
|
||||
wrongDhallType :: Dhall.Type MyType
|
||||
wrongDhallType :: Dhall.Type MyType
|
||||
wrongDhallType = Dhall.Type { .. }
|
||||
where expected =
|
||||
Dhall.Core.Record
|
||||
|
|
@ -51,7 +71,7 @@ wrongDhallType = Dhall.Type { .. }
|
|||
shouldShowDetailedTypeError :: TestTree
|
||||
shouldShowDetailedTypeError = testCase "detailed TypeError" $ do
|
||||
inputEx :: Either SomeException MyType <-
|
||||
try ( Dhall.input wrongDhallType "{ bar = 0, foo = \"foo\" }")
|
||||
try ( Dhall.input wrongDhallType "{ bar = 0, foo = \"foo\" }")
|
||||
|
||||
let expectedMsg =
|
||||
"\ESC[1;31mError\ESC[0m: Invalid Dhall.Type \n\
|
||||
|
|
@ -69,7 +89,7 @@ shouldShowDetailedTypeError = testCase "detailed TypeError" $ do
|
|||
\ \n"
|
||||
|
||||
let assertMsg = "The exception message did not match the expected output"
|
||||
|
||||
|
||||
case inputEx of
|
||||
Left ex -> assertEqual assertMsg expectedMsg (show ex)
|
||||
Right _ -> fail "The extraction using a wrong type succeded"
|
||||
|
|
@ -96,6 +116,35 @@ 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"
|
||||
[ 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
|
||||
, 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
|
||||
]
|
||||
|
||||
data CompilerFlavor3 =
|
||||
GHC3 | GHCJS3 | Helium3
|
||||
deriving (Generic, Show, Eq)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,12 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
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
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
let ExprF
|
||||
= λ(a : Type) →
|
||||
< LitF : { _1 : Natural }
|
||||
| AddF : { _1 : a, _2 : a }
|
||||
| MulF : { _1 : a, _2 : a }
|
||||
>
|
||||
|
||||
in ExprF
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
{ mkDerivation, base, base-orphans, comonad, free, HUnit, stdenv
|
||||
, template-haskell, th-abstraction, transformers
|
||||
}:
|
||||
mkDerivation {
|
||||
pname = "recursion-schemes";
|
||||
version = "5.1.3";
|
||||
sha256 = "b21736e54b1d5fb0149624e95f2d8d8fd3413bb0972eda6a70e5753d3c9f1528";
|
||||
revision = "1";
|
||||
editedCabalFile = "0zxcmga4fy42arbyv1kzbyfnsghnll3prkpva58x654x4cg4diwk";
|
||||
libraryHaskellDepends = [
|
||||
base base-orphans comonad free template-haskell th-abstraction
|
||||
transformers
|
||||
];
|
||||
testHaskellDepends = [ base HUnit template-haskell transformers ];
|
||||
homepage = "http://github.com/ekmett/recursion-schemes/";
|
||||
description = "Representing common recursion patterns as higher-order functions";
|
||||
license = stdenv.lib.licenses.bsd2;
|
||||
}
|
||||
|
|
@ -38,6 +38,7 @@ extra-deps:
|
|||
- turtle-1.5.14
|
||||
- unliftio-core-0.1.2.0
|
||||
- yaml-0.10.4.0
|
||||
- recursion-schemes-5.1.3
|
||||
flags:
|
||||
transformers-compat:
|
||||
four: true
|
||||
|
|
|
|||
Loading…
Reference in New Issue