问题
I'm trying to write a replicate function for a length-indexed list using the machinery from GHC.TypeLits, singletons, and constraints.
The Vect type and signature for replicateVec are given below:
data Vect :: Nat -> Type -> Type where
VNil :: Vect 0 a
VCons :: a -> Vect (n - 1) a -> Vect n a
replicateVec :: forall n a. SNat n -> a -> Vect n a
How can you write this replicateVec function?
I have a version of replicateVec that compiles and type checks, but it appears to go into an infinite loop when run. The code is below. I have added comments to try to make the laws and proofs I am using a little easier to understand:
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeInType #-}
module VectStuff where
import Data.Constraint ((:-)(Sub), Dict(Dict))
import Data.Kind (Type)
import Data.Singletons.Decide (Decision(Disproved, Proved), Refuted, (:~:)(Refl), (%~))
import Data.Singletons.Prelude (PNum((-)), sing)
import Data.Singletons.TypeLits (SNat, Sing(SNat))
import GHC.TypeLits (CmpNat, KnownNat, Nat)
import Unsafe.Coerce (unsafeCoerce)
data Vect :: Nat -> Type -> Type where
VNil :: Vect 0 a
VCons :: forall n a. a -> Vect (n - 1) a -> Vect n a
deriving instance Show a => Show (Vect n a)
-- This is used to define the two laws below.
axiom :: Dict a
axiom = unsafeCoerce (Dict :: Dict ())
-- | This law says that if we know that @n@ is not 0, then it MUST be
-- greater than 0.
nGT0CmpNatLaw :: (Refuted (n :~: 0)) -> Dict (CmpNat n 0 ~ 'GT)
nGT0CmpNatLaw _ = axiom
-- | This law says that if we know that @n@ is greater than 0, then we know
-- that @n - 1@ is also a 'KnownNat'.
cmpNatGT0KnownNatLaw :: forall n. (CmpNat n 0 ~ 'GT) :- KnownNat (n - 1)
cmpNatGT0KnownNatLaw = Sub axiom
-- | This is a proof that if we have an @n@ that is greater than 0, then
-- we can get an @'SNat' (n - 1)@
sNatMinus1 :: forall n. (CmpNat n 0 ~ 'GT) => SNat n -> SNat (n - 1)
sNatMinus1 SNat =
case cmpNatGT0KnownNatLaw @n of
Sub Dict -> SNat
-- | This is basically a combination of the other proofs. If we have a
-- @SNat n@ and we know that it is not 0, then we can get an @SNat (n -1)@
-- that we know is a 'KnownNat'.
nGT0Proof ::
forall n.
Refuted (n :~: 0)
-> SNat n
-> (SNat (n - 1), Dict (KnownNat (n - 1)))
nGT0Proof f snat =
case nGT0CmpNatLaw f of
Dict ->
case cmpNatGT0KnownNatLaw @n of
Sub d -> (sNatMinus1 snat, d)
replicateVec :: forall n a. SNat n -> a -> Vect n a
replicateVec snat a =
-- First we check if @snat@ is 0.
case snat %~ (sing @_ @0) of
-- If we get a proof that @snat@ is 0, then we just return 'VNil'.
Proved Refl -> VNil
-- If we get a proof that @snat@ is not 0, then we use 'nGT0Proof'
-- to get @n - 1@, and pass that to 'replicateVec' recursively.
Disproved f ->
case nGT0Proof f snat of
(snat', Dict) -> VCons a $ replicateVec snat' a
However, for some reason this replicateVec function goes into an endless loop when I try to run it:
> replicateVec (sing @_ @3) "4"
["4","4","4","4","4","4","4","4","4","4","4","4",^CInterrupted.
Why is this happening? How can I write the replicateVec function correctly?
回答1:
axiom :: Dict a is very unsafe because the runtime representation of a Dict a depends on the constraint a (which corresponds to a dictionary that is captured by the Dict constructor).
A KnownNat constraint corresponds to an integer value at runtime, so it is not correct to construct a Dict of KnownNat using unsafeCoerce on a dummy dictionary (in cmpNatGT0KnownNatLaw). In particular, this integer is used in replicateVec to check whether the integer is 0.
Type equalities (~) are special in that they have no meaningful runtime representation, hence axiom-atizing equalities, if they are correct, technically does not lead to bad runtime behavior because the coerced dictionary is never used, but coercing from Dict () to a Dict (a ~ b) is certainly not a supported use of unsafeCoerce. Coercing between equalities might be more reliable.
To solve KnownNat constraints, constraints internally associates the type-level operations to their term-level counterparts, see magic in Data.Constraints.Nat and reconstructs the KnownNat dictionary based on implicit knowledge about how GHC represents type classes.
Anyway, for an inductive construction like replicate, we can avoid KnownNat, and use a different singleton type that reflects the inductive nature of Nat.
data Sing n where
Z :: Sing 0
S :: Sing n -> Sing (1 + n)
This singleton is actually annoying to use because (+) is not injective. (\x -> (1 + x) technically is injective, but GHC can't tell that much.) It would be easier with an actually inductively defined Nat, but still, with the right set of constraints, we can do some things. For example, singleton reflection (mapping from the type-level n to a Sing n value):
class SingN n where
singN :: Sing n
instance {-# OVERLAPPING #-} SingN 0 where
singN = Z
instance (n ~ (1 + n'), n' ~ (n - 1), SingN n') => SingN n where
singN = S (singN @n')
The list type should be similarly structured:
data List n a where
Nil :: List 0 a
Cons :: a -> List n a -> List (1 + n) a
The reason to set up the type index n this way instead of Sing (n-1) -> Sing n and a -> List (n-1) a -> List n a is to forbid some silly values:
oops :: Sing 0
oops = S undefined
ouch :: List 0 ()
ouch = Cons () undefined
which would be a problem because functions would actually need to handle those cases which make no sense.
replicate turns out to be straightforward to implement because List and Sing have a lot of structure in common.
replicate :: Sing n -> a -> List n a
replicate Z _ = Nil
replicate (S n) a = Cons a (replicate n a)
We can now apply replicate as follows:
replicate (singN @3) "x"
- Compilable gist
来源：https://stackoverflow.com/questions/49709113/replicate-function-for-a-length-indexed-list-using-ghc-typelits-and-singletons