constraints-extras 0.2.2.1 → 0.2.3.0
raw patch · 3 files changed
+107/−30 lines, 3 filesdep +aesondep +constraints-extrasdep +markdown-unlitdep ~basenew-component:exe:readmePVP ok
version bump matches the API change (PVP)
Dependencies added: aeson, constraints-extras, markdown-unlit
Dependency ranges changed: base
API changes (from Hackage documentation)
Files
- README.lhs +62/−0
- constraints-extras.cabal +13/−2
- src/Data/Constraint/Extras/TH.hs +32/−28
+ README.lhs view
@@ -0,0 +1,62 @@+# constraints-extras++## Example usage:++NB: This example can be built with `-pgmL markdown-unlit`.++```haskell+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ExistentialQuantification #-}++import Data.Aeson+import Data.Constraint.Forall+import Data.Constraint.Extras+import Data.Constraint.Extras.TH++data A :: * -> * where+ A_a :: A Int+ A_b :: Int -> A ()++data B :: * -> * where+ B_a :: A a -> A a -> B a+ B_x :: Int -> B Int++data V :: (* -> *) -> * where+ V_a :: A Int -> V A++deriveArgDict ''A+deriveArgDict ''B+deriveArgDictV ''V++data DSum k f = forall a. DSum (k a) (f a)++-- Derive a ToJSON instance for our 'DSum'+instance forall k f.+ ( Has' ToJSON k f -- Given a value of type (k a), we can obtain an instance (ToJSON (f a))+ , ForallF ToJSON k -- For any (a), we have an instance (ToJSON (k a))+ ) => ToJSON (DSum k f) where+ toJSON (DSum (k :: k a) f) = toJSON+ ( whichever @ToJSON @k @a $ toJSON k -- Use the (ForallF ToJSON k) constraint to obtain the (ToJSON (k a)) instance+ , has' @ToJSON @f k $ toJSON f -- Use the (Has' ToJSON k f) constraint to obtain the (ToJSON (f a)) instance+ )++data Some k = forall a. Some (k a)++-- Derive a FromJSON instance for our 'DSum'+instance (FromJSON (Some f), Has' FromJSON f g) => FromJSON (DSum f g) where+ parseJSON x = do+ (jf, jg) <- parseJSON x+ Some (f :: f a) <- parseJSON jf+ g <- has' @FromJSON @g f (parseJSON jg)+ return $ DSum f g++main :: IO ()+main = return ()+```
constraints-extras.cabal view
@@ -1,7 +1,8 @@ name: constraints-extras-version: 0.2.2.1+version: 0.2.3.0 synopsis: Utility package for constraints description: Convenience functions and TH for working with constraints. See <https://github.com/obsidiansystems/constraints-extras/blob/develop/README.md README.md> for example usage.+category: Constraints license: BSD3 license-file: LICENSE author: Cale Gibbard, Ali Abrar@@ -23,7 +24,17 @@ , constraints >= 0.9 && < 0.11 , template-haskell >=2.11 && <2.14 hs-source-dirs: src- default-language:Haskell2010+ default-language: Haskell2010++executable readme+ build-depends: base >=4.9 && <4.12+ , aeson+ , constraints >= 0.9 && < 0.11+ , constraints-extras+ , markdown-unlit+ main-is: README.lhs+ ghc-options: -pgmL markdown-unlit -Wall+ default-language: Haskell2010 source-repository head type: git
src/Data/Constraint/Extras/TH.hs view
@@ -25,13 +25,12 @@ l = length xs constraints = foldl AppT (TupleT l) xs constraints' = foldl AppT (TupleT l) xs'- {-- runIO $ putStrLn "Constraints:"- runIO . putStrLn . pprint $ constraints'- -}- [d| instance ArgDict $(pure $ ConT n) where- type ConstraintsFor $(conT n) $(varT c) = $(pure constraints)- type ConstraintsFor' $(conT n) $(varT c) $(varT g) = $(pure constraints')+ arity <- tyConArity n+ tyVars <- replicateM (arity - 1) (newName "a")+ let n' = foldr (\v x -> AppT x (VarT v)) (ConT n) tyVars+ [d| instance ArgDict $(pure n') where+ type ConstraintsFor $(pure n') $(varT c) = $(pure constraints)+ type ConstraintsFor' $(pure n') $(varT c) $(varT g) = $(pure constraints') argDict = $(LamCaseE <$> matches n 'argDict) argDict' = $(LamCaseE <$> matches n 'argDict') |]@@ -46,10 +45,6 @@ Right v -> AppT (VarT c) $ AppT v (VarT g) l = length xs constraints = foldl AppT (TupleT l) xs- {-- runIO $ putStrLn "Constraints:"- runIO . putStrLn . pprint $ constraints'- -} ds <- deriveArgDict n d <- [d| instance ArgDictV $(pure $ ConT n) where type ConstraintsForV $(conT n) $(varT c) $(varT g) = $(pure constraints)@@ -62,14 +57,12 @@ x <- newName "x" reify n >>= \case 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] _ _ -> return $ [Match (RecP name []) (NormalB $ ConE 'Dict) []]- ForallC _ _ (GadtC [name] bts (AppT (ConT _) (VarT b))) -> do+ ForallC _ _ (GadtC [name] bts (AppT _ (VarT b))) -> do ps <- forM bts $ \case- (_, AppT (ConT a) (VarT b')) | b == b' -> do- hasArgDictInstance <- not . null <$> reifyInstances ''ArgDict [(ConT a)]+ (_, AppT t (VarT b')) | b == b' -> do+ hasArgDictInstance <- not . null <$> reifyInstances ''ArgDict [t] return $ if hasArgDictInstance then Just x else Nothing@@ -89,17 +82,28 @@ a -> error $ "deriveArgDict matches: Unmatched 'Dec': " <> show a a -> error $ "deriveArgDict matches: Unmatched 'Info': " <> show a +kindArity :: Kind -> Int+kindArity = \case+ ForallT _ _ t -> kindArity t+ AppT (AppT ArrowT _) t -> 1 + kindArity t+ SigT t _ -> kindArity t+ ParensT t -> kindArity t+ _ -> 0++tyConArity :: Name -> Q Int+tyConArity n = reify n >>= return . \case+ TyConI (DataD _ _ ts mk _ _) -> fromMaybe 0 (fmap kindArity mk) + length ts+ _ -> error $ "tyConArity: Supplied name reified to something other than a data declaration: " <> show n+ gadtIndices :: Name -> Q [Either Type Type]-gadtIndices n = do- reify n >>= \case- TyConI (DataD _ _ _ _ cons _) -> fmap concat $ forM cons $ \x -> case x of- GadtC _ _ (AppT (ConT _) (VarT _)) -> return []- 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]+gadtIndices n = reify n >>= \case+ TyConI (DataD _ _ _ _ cons _) -> fmap concat $ forM cons $ \case+ GadtC _ _ (AppT _ typ) -> return [Right typ]+ ForallC _ _ (GadtC _ bts (AppT _ (VarT _))) -> fmap concat $ forM bts $ \case+ (_, AppT t (VarT _)) -> do+ hasArgDictInstance <- fmap (not . null) $ reifyInstances ''ArgDict [t]+ return $ if hasArgDictInstance then [Left t] else [] _ -> return []- a -> error $ "gadtResults: Unmatched 'Info': " <> show a+ ForallC _ _ (GadtC _ _ (AppT _ typ)) -> return [Right typ]+ _ -> return []+ a -> error $ "gadtResults: Unmatched 'Info': " <> show a