Merge pull request #65 from target/github-ci

Use github CI

.github/workflows/ci.yml

@@ -0,0 +1,91 @@
+name: CI
+
+# Trigger the workflow on push or pull request, but only for the master branch
+on:
+  pull_request:
+  push:
+    branches: [master]
+
+jobs:
+  cabal:
+    name: ${{ matrix.os }} / ghc ${{ matrix.ghc }}
+    runs-on: ${{ matrix.os }}
+    strategy:
+      matrix:
+        os: [ubuntu-latest, macOS-latest, windows-latest]
+        cabal: ["3.2"]
+        ghc:
+          - "8.6.5"
+          - "8.8.3"
+          - "8.10.1"
+        exclude:
+          - os: macOS-latest
+            ghc: 8.8.3
+          - os: macOS-latest
+            ghc: 8.6.5
+          - os: windows-latest
+            ghc: 8.8.3
+          - os: windows-latest
+            ghc: 8.6.5
+
+    steps:
+    - uses: actions/checkout@v2
+      if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+    - uses: actions/setup-haskell@v1.1.1
+      id: setup-haskell-cabal
+      name: Setup Haskell
+      with:
+        ghc-version: ${{ matrix.ghc }}
+        cabal-version: ${{ matrix.cabal }}
+
+    - name: Freeze
+      run: |
+        cabal freeze
+
+    - uses: actions/cache@v1
+      name: Cache ~/.cabal/store
+      with:
+        path: ${{ steps.setup-haskell-cabal.outputs.cabal-store }}
+        key: ${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('cabal.project.freeze') }}
+
+    - name: Build
+      run: |
+        cabal configure --enable-tests --enable-benchmarks --test-show-details=direct
+        cabal build all --disable-optimization
+
+    - name: Test
+      run: |
+        cabal test all
+
+  stack:
+    name: stack / ghc ${{ matrix.ghc }}
+    runs-on: ubuntu-latest
+    strategy:
+      matrix:
+        stack: ["2.3.1"]
+        ghc: ["8.8.3"]
+
+    steps:
+    - uses: actions/checkout@v2
+      if: github.event.action == 'opened' || github.event.action == 'synchronize' || github.event.ref == 'refs/heads/master'
+
+    - uses: actions/setup-haskell@v1.1
+      name: Setup Haskell Stack
+      with:
+        ghc-version: ${{ matrix.ghc }}
+        stack-version: ${{ matrix.stack }}
+
+    - uses: actions/cache@v1
+      name: Cache ~/.stack
+      with:
+        path: ~/.stack
+        key: ${{ runner.os }}-${{ matrix.ghc }}-stack
+
+    - name: Build
+      run: |
+        stack build --system-ghc --test --bench --fast --no-run-tests --no-run-benchmarks
+
+    - name: Test
+      run: |
+        stack test --system-ghc

Data/Row/Dictionaries.hs

@@ -30,6 +30,9 @@ module Data.Row.Dictionaries
   , mapForall
   , IsA(..)
   , As(..)
+  , ActsOn(..)
+  , As'(..)
+  , apSingleForall
   -- * Re-exports
   , Dict(..), (:-)(..), HasDict(..), (\\), withDict
   )
@@ -58,9 +61,22 @@ class IsA c f a where
 instance c a => IsA c f (f a) where
   as = As
 
+data As' c t a where
+  As' :: forall c f a t. (a ~ f t, c f) => As' c t a
+
+class ActsOn c t a where
+  actsOn :: As' c t a
+
+instance c f => ActsOn c t (f t) where
+  actsOn = As'
+
 -- | An internal type used by the 'metamorph' in 'mapForall'.
 newtype MapForall c f (r :: Row k) = MapForall { unMapForall :: Dict (Forall (Map f r) (IsA c f)) }
 
