Open howtonotwin opened 6 years ago
What you want is reasonable. And perhaps key functions, like foldr
, can be rewritten as you suggest. But part of the point of singletons
is so that you don't have to rewrite your functions! Yet, option (2) seems terrible and fragile.
Maybe the solution is for lambda-lifting to be a bit cleverer in its approach. We could likely tell statically that we don't need foldr
's last argument and so can leave it off when lifting. That will solve your immediate problem, but perhaps we can settle for that, for now.
Indeed, lambda-lifting of local functions is quite un-optimized at the moment and always captures all variables that are in scope at the definition site, even if they are not actually free in the definition itself. A conceptually simple fix would be to implement a function which computes the free variables of a definition and only capture those variables when we lift a closure to the top level during promotion. (In your particular example, this means that the promoted version of go
would only capture k
.)
th-desugar
would be a good place to put this function, as it already has the ability to compute the free variables of types (here). We would just need a term-level counterpart as well.
Yes, that's just what I was thinking, if you wanted to implement it. :)
It looks like this problem will strike in more places in the upcoming singletons-2.5
release. For example, this code typechecks with singletons-2.4
:
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Bug where
import Data.Kind
import Data.Singletons.Prelude
import Data.Singletons.TH
$(singletons [d|
forallb :: (a -> Bool) -> [a] -> Bool
forallb = all
existsb, existsb' :: (a -> Bool) -> [a] -> Bool
existsb = any
existsb' p = not . forallb (not . p)
|])
existsbExistsb' :: forall (a :: Type) (p :: a ~> Bool) (l :: [a]).
Sing p -> Sing l
-> Existsb' p l :~: Existsb p l
existsbExistsb' _ SNil = Refl
existsbExistsb' sp (SCons sx sls)
= case sp @@ sx of
STrue -> Refl
SFalse
| Refl <- existsbExistsb' sp sls
-> Refl
But not with singletons-2.5
:
../../Bug.hs:29:16: error:
• Could not deduce: Not
(Data.Singletons.Prelude.Foldable.Case_6989586621680649554
(NotSym0 .@#@$$$ p)
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181224
('base-4.12.0.0:Data.Semigroup.Internal.All 'False)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.All_Sym0
.@#@$$$ (NotSym0 .@#@$$$ p)))
('base-4.12.0.0:Data.Semigroup.Internal.All 'True)
(n1 : n2)
n2)))
~ Data.Singletons.Prelude.Foldable.Case_6989586621680649567
p
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181236
('base-4.12.0.0:Data.Semigroup.Internal.Any 'True)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.Any_Sym0
.@#@$$$ p))
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(n1 : n2)
n2))
from the context: l ~ (n1 : n2)
bound by a pattern with constructor:
SCons :: forall a (n1 :: a) (n2 :: [a]).
Sing n1 -> Sing n2 -> Sing (n1 : n2),
in an equation for ‘existsbExistsb'’
at ../../Bug.hs:27:21-32
or from: Apply p n1 ~ 'True
bound by a pattern with constructor: STrue :: Sing 'True,
in a case alternative
at ../../Bug.hs:29:7-11
Expected type: Existsb' p l :~: Existsb p l
Actual type: Data.Singletons.Prelude.Foldable.Case_6989586621680649567
p
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181236
('base-4.12.0.0:Data.Semigroup.Internal.Any 'True)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.Any_Sym0
.@#@$$$ p))
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(n1 : n2)
n2))
:~: Data.Singletons.Prelude.Foldable.Case_6989586621680649567
p
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181236
('base-4.12.0.0:Data.Semigroup.Internal.Any 'True)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.Any_Sym0
.@#@$$$ p))
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(n1 : n2)
n2))
• In the expression: Refl
In a case alternative: STrue -> Refl
In the expression:
case sp @@ sx of
STrue -> Refl
SFalse | Refl <- existsbExistsb' sp sls -> Refl
• Relevant bindings include
sls :: Sing n2 (bound at ../../Bug.hs:27:30)
sx :: Sing n1 (bound at ../../Bug.hs:27:27)
sp :: Sing p (bound at ../../Bug.hs:27:17)
existsbExistsb' :: Sing p -> Sing l -> Existsb' p l :~: Existsb p l
(bound at ../../Bug.hs:26:1)
|
29 | STrue -> Refl
| ^^^^
../../Bug.hs:32:12: error:
• Could not deduce: Not
(Data.Singletons.Prelude.Foldable.Case_6989586621680649554
(NotSym0 .@#@$$$ p)
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181224
('base-4.12.0.0:Data.Semigroup.Internal.All 'True)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.All_Sym0
.@#@$$$ (NotSym0 .@#@$$$ p)))
('base-4.12.0.0:Data.Semigroup.Internal.All 'True)
(n1 : n2)
n2)))
~ Data.Singletons.Prelude.Foldable.Case_6989586621680649567
p
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181236
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.Any_Sym0
.@#@$$$ p))
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(n1 : n2)
n2))
from the context: l ~ (n1 : n2)
bound by a pattern with constructor:
SCons :: forall a (n1 :: a) (n2 :: [a]).
Sing n1 -> Sing n2 -> Sing (n1 : n2),
in an equation for ‘existsbExistsb'’
at ../../Bug.hs:27:21-32
or from: Apply p n1 ~ 'False
bound by a pattern with constructor: SFalse :: Sing 'False,
in a case alternative
at ../../Bug.hs:30:7-12
or from: Existsb p n2 ~ Existsb' p n2
bound by a pattern with constructor:
Refl :: forall k (a :: k). a :~: a,
in a pattern binding in
pattern guard for
a case alternative
at ../../Bug.hs:31:11-14
Expected type: Existsb' p l :~: Existsb p l
Actual type: Data.Singletons.Prelude.Foldable.Case_6989586621680649567
p
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181236
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.Any_Sym0
.@#@$$$ p))
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(n1 : n2)
n2))
:~: Data.Singletons.Prelude.Foldable.Case_6989586621680649567
p
(n1 : n2)
(singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.TFHelper_6989586621680181236
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(Data.Singletons.Prelude.Base.Let6989586621679917966Go
(MappendSym0
.@#@$$$ (singletons-2.5:Data.Singletons.Prelude.Semigroup.Internal.Any_Sym0
.@#@$$$ p))
('base-4.12.0.0:Data.Semigroup.Internal.Any 'False)
(n1 : n2)
n2))
• In the expression: Refl
In a case alternative:
SFalse | Refl <- existsbExistsb' sp sls -> Refl
In the expression:
case sp @@ sx of
STrue -> Refl
SFalse | Refl <- existsbExistsb' sp sls -> Refl
• Relevant bindings include
sls :: Sing n2 (bound at ../../Bug.hs:27:30)
sx :: Sing n1 (bound at ../../Bug.hs:27:27)
sp :: Sing p (bound at ../../Bug.hs:27:17)
existsbExistsb' :: Sing p -> Sing l -> Existsb' p l :~: Existsb p l
(bound at ../../Bug.hs:26:1)
|
32 | -> Refl
| ^^^^
The culprit is that I changed the definition of all
from this (in singletons-2.4
):
To this (in singletons-2.5
):
Just like the issue with foldr
, I believe that making singletons
close over fewer variables when lambda lifting would be sufficient to fix this buglet.
For any readers out there who are interested in fixing this bug, I've just pushed a FVs
branch in th-desugar
which adds a plethora of new functions that compute free variables. It's my hope that these will be useful in implementing the suggestion in https://github.com/goldfirere/singletons/issues/339#issuecomment-397309205.
Edit: The FVs
branch has been merged into master
.
Another example, related to ZipWith
:
Yay, finally we did it, but we had to write the algorithm from scratch and our previous utility functions were useless :(
One consolation point however is that GHC seems able to reason with the Fmap (FlipSym2 (TyCon2 (->)) r) vv
, it just fails with more complex expressions :(
Note: I wrote that last example 3 before I posted #447 so it still uses SDecide
instead of SEq
. It also works if you convert it to using SEq
; both work fine without needing unsafeCoerce
.
Another set of examples, this one relating to constraints instead of ZipWith
:
unsafeCoerce
doesn't help us here, it doesn't seem to help GHC resolve constraints (as far as I can tell anyway; I don't know how the type checker works in detail):
I haven't examined your examples in close detail, but I don't think the issues you're experiencing are a symptom of this issue, which document unintended implementation details leaking through. As I mention in https://github.com/goldfirere/singletons/issues/447#issuecomment-612453185, there are some implementation details that are simply unavoidable when doing dependently typed programming. (Do correct me if I've misunderstood the nature of your examples.)
Admittedly I hadn't gotten around to actually attempting to write a proof when I posted those examples - I couldn't find examples of proofs or hints on how to write these anywhere. The example in the OP seems to be about encoding proofs as term-level functions, but I seem to rather need type-level constraints in my examples. I've now finally found an example by Stephanie Weirich, and made an attempt for my code.
The problem in my examples above ultimately stemmed from using the lookupKV
function directly, and were solved by inlining it. So let's try to prove something about it, that can be used by the compiler at the caller's site. Our first goal is:
Fmap f (LookupKV k kk vv) ~ LookupKV k kk (Fmap f vv)
Trying it by hand, we could do something like this:
Inducting on kk vv:
Given:
Wf. (Fmap f (LookupKV k kk vv) ~ LookupKV k kk (Fmap f vv))
Sf. Just (Apply f v') ~ Fmap f (Just v')
Tf. Apply f v' ': Fmap f vv ~ Fmap f (v' ': vv)
Deduce:
(Fmap f (LookupKV k (k' ': kk) (v' ': vv)) ~ LookupKV k (k' ': kk) (Fmap f (v' ': vv)))
by (Tf), ~
LookupKV k (k' ': kk) (Apply f v' ': Fmap f vv)
Apply type-family reduction rule for LookupKV on both sides, which GHC knows...
if k == k' if k == k'
then -> Fmap f (Just v') by (Sf) ~ then -> Just (Apply f v')
else -> Fmap f (LookupKV k kk vv) by (Wf) ~ else -> Lookup k kk (Fmap f vv)
[].
OK so let's try it in the code:
Now that looks like an example of what I refer to as "unintended" implementation details. Perhaps "unintended" was not the best choice of phrase in hindsight, since I think if you were to write this proof in another dependently typed language, the details would look pretty similar. The main difference is that in singletons
, you have to refer to gensymmed names like Case_6989586621679077040
in order to complete the proof. A proof assistant like Coq, on the other hand, would let you manipulate subexpressions directly without needing to explicitly name them.
If not unintended, then the approach that singletons
uses is definitely more fragile. Case in point: I tried to compile your HLookupKVWithProof.hs
example from https://github.com/goldfirere/singletons/issues/339#issuecomment-612525798, but it failed due to GHC generating a different unique number for Case
:
HLookupKVWithProof.hs:41:16: error:
Not in scope: type constructor or class ‘Case_6989586621679077040’
Perhaps you meant ‘Case_6989586621679077286’ (line 11)
|
41 | class (Fmap f (Case_6989586621679077040 k k' kk v' vv eq) ~
| ^^^^^^^^^^^^^^^^^^^^^^^^
HLookupKVWithProof.hs:42:8: error:
Not in scope: type constructor or class ‘Case_6989586621679077040’
Perhaps you meant ‘Case_6989586621679077286’ (line 11)
|
42 | Case_6989586621679077040 k k' kk (Apply f v') (Fmap f vv) eq)
| ^^^^^^^^^^^^^^^^^^^^^^^^
Unfortunately, this means that this sort of code is inherently nondeterministic.
Alas, I don't see an easy solution to this problem. @goldfirere's suggestion in https://github.com/goldfirere/singletons/issues/339#issuecomment-397156665 will make this less likely to occur, but it likely won't make the issue completely go away. I can't think of a way to completely solve this short of equipping GHC with some way to manipulate subexpressions à la Coq.
Until GHC gains such a power, you can always apply the workaround from (2) in https://github.com/goldfirere/singletons/issues/339#issue-332172197. Namely, factor out the relevant subexpressions to be top-level functions, like so:
singletons [d|
lookupKV :: Eq k => k -> [k] -> [v] -> Maybe v
lookupKV k [] [] = Nothing
lookupKV k (k':kk) (v:vv) = aux k kk v vv (k == k')
aux :: Eq k => k -> [k] -> v -> [v] -> Bool -> Maybe v
aux _ _ v _ True = Just v
aux k kk v vv False = lookupKV k kk vv
|]
...
class (Fmap f (Aux k kk v' vv eq) ~
Aux k kk (Apply f v') (Fmap f vv) eq)
=> Vf f (k :: kt) k' kk v' vv eq where
Well, we can imagine using a little TH magic. The challenge is that the internal functions have nondeterministic names. So we can't hard-code them. But we can reify the top-level expression and then extract the internal name from it. One problem is that TH never preserves value definitions for reification. Could we get to what we want from the promoted version of functions? Probably.
More generally, it seems possible to imagine a tactic-like system that uses TH.
I don't think either of these are good ideas. But they're ideas, nonetheless.
A proof about a function needs to have the implementation details of the function. In
singletons
, functions are type families, and type families must expose all their equations (AKA their implementation). However, functions that uselet
/where
create helper type families, where the implementation is known, but the type families themselves have unutterable names. It becomes impossible to write proofs for these hidden functions, so proofs for the whole function become impossible.E.g.
Both cases fail with a similar error
The issue is that the
go
infoldr
, when promoted, gets an (unused) argument that representsfoldr
's list argument. This mucks up the proof, where it isn't clear that the argument doesn't matter. Because this function has no stable name, not to mention its unexported status, one can't prove around that. It seems impossible to writesumIs
.I feel like a fix for this deserves to be in
singletons
. Here are a couple ways:Remove
go
fromfoldr
. Replacingfoldr
with a nicer version fixes this:I think, sometimes, this strategy will fail. In those cases, the helper function can be wholly lifted out. However, this is a complicated procedure. Further, the changes involved are to the functions being promoted themselves. This requires actual effort by the person writing the functions (i.e. me), which is at odds to the fact that I am lazy. If the promoted functions in
singletons
were changed like this, I also think maintainability would take a hit, due to the changes to thebase
codesingletons
copies.Expose the implementation details of promoted functions. Give stable names to all the supporting definitions for a promoted function, which lets them be exported and talked about. This kicks the number of things that can appear in export lists from "high" to "higher" (further evidence for TH-controlled exports). This also has the effect of coupling (even further than usual) the API of a promoted function to the exact way
singletons
decides to promote it. I'm not sure what the stance is on that, or even how fastsingletons
's implementation changes currently. There's always the option of making only some things stable (e.g.where
clauses get stable names,case
s don't, etc.).