diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (C) 2013 Ryan Trinkle + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,33 @@ +## superconstraints + +A way of inferring instance constraints given an instance. + +Suppose you have a class like this: + +```haskell +class C a + +instance C a => C [a] +``` + +Normally, given `C [a]`, you cannot obtain `C a`; however, superconstraints allows you to add that capability: + +```haskell +class HasSuper (C a) => C a + +instance C a => C [a] +makeSuper "C [a]" +``` + +Then, you can retrieve the superconstraint by doing: + +```haskell +case super (Proxy :: Proxy (C [a])) of + Dict -> ... +``` + +The superconstraint dictionary will include all of the constraints required by the instance. + +### Future Improvements + +* Replace the crazy string argument to `makeSuper` with something more sensible diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Data/Constraint/Super.hs b/src/Data/Constraint/Super.hs new file mode 100644 --- /dev/null +++ b/src/Data/Constraint/Super.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TypeFamilies, ConstraintKinds, Rank2Types, TypeOperators, ScopedTypeVariables, GADTs, TemplateHaskell, LambdaCase #-} +module Data.Constraint.Super where + +import Data.Proxy (Proxy) +import Data.Constraint (Constraint, Dict (Dict), (:-) (Sub)) +import Control.Monad (filterM) +import Control.Applicative ((<$>)) +import Data.Data (Data, gmapM) +import Type.Eq ((:~:) (Eq), dynamicEq) +import Data.Map (Map) +import qualified Data.Map as Map +import Control.Monad.State (StateT, evalStateT, get, put, lift) +import Language.Haskell.Meta.Parse (parseType) + +import Language.Haskell.TH.Syntax hiding (lift) + +class HasSuper c where + type Super c :: Constraint + instantiate :: HasSuper c :- c + super :: Proxy c -> Dict (Super c) + +normalizeInstanceHead :: Type -> Q Type +normalizeInstanceHead t = do + let f :: forall d. Data d => d -> StateT (Integer, Map String Name) Q d + f x = case dynamicEq :: Maybe (d :~: Name) of + Just Eq -> + let b = nameBase x + in lift (qLookupName True b) >>= \case + Just n' -> return n' + Nothing -> do + (nextId, m) <- get + case Map.lookup b m of + Just n' -> return n' + Nothing -> do + let n' = mkName $ "a" ++ show nextId + put (succ nextId, Map.insert b n' m) + return n' + _ -> case dynamicEq :: Maybe (d :~: Type) of + Just Eq + | ConT n' <- x + , nameBase n' == "()" + -> return $ TupleT 0 + _ -> gmapM f x + evalStateT (gmapM f t) (1, Map.empty) + +getClassName :: Type -> Maybe Name +getClassName = \case + ConT n -> Just n + AppT t _ -> getClassName t + _ -> Nothing + +-- | Note: this is not compatible with PolyKinds +makeSuper :: String -> Q [Dec] +makeSuper tStr = case parseType tStr of + Left s -> fail $ "Error: Could not parse instance head: " ++ s + Right t -> do + t' <- normalizeInstanceHead t + case getClassName t' of + Nothing -> fail $ "Error: Instance head must be of the form \"ClassName (t1) (t2) (t3)...\"" + Just className -> do + qReify className >>= \case + ClassI _ instances -> do + filterM (\(InstanceD _ _ t2 _) -> (==t') <$> normalizeInstanceHead t2) instances >>= \x -> case x of + [InstanceD _ cxt t2 _] -> return + [InstanceD Nothing cxt (AppT (ConT ''HasSuper) t2) + [ TySynInstD ''Super $ TySynEqn [t2] $ foldl AppT (TupleT $ length cxt) cxt + , FunD 'super [Clause [WildP] (NormalB (ConE 'Dict)) []] + , FunD 'instantiate [Clause [] (NormalB (AppE (ConE 'Sub) (ConE 'Dict))) []] + ] + ] + [] -> fail "Error: No matching instances found" + _ -> fail "Error: Found multiple instances" + _ -> fail $ "Error: " ++ show className ++ " is not a typeclass" diff --git a/superconstraints.cabal b/superconstraints.cabal new file mode 100644 --- /dev/null +++ b/superconstraints.cabal @@ -0,0 +1,47 @@ +name: superconstraints +category: Constraints +version: 0.0.1 +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.10 +author: Ryan Trinkle +maintainer: Ryan Trinkle = 4.9.1 && < 4.10 + , constraints >= 0.9.1 && < 0.10 + , template-haskell >= 2.11.1 && < 2.12 + , haskell-src-meta >= 0.7.0.1 && < 0.8 + , mtl >= 2.2.1 && < 2.3 + , containers >= 0.5.7.1 && < 0.6 + , type-eq >= 0.5 && < 0.6 + , tagged >= 0.8.5 && < 0.9 + exposed-modules: + Data.Constraint.Super + + ghc-options: -Wall