+-- | An internal type used by the 'metamorph' in 'apSingleForall'.
+newtype ApSingleForall c a (fs :: Row (k -> k')) = ApSingleForall
+  { unApSingleForall :: Dict (Forall (ApSingle fs a) (ActsOn c a)) }
+
 -- | This allows us to derive a `Forall (Map f r) ..` from a `Forall r ..`.
 mapForall :: forall f c ρ. Forall ρ c :- Forall (Map f ρ) (IsA c f)
 mapForall = Sub $ unMapForall $ metamorph @_ @ρ @c @FlipConst @Proxy @(MapForall c f) @Proxy Proxy empty uncons cons $ Proxy
@@ -74,6 +90,19 @@ mapForall = Sub $ unMapForall $ metamorph @_ @ρ @c @FlipConst @Proxy @(MapForal
             \\ mapExtendSwap @ℓ @τ @ρ @f
             \\ uniqueMap @(Extend ℓ τ ρ) @f
 
+-- | This allows us to derive a `Forall (ApSingle f r) ..` from a `Forall f ..`.
+apSingleForall :: forall a c fs. Forall fs c :- Forall (ApSingle fs a) (ActsOn c a)
+apSingleForall = Sub $ unApSingleForall $ metamorph @_ @fs @c @FlipConst @Proxy @(ApSingleForall c a) @Proxy Proxy empty uncons cons $ Proxy
+  where empty _ = ApSingleForall Dict
+        uncons _ _ = FlipConst Proxy
+        cons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, FrontExtends ℓ τ ρ, AllUniqueLabels (Extend ℓ τ ρ))
+             => Label ℓ -> FlipConst (Proxy τ) (ApSingleForall c a ρ)
+             -> ApSingleForall c a (Extend ℓ τ ρ)
+        cons _ (FlipConst (ApSingleForall Dict)) = case frontExtendsDict @ℓ @τ @ρ of
+          FrontExtendsDict Dict -> ApSingleForall Dict
+            \\ apSingleExtendSwap @ℓ @a @ρ @τ
+            \\ uniqueApSingle @(Extend ℓ τ ρ) @a
+
 -- | Allow any 'Forall` over a row-type, be usable for 'Unconstrained1'.
 freeForall :: forall r c. Forall r c :- Forall r Unconstrained1
 freeForall = Sub $ UNSAFE.unsafeCoerce @(Dict (Forall r c)) Dict
@@ -102,11 +131,11 @@ mapExtendSwap :: forall ℓ τ r f. Dict (Extend ℓ (f τ) (Map f r) ≈ Map f
 mapExtendSwap = UNSAFE.unsafeCoerce $ Dict @Unconstrained
 
 -- | Proof that the 'Ap' type family preserves labels and their ordering.
-apExtendSwap :: forall ℓ (τ :: k) r (f :: k -> *) fs. Dict (Extend ℓ (f τ) (Ap fs r) ≈ Ap (Extend ℓ f fs) (Extend ℓ τ r))
+apExtendSwap :: forall ℓ τ r f fs. Dict (Extend ℓ (f τ) (Ap fs r) ≈ Ap (Extend ℓ f fs) (Extend ℓ τ r))
 apExtendSwap = UNSAFE.unsafeCoerce $ Dict @Unconstrained
 
 -- | Proof that the 'ApSingle' type family preserves labels and their ordering.
-apSingleExtendSwap :: forall k ℓ (τ :: k) r (f :: k -> *). Dict (Extend ℓ (f τ) (ApSingle r τ) ≈ ApSingle (Extend ℓ f r) τ)
+apSingleExtendSwap :: forall ℓ τ r f. Dict (Extend ℓ (f τ) (ApSingle r τ) ≈ ApSingle (Extend ℓ f r) τ)
 apSingleExtendSwap = UNSAFE.unsafeCoerce $ Dict @Unconstrained
 
 -- | Proof that the 'Ap' type family preserves labels and their ordering.

Data/Row/Records.hs

@@ -351,7 +351,7 @@ mapF f = unRFMap . biMetamorph @_ @_ @ϕ @ρ @c @(,) @RecAp @(RFMap g) @App Prox
            => Label ℓ -> (App f τ, RFMap g ϕ ρ) -> RFMap g (Extend ℓ f ϕ) (Extend ℓ τ ρ)
     doCons l (App v, RFMap r) = RFMap (extend l (f @f @τ v) r)
       \\ mapExtendSwap @ℓ @τ @ρ @g
-      \\ apExtendSwap @_ @ℓ @(g τ) @(Map g ρ) @f @ϕ
+      \\ apExtendSwap @ℓ @(g τ) @(Map g ρ) @f @ϕ
 
 -- | A function to map over a record given no constraint.
 map' :: forall f r. FreeForall r => (forall a. a -> f a) -> Rec r -> Rec (Map f r)

Data/Row/Variants.hs

@@ -52,7 +52,7 @@ module Data.Row.Variants
   -- ** Map
   , Map, map, map', transform, transform'
   -- ** Fold
-  , Forall, erase, eraseWithLabels, eraseZip
+  , Forall, erase, eraseWithLabels, eraseZipGeneral, eraseZip
   -- ** Sequence
   , sequence
   -- ** Compose
@@ -109,14 +109,9 @@ instance Forall r Eq => Eq (Var r) where
 
 instance (Forall r Eq, Forall r Ord) => Ord (Var r) where
   compare :: Var r -> Var r -> Ordering
-  compare x y = getConst $ metamorph @_ @r @Ord @Either @(Product Var Var) @(Const Ordering) @(Const Ordering) Proxy doNil doUncons doCons (Pair x y)
-    where doNil (Pair x _) = impossible x
-          doUncons l (Pair r1 r2) = case (trial r1 l, trial r2 l) of
-            (Left a,  Left b)  -> Left $ Const $ compare a b
-            (Left _,  Right _) -> Left $ Const LT
-            (Right _, Left _)  -> Left $ Const GT
-            (Right x, Right y) -> Right $ Pair x y
-          doCons _ = Const . either getConst getConst
+  compare = eraseZipGeneral @Ord @r @Ordering @Text $ \case
+    (Left (_, x, y))           -> compare x y
+    (Right ((s1, _), (s2, _))) -> compare s1 s2
 
 instance Forall r NFData => NFData (Var r) where
   rnf r = getConst $ metamorph @_ @r @NFData @Either @Var @(Const ()) @Identity Proxy empty doUncons doCons r
@@ -240,18 +235,48 @@ eraseWithLabels f = getConst . metamorph @_ @ρ @c @Either @Var @(Const (s,b)) @
         doCons l (Left (Identity x)) = Const (show' l, f x)
         doCons _ (Right (Const c)) = Const c
 
--- | A fold over two row type structures at once
+
+data ErasedVal c s = forall y. c y => ErasedVal (s, y)
+data ErasePair c s ρ = ErasePair (Either (ErasedVal c s) (Var ρ)) (Either (ErasedVal c s) (Var ρ))
+
+-- | A fold over two variants at once.  A call `eraseZipGeneral f x y` will return
+-- `f (Left (show l, a, b))` when `x` and `y` both have values at the same label `l`
+-- and will return `f (Right ((show l1, a), (show l2, b)))` when they have values
+-- at different labels `l1` and `l2` respectively.
+eraseZipGeneral
+  :: forall c ρ b s. (Forall ρ c, IsString s)
+  => (forall x y. (c x, c y) => Either (s, x, x) ((s, x), (s, y)) -> b)
+  -> Var ρ -> Var ρ -> b
+eraseZipGeneral f x y = getConst $ metamorph @_ @ρ @c @Either @(ErasePair c s) @(Const b) @(Const b) Proxy doNil doUncons doCons (ErasePair (Right x) (Right y))
+  where
+    doNil (ErasePair (Left (ErasedVal a)) (Left (ErasedVal b))) =
+      Const $ f $ Right (a, b)
+    doNil (ErasePair (Right x) _) = impossible x
+    doNil (ErasePair _ (Right y)) = impossible y
+    doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ)
+             => Label ℓ -> ErasePair c s ρ -> Either (Const b τ) (ErasePair c s (ρ .- ℓ))
+    doUncons _ (ErasePair (Left (ErasedVal a)) (Left (ErasedVal b))) =
+      Left $ Const $ f $ Right (a, b)
+    doUncons l (ErasePair (Right x) (Left eb)) = case (trial x l, eb) of
+      (Left a, ErasedVal b) -> Left $ Const $ f $ Right ((show' l, a), b)
+      (Right x', _)         -> Right $ ErasePair (Right x') (Left eb)
+    doUncons l (ErasePair (Left ea) (Right y)) = case (ea, trial y l) of
+      (ErasedVal a, Left b) -> Left $ Const $ f $ Right (a, (show' l, b))
+      (_, Right x')         -> Right $ ErasePair (Left ea) (Right x')
+    doUncons l (ErasePair (Right x) (Right y)) = case (trial x l, trial y l) of
+      (Left (a :: x), Left b) -> Left $ Const $ f @x @x $ Left (show' l, a, b)
+      (Left a,   Right y')    -> Right $ ErasePair (Left $ ErasedVal (show' l, a)) (Right y')
+      (Right x', Left b)      -> Right $ ErasePair (Right x') (Left $ ErasedVal (show' l, b))
+      (Right x', Right y')    -> Right $ ErasePair (Right x') (Right y')
+    doCons _ (Left  (Const b)) = Const b
+    doCons _ (Right (Const b)) = Const b
+
+
+-- | A simpler fold over two variants at once
 eraseZip :: forall c ρ b. Forall ρ c => (forall a. c a => a -> a -> b) -> Var ρ -> Var ρ -> Maybe b
-eraseZip f x y = getConst $ metamorph @_ @ρ @c @Either @(Product Var Var) @(Const (Maybe b)) @(Const (Maybe b)) Proxy doNil doUncons doCons (Pair x y)
-  where doNil _ = Const Nothing
-        doUncons :: forall ℓ τ ρ. (KnownSymbol ℓ, c τ, HasType ℓ τ ρ)
-                 => Label ℓ -> Product Var Var ρ -> Either (Const (Maybe b) τ) (Product Var Var (ρ .- ℓ))
-        doUncons l (Pair r1 r2) = case (trial r1 l, trial r2 l) of
-          (Left a,  Left b)  -> Left $ Const $ Just $ f a b
-          (Right x, Right y) -> Right $ Pair x y
-          _ -> Left $ Const Nothing
-        doCons _ (Left  (Const c)) = Const c
-        doCons _ (Right (Const c)) = Const c
+eraseZip f = eraseZipGeneral @c @ρ @(Maybe b) @Text $ \case
+    Left (_,x,y) -> Just (f x y)
+    _            -> Nothing
 
 
 -- | VMap is used internally as a type level lambda for defining variant maps.
@@ -418,43 +443,24 @@ fromLabels mk = getCompose $ metamorph @_ @ρ @c @FlipConst @(Const ()) @(Compos
 newtype VApS x (fs :: Row (* -> *)) = VApS { unVApS :: Var (ApSingle fs x) }
 newtype FlipApp (x :: *) (f :: * -> *) = FlipApp (f x)
 
+-- | A version of 'erase' that works even when the row-type of the variant argument
+-- is of the form 'ApSingle fs x'.
 eraseSingle
   :: forall (c :: (* -> *) -> Constraint) (fs :: Row (* -> *)) (x :: *) (y :: *)
-   . (Forall fs c)
+   . Forall fs c
   => (forall f . (c f) => f x -> y)
   -> Var (ApSingle fs x)
   -> y
-eraseSingle f =
-  getConst
-    . metamorph @_ @fs @c @Either @(VApS x) @(Const y) @(FlipApp x)
-        Proxy
-        doNil
-        doUncons
-        doCons
-    . VApS
- where
-  doNil = impossible . unVApS
-
-  doUncons
-    :: forall l f fs
-      . ( c f
-        , fs .! l ≈ f
-        , KnownSymbol l
-        )
-    => Label l
-    -> VApS x fs
-    -> Either (FlipApp x f) (VApS x (fs .- l))
-  doUncons l = (FlipApp +++ VApS) . (flip trial l \\ apSingleHas @fs @l @f @x) . unVApS
-
-  doCons
-    :: forall l f fs
-     . (c f)
-    => Label l
-    -> Either (FlipApp x f) (Const y fs)
-    -> Const y (Extend l f fs)
-  doCons _ (Left (FlipApp v)) = Const (f v)
-  doCons _ (Right (Const  y)) = Const y
+eraseSingle f = erase @(ActsOn c x) @(ApSingle fs x) @y g
+  \\ apSingleForall @x @c @fs
+  where
+    g :: forall a. ActsOn c x a => a -> y
+    g a = case actsOn @c @x @a of As' -> f a
 
+-- | Performs a functorial-like map over an 'ApSingle' variant.
+-- In other words, it acts as a variant transformer to convert a variant of
+-- @f x@ values to a variant of @f y@ values.  If no constraint is needed,
+-- instantiate the first type argument with 'Unconstrained1'.
 mapSingle
   :: forall (c :: (* -> *) -> Constraint) (fs :: Row (* -> *)) (x :: *) (y :: *)
    . (Forall fs c)
@@ -473,15 +479,19 @@ mapSingle f = unVApS . metamorph @_ @fs @c @Either @(VApS x) @(VApS y) @(FlipApp
              . flip (trial \\ apSingleHas @fs @l @f @x) l
              . unVApS
 
-  doCons :: forall l f fs. (KnownSymbol l, c f)
+  doCons :: forall l f fs. (KnownSymbol l, c f, AllUniqueLabels (Extend l f fs))
          => Label l
          -> Either (FlipApp x f) (VApS y fs)
          -> VApS y (Extend l f fs)
-  doCons (toKey -> l) (Left (FlipApp x)) = VApS . OneOf l . HideType $ f x
-  doCons l (Right (VApS v)) = VApS $
-    extend @(f y) l v
-      \\ apSingleExtendSwap @_ @l @y @fs @f
-
+  doCons l (Left (FlipApp x)) = VApS $ IsJust l (f x)
+    \\ apSingleExtendSwap @l @y @fs @f
+    \\ extendHas @(ApSingle fs y) @l @(f y)
+    \\ uniqueApSingle @(Extend l f fs) @y
+  doCons l (Right (VApS v)) = VApS $ extend @(f y) l v
+    \\ apSingleExtendSwap @l @y @fs @f
+
+-- | A version of 'eraseZip' that works even when the row-types of the variant
+-- arguments are of the form 'ApSingle fs x'.
 eraseZipSingle :: forall c fs (x :: *) (y :: *) z
                 . (Forall fs c)
                => (forall f. c f => f x -> f y -> z)