constraints-extras 0.2.1.0 → 0.2.2.0

raw patch · 2 files changed

+44/−18 lines, 2 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• constraints-extras.cabal +1/−1
• src/Data/Constraint/Extras/TH.hs +43/−17

@@ -1,5 +1,5 @@ name: constraints-extras-version: 0.2.1.0+version: 0.2.2.0 synopsis: Utility package for constraints license: BSD3 license-file: LICENSE

@@ -6,16 +6,22 @@ import Data.Constraint.Extras import Control.Monad import Data.Constraint-import Data.Semigroup+import Data.Maybe import Language.Haskell.TH +import Data.Either+ deriveArgDict :: Name -> Q [Dec] deriveArgDict n = do   ts <- gadtIndices n   c <- newName "c"   g <- newName "g"-  let xs = map (AppT (VarT c)) ts-      xs' = map (AppT (VarT c) . AppT (VarT g)) ts+  let xs = flip map ts $ \case+        Left t -> AppT (AppT (ConT ''ConstraintsFor) t) (VarT c)+        Right t -> (AppT (VarT c) t)+      xs' = flip map ts $ \case+        Left t -> AppT (AppT (AppT (ConT ''ConstraintsFor') t) (VarT c)) (VarT g)+        Right t -> AppT (VarT c) (AppT (VarT g) t)       l = length xs       constraints = foldl AppT (TupleT l) xs       constraints' = foldl AppT (TupleT l) xs'@@ -35,7 +41,9 @@   vs <- gadtIndices n   c <- newName "c"   g <- newName "g"-  let xs = map (\v -> AppT (VarT c) $ AppT v (VarT g)) vs+  let xs = flip map vs $ \case+        Left t -> AppT (AppT (AppT (ConT ''ConstraintsForV) t) (VarT c)) (VarT g)+        Right v -> AppT (VarT c) $ AppT v (VarT g)       l = length xs       constraints = foldl AppT (TupleT l) xs   {-@@ -53,27 +61,45 @@ matches n argDictName = do   x <- newName "x"   reify n >>= \case-    TyConI (DataD _ _ _ _ cons _) -> pure $ concat $ flip map cons $ \case-      GadtC [name] _ (AppT (ConT _) (VarT _)) ->+    TyConI (DataD _ _ _ _ cons _) -> fmap concat $ forM cons $ \case+      GadtC [name] _ (AppT (ConT _) (VarT _)) -> return $         [Match (ConP name [VarP x]) (NormalB $ AppE (VarE argDictName) (VarE x)) []]-      GadtC [name] _ _ ->+      GadtC [name] _ _ -> return $         [Match (RecP name []) (NormalB $ ConE 'Dict) []]-      ForallC _ _ (GadtC [name] _ (AppT (ConT _) (VarT _))) ->-        [Match (ConP name [VarP x]) (NormalB $ AppE (VarE argDictName) (VarE x)) []]-      ForallC _ _ (GadtC [name] _ _) ->+      ForallC _ _ (GadtC [name] bts (AppT (ConT _) (VarT b))) -> do+        ps <- forM bts $ \case+          (_, AppT (ConT a) (VarT b')) | b == b' -> do+            hasArgDictInstance <- not . null <$> reifyInstances ''ArgDict [(ConT a)]+            return $ if hasArgDictInstance+              then Just x+              else Nothing+          _ -> return Nothing+        return $ case catMaybes ps of+          [] -> [Match (RecP name []) (NormalB $ ConE 'Dict) []]+          (v:_) ->+            let patf = \v' rest done -> if done+                  then WildP : rest done+                  else case v' of+                    Nothing -> WildP : rest done+                    Just _ -> VarP v : rest True+                pat = foldr patf (const []) ps False+            in [Match (ConP name pat) (NormalB $ AppE (VarE argDictName) (VarE v)) []]+      ForallC _ _ (GadtC [name] _ _) -> return $         [Match (RecP name []) (NormalB $ ConE 'Dict) []]-      NormalC name [(_, AppT (ConT _) (VarT _))] ->-        [Match (ConP name [VarP x]) (NormalB $ AppE (VarE argDictName) (VarE x)) []]       a -> error $ "deriveArgDict matches: Unmatched 'Dec': " <> show a     a -> error $ "deriveArgDict matches: Unmatched 'Info': " <> show a -gadtIndices :: Name -> Q [Type]+gadtIndices :: Name -> Q [Either Type Type] gadtIndices n = do   reify n >>= \case-    TyConI (DataD _ _ _ _ cons _) -> fmap concat $ forM cons $ \case+    TyConI (DataD _ _ _ _ cons _) -> fmap concat $ forM cons $ \x -> case x of       GadtC _ _ (AppT (ConT _) (VarT _)) -> return []-      GadtC _ _ (AppT _ typ) -> return [typ]-      ForallC _ _ (GadtC _ _ (AppT (ConT _) (VarT _))) -> return []-      ForallC _ _ (GadtC _ _ (AppT _ typ)) -> return [typ]+      GadtC _ _ (AppT _ typ) -> return [Right typ]+      ForallC _ _ (GadtC _ bts (AppT (ConT _) (VarT _))) -> fmap concat $ forM bts $ \case+        (_, AppT (ConT a) (VarT _)) -> do+          hasArgDictInstance <- fmap (not . null) $ reifyInstances ''ArgDict [(ConT a)]+          return $ if hasArgDictInstance then [Left (ConT a)] else []+        _ -> return []+      ForallC _ _ (GadtC _ _ (AppT _ typ)) -> return [Right typ]       _ -> return []     a -> error $ "gadtResults: Unmatched 'Info': " <> show a