diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -1,22 +1,45 @@ -language: haskell -before_install: - # Uncomment whenever hackage is down. - # - mkdir -p ~/.cabal && cp travis/config ~/.cabal/config && cabal update - - cabal update +language: c +sudo: false - # Try installing some of the build-deps with apt-get for speed. - - travis/cabal-apt-install $mode +matrix: + include: + - env: CABALVER=1.16 GHCVER=7.4.2 + addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2], sources: [hvr-ghc]}} + - env: CABALVER=1.16 GHCVER=7.6.3 + addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3], sources: [hvr-ghc]}} + - env: CABALVER=1.18 GHCVER=7.8.4 + addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}} + - env: CABALVER=1.22 GHCVER=7.10.1 + addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.1],sources: [hvr-ghc]}} + - env: CABALVER=head GHCVER=head + addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} + allow_failures: + - env: CABALVER=head GHCVER=head + +before_install: + - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH + - export CABAL=cabal-$CABALVER + - $CABAL --version + install: - - cabal install packunused packdeps - - cabal configure $mode - - cabal build --ghc-options=-ddump-minimal-imports + - travis_retry $CABAL update + - $CABAL install "Cabal == $CABALVER.*" + - $CABAL install --enable-tests --only-dependencies script: - - $script - - packdeps bound.cabal - - packunused - - hlint src --cpp-define HLINT + - $CABAL configure -v2 --enable-tests + - $CABAL build + - $CABAL test + - $CABAL sdist + - export SRC_TGZ=$($CABAL info . | awk '{print $2 ".tar.gz";exit}') ; + cd dist/; + if [ -f "$SRC_TGZ" ]; then + $CABAL install "$SRC_TGZ"; + else + echo "expected '$SRC_TGZ' not found"; + exit 1; + fi notifications: irc: @@ -24,7 +47,4 @@ - "irc.freenode.org#haskell-lens" skip_join: true template: - - "\x0313bound\x03/\x0306%{branch}\x03 \x0314%{commit}\x03 %{build_url} %{message}" - -env: - - mode="--enable-tests" script="cabal test --show-details=always" + - "\x0313bound\x0f/\x0306%{branch}\x0f \x0314%{commit}\x0f %{message} \x0302\x1f%{build_url}\x0f" diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,8 @@ +1.0.7 +------ +* Added an `-f-template-haskell` option to allow disabling `template-haskell` support. This is an unsupported configuration but may be useful for expert users in sandbox configurations. +* Support `cereal` 0.5 + 1.0.6 ----- * Compiles warning-free on GHC 7.10 diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,7 +1,7 @@ Bound ===== -[![Build Status](https://secure.travis-ci.org/ekmett/bound.png?branch=master)](http://travis-ci.org/ekmett/bound) +[![Hackage](https://img.shields.io/hackage/v/bound.svg)](https://hackage.haskell.org/package/bound) [![Build Status](https://secure.travis-ci.org/ekmett/bound.png?branch=master)](http://travis-ci.org/ekmett/bound) Goals ----- diff --git a/bound.cabal b/bound.cabal --- a/bound.cabal +++ b/bound.cabal @@ -1,6 +1,6 @@ name: bound category: Language, Compilers/Interpreters -version: 1.0.6 +version: 1.0.7 license: BSD3 cabal-version: >= 1.9.2 license-file: LICENSE @@ -48,6 +48,14 @@ CHANGELOG.markdown AUTHORS.markdown +flag template-haskell + description: + You can disable the use of the `template-haskell` package using `-f-template-haskell`. + . + Disabling this is an unsupported configuration, but it may be useful for accelerating builds in sandboxes for expert users. + default: True + manual: True + source-repository head type: git location: git://github.com/ekmett/bound.git @@ -62,25 +70,30 @@ Bound.Scope Bound.Scope.Simple Bound.Term + Bound.TH Bound.Var build-depends: - base >= 4 && < 5, - bifunctors >= 3 && < 6, - binary >= 0.5 && < 0.8, - bytes >= 0.4 && < 1, - cereal >= 0.3.5.2 && < 0.5, - comonad >= 3 && < 5, - hashable >= 1.1 && < 1.3, - hashable-extras >= 0.1 && < 1, - prelude-extras >= 0.3 && < 1, - profunctors >= 3.3 && < 6, - transformers >= 0.2 && < 0.5 + base >= 4 && < 5, + bifunctors >= 3 && < 6, + binary >= 0.5 && < 0.8, + bytes >= 0.4 && < 1, + cereal >= 0.3.5.2 && < 0.6, + comonad >= 3 && < 5, + hashable >= 1.1 && < 1.3, + hashable-extras >= 0.1 && < 1, + prelude-extras >= 0.3 && < 1, + profunctors >= 3.3 && < 6, + template-haskell >= 2.7 && < 3, + transformers >= 0.2 && < 0.5 ghc-options: -Wall -O2 -fspec-constr -fdicts-cheap -funbox-strict-fields if impl(ghc >=7.4 && < 7.6) build-depends: ghc-prim + + if flag(template-haskell) && impl(ghc) + build-depends: template-haskell >= 2.7 && < 3.0 test-suite Simple type: exitcode-stdio-1.0 diff --git a/examples/Overkill.hs b/examples/Overkill.hs --- a/examples/Overkill.hs +++ b/examples/Overkill.hs @@ -1,14 +1,11 @@ -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE PolyKinds #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} + module Overkill where import Data.Vector as Vector hiding ((++), map) @@ -17,12 +14,10 @@ import Data.Traversable import Data.Monoid (Monoid(..)) import Control.Monad -import Control.Monad.Trans.Class import Control.Applicative import Prelude hiding (foldr) import Prelude.Extras -import GHC.Prim (Constraint(..)) -import Unsafe.Coerce +import Data.Type.Equality import Bound infixl 9 :@ @@ -41,10 +36,10 @@ data Index = VarI | WildI | AsI Index | ConI [Index] data Pat :: Index -> (* -> *) -> * -> * where - VarP :: Pat VarI f a - WildP :: Pat WildI f a - AsP :: Pat i f a -> Pat (AsI i) f a - ConP :: String -> Pats bs f a -> Pat (ConI bs) f a + VarP :: Pat 'VarI f a + WildP :: Pat 'WildI f a + AsP :: Pat i f a -> Pat ('AsI i) f a + ConP :: String -> Pats bs f a -> Pat ('ConI bs) f a ViewP :: f a -> Pat b f a -> Pat b f a -- TODO: allow references to earlier variables data Pats :: [Index] -> (* -> *) -> * -> * where @@ -52,10 +47,10 @@ (:>) :: Pat b f a -> Pats bs f a -> Pats (b ': bs) f a data Path :: Index -> * where - V :: Path VarI - L :: Path (AsI a) - R :: Path a -> Path (AsI a) - C :: MPath as -> Path (ConI as) + V :: Path 'VarI + L :: Path ('AsI a) + R :: Path a -> Path ('AsI a) + C :: MPath as -> Path ('ConI as) data MPath :: [Index] -> * where H :: Path a -> MPath (a ':as) @@ -88,7 +83,11 @@ instance Eq1 Exp where Var a ==# Var b = a == b (a :@ b) ==# (c :@ d) = a ==# c && b ==# d - Lam ps a ==# Lam qs b = eqPat ps qs && a ==# unsafeCoerce b -- eqPat proves equal shape + Lam ps a ==# Lam qs b = + case eqPat' ps qs of + Nothing -> False + Just Refl -> a ==# b + Let as a ==# Let bs b = as == bs && a ==# b _ ==# _ = False @@ -126,8 +125,8 @@ go :: [P a] -> Ps a go [] = Ps NilP [] (const Nothing) go (P p as f : xs) = case go xs of - Ps ps ass g -> Ps (p :> ps) (as ++ ass) $ \v -> - T <$> g v <|> H <$> f v + Ps ps' ass g' -> Ps (p :> ps') (as ++ ass) $ \v -> + T <$> g' v <|> H <$> f v -- * smart lam lam :: P a -> Exp a -> Exp a @@ -149,7 +148,23 @@ eqPat (AsP p) (AsP q) = eqPat p q eqPat (ConP g ps) (ConP h qs) = g == h && eqPats ps qs eqPat (ViewP e p) (ViewP f q) = e ==# f && eqPat p q +eqPat _ _ = False +-- The same as eqPat, but if the patterns are equal, it returns a +-- proof that their type arguments are the same. +eqPat' :: (Eq1 f, Eq a) => Pat b f a -> Pat b' f a -> Maybe (b :~: b') +eqPat' VarP VarP = Just Refl +eqPat' WildP WildP = Just Refl +eqPat' (AsP p) (AsP q) = do + Refl <- eqPat' p q + Just Refl +eqPat' (ConP g ps) (ConP h qs) = do + guard (g == h) + Refl <- eqPats' ps qs + Just Refl +eqPat' (ViewP e p) (ViewP f q) = guard (e ==# f) >> eqPat' p q +eqPat' _ _ = Nothing + instance Eq1 f => Eq1 (Pat b f) where (==#) = eqPat instance (Eq1 f, Eq a) => Eq (Pat b f a) where (==) = eqPat @@ -170,7 +185,7 @@ instance Foldable f => Foldable (Pat b f) where foldMap f (AsP p) = foldMap f p - foldMap f (ConP g ps) = foldMap f ps + foldMap f (ConP _g ps) = foldMap f ps foldMap f (ViewP e p) = foldMap f e `mappend` foldMap f p foldMap _ _ = mempty @@ -194,6 +209,16 @@ eqPats (p :> ps) (q :> qs) = eqPat p q && eqPats ps qs eqPats _ _ = False +-- Like eqPats, but if the patses are equal, it returns a proof that their +-- type arguments are the same. +eqPats' :: (Eq1 f, Eq a) => Pats bs f a -> Pats bs' f a -> Maybe (bs :~: bs') +eqPats' NilP NilP = Just Refl +eqPats' (p :> ps) (q :> qs) = do + Refl <- eqPat' p q + Refl <- eqPats' ps qs + Just Refl +eqPats' _ _ = Nothing + instance Eq1 f => Eq1 (Pats bs f) where (==#) = eqPats instance (Eq1 f, Eq a) => Eq (Pats bs f a) where (==) = eqPats @@ -212,7 +237,7 @@ foldMap _ _ = mempty instance Traversable f => Traversable (Pats bs f) where - traverse f NilP = pure NilP + traverse _f NilP = pure NilP traverse f (p :> ps) = (:>) <$> traverse f p <*> traverse f ps instance Bound (Pats bs) where @@ -220,19 +245,32 @@ (p :> ps) >>>= f = (p >>>= f) :> (ps >>>= f) -- ** Path into Pats +-- Internally, this is only used to implement eqPath, which is only +-- used to implement this. eqMPath :: MPath is -> MPath js -> Bool eqMPath (H m) (H n) = eqPath m n eqMPath (T p) (T q) = eqMPath p q eqMPath _ _ = False -instance Eq (MPath is) where (==) = eqMPath +instance Eq (MPath is) where + H m == H n = m == n + T p == T q = p == q + _ == _ = False + +-- Internally, this is only used to define comparePath, which +-- is only used here to define this. compareMPath :: MPath is -> MPath js -> Ordering compareMPath (H m) (H n) = comparePath m n compareMPath (H _) (T _) = LT compareMPath (T p) (T q) = compareMPath p q compareMPath (T _) (H _) = GT -instance Ord (MPath is) where compare = compareMPath +instance Ord (MPath is) where + compare (H m) (H n) = compare m n + compare (H _) (T _) = LT + compare (T p) (T q) = compare p q + compare (T _) (H _) = GT + instance Show (MPath is) where showsPrec d (H m) = showParen (d > 10) $ showString "H " . showsPrec 11 m showsPrec d (T p) = showParen (d > 10) $ showString "T " . showsPrec 11 p @@ -240,6 +278,8 @@ -- instance Read (MPath is) -- ** Path into Pat +-- Internally, this is only used to implement eqMPath, which is only used +-- to implement this. eqPath :: Path i -> Path j -> Bool eqPath V V = True eqPath L L = True @@ -247,8 +287,13 @@ eqPath (C p) (C q) = eqMPath p q eqPath _ _ = False -instance Eq (Path i) where (==) = eqPath +instance Eq (Path i) where + p == q = case compare p q of + EQ -> True + _ -> False +-- Internally, this is only used to define compareMPath, which +-- is only used here to define this. comparePath :: Path i -> Path j -> Ordering comparePath V V = EQ comparePath V _ = LT @@ -263,12 +308,21 @@ comparePath (C _) _ = GT instance Ord (Path i) where - compare V V = EQ - compare L L = EQ - compare L _ = LT - compare (R _) L = GT - compare (R m) (R n) = compare m n - compare (C p) (C q) = compare p q + compare V y = case (y :: Path 'VarI) of V -> EQ + compare L y = cpL y + where + cpL :: Path ('AsI a) -> Ordering + cpL L = EQ + cpL (R _) = LT + compare (R r) y = cpR r y + where + cpR :: Path a -> Path ('AsI a) -> Ordering + cpR _ L = GT + cpR m (R n) = compare m n + compare (C c) y = cpC c y + where + cpC :: MPath as -> Path ('ConI as) -> Ordering + cpC p (C q) = compare p q instance Show (Path i) where showsPrec _ V = showString "V" diff --git a/src/Bound.hs b/src/Bound.hs --- a/src/Bound.hs +++ b/src/Bound.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Copyright : (C) 2012 Edward Kmett @@ -89,7 +91,7 @@ -- (1) /Simple.hs/ provides an untyped lambda calculus with recursive let -- bindings and includes an evaluator for the untyped lambda calculus and a -- longer example taken from Lennart Augustsson's "λ-calculus cooked four --- ways" available from +-- ways" available from -- -- 2. /Derived.hs/ shows how much of the API can be automated with -- DeriveTraversable and adds combinators for building binders that support @@ -119,9 +121,14 @@ , Var(..) , fromScope , toScope + -- * Deriving instances + , makeBound ) where import Bound.Var import Bound.Class import Bound.Scope import Bound.Term +#ifdef MIN_VERSION_template_haskell +import Bound.TH +#endif diff --git a/src/Bound/Scope.hs b/src/Bound/Scope.hs --- a/src/Bound/Scope.hs +++ b/src/Bound/Scope.hs @@ -137,7 +137,7 @@ {-# INLINE traverse #-} instance (Functor f, Monad f) => Applicative (Scope b f) where - pure = return + pure a = Scope (return (F (return a))) {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} @@ -145,8 +145,10 @@ -- | The monad permits substitution on free variables, while preserving -- bound variables instance Monad f => Monad (Scope b f) where +#if __GLASGOW_HASKELL__ < 710 return a = Scope (return (F (return a))) {-# INLINE return #-} +#endif Scope e >>= f = Scope $ e >>= \v -> case v of B b -> return (B b) F ea -> ea >>= unscope . f @@ -318,8 +320,7 @@ liftMScope f g (Scope s) = Scope $ liftM (bimap f (liftM g)) s {-# INLINE liftMScope #-} --- | Obtain a result by collecting information from both bound and free --- variables +-- | Obtain a result by collecting information from bound variables foldMapBound :: (Foldable f, Monoid r) => (b -> r) -> Scope b f a -> r foldMapBound f (Scope s) = foldMap f' s where f' (B a) = f a diff --git a/src/Bound/Scope/Simple.hs b/src/Bound/Scope/Simple.hs --- a/src/Bound/Scope/Simple.hs +++ b/src/Bound/Scope/Simple.hs @@ -129,7 +129,7 @@ {-# INLINE traverse #-} instance (Functor f, Monad f) => Applicative (Scope b f) where - pure = return + pure a = Scope (return (F a)) {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} @@ -137,8 +137,10 @@ -- | The monad permits substitution on free variables, while preserving -- bound variables instance Monad f => Monad (Scope b f) where +#if __GLASGOW_HASKELL__ < 710 return a = Scope (return (F a)) {-# INLINE return #-} +#endif Scope e >>= f = Scope $ e >>= \v -> case v of B b -> return (B b) F a -> unscope (f a) diff --git a/src/Bound/TH.hs b/src/Bound/TH.hs new file mode 100644 --- /dev/null +++ b/src/Bound/TH.hs @@ -0,0 +1,366 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- Copyright : (C) 2012-2013 Edward Kmett +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : Edward Kmett +-- Stability : experimental +-- Portability : portable +-- +-- This is a Template Haskell module for deriving 'Applicative' and +-- 'Monad' instances for data types. +---------------------------------------------------------------------------- + +module Bound.TH + ( +#ifdef MIN_VERSION_template_haskell + makeBound +#endif + ) where + +#ifdef MIN_VERSION_template_haskell +import Data.List (intercalate) +import Data.Traversable (for) +import Control.Monad (foldM) +import Bound.Class (Bound((>>>=))) +import Language.Haskell.TH +#if __GLASGOW_HASKELL__ < 710 +import Control.Applicative (Applicative, pure, (<*>)) +#endif + +-- | +-- Use to automatically derive 'Applicative' and 'Monad' instances for +-- your datatype. +-- +-- In GHC 7.10 or later the @DeriveAnyClass@ extension may be used to derive the 'Show1' and 'Read1' instances +-- +-- @ +-- {-# LANGUAGE DeriveAnyClass #-} +-- {-# LANGUAGE DeriveFunctor #-} +-- {-# LANGUAGE TemplateHaskell #-} +-- +-- import Bound (Scope, makeBound) +-- import Prelude.Extras (Read1, Show1) +-- +-- data Exp a +-- = V a +-- | App (Exp a) (Exp a) +-- | Lam (Scope () Exp a) +-- | I Int +-- deriving (Functor, Read, Read1, Show, Show1) +-- +-- makeBound ''Exp +-- @ +-- +-- and in GHCi +-- +-- @ +-- ghci> :set -XDeriveAnyClass +-- ghci> :set -XDeriveFunctor +-- ghci> :set -XTemplateHaskell +-- ghci> import Bound (Scope, makeBound) +-- ghci> import Prelude.Extras (Read1, Show1) +-- ghci> data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | I Int deriving (Functor, Read, Read1, Show, Show1); makeBound ''Exp +-- @ +-- +-- or +-- +-- @ +-- ghci> :{ +-- ghci| data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | I Int deriving (Functor, Read, Read1, Show, Show1) +-- ghci| makeBound ''Exp +-- ghci| :} +-- +-- If @DeriveAnyClass@ is not used the instances must be declared explicitly: +-- +-- @ +-- data Exp a +-- = V a +-- | App (Exp a) (Exp a) +-- | Lam (Scope () Exp a) +-- | I Int +-- deriving (Functor, Read, Show) +-- instance Read1 Exp +-- instance Show1 Exp +-- +-- makeBound ''Exp +-- @ +-- +-- or in GHCi: +-- +-- @ +-- ghci> :{ +-- ghci| data Exp a = V a | App (Exp a) (Exp a) | Lam (Scope () Exp a) | I Int deriving (Functor, Read, Show) +-- ghci| instance Read1 Exp +-- ghci| instance Show1 Exp +-- ghci| makeBound ''Exp +-- ghci| :} +-- @ +-- +-- 'Eq' and 'Ord' instances need to be derived differently if the data +-- type's immediate components include 'Scope' (or other instances of +-- 'Bound') +-- +-- In a file with @{-# LANGUAGE StandaloneDeriving #-}@ at the top: +-- +-- @ +-- instance Eq1 Exp +-- deriving instance Eq a => Eq (Exp a) +-- +-- instance Ord1 Exp +-- deriving instance Ord a => Ord (Exp a) +-- @ +-- +-- or in GHCi: +-- +-- @ +-- ghci> :set -XStandaloneDeriving +-- ghci> deriving instance Eq a => Eq (Exp a); instance Eq1 Exp +-- ghci> deriving instance Ord a => Ord (Exp a); instance Ord1 Exp +-- @ +-- +-- because their 'Eq' and 'Ord' instances require @Exp@ to be a 'Monad': +-- +-- @ +-- instance (Monad f, Eq b, Eq1 f, Eq a) => Eq (Scope b f a) +-- instance (Monad f, Ord b, Ord1 f, Ord a) => Ord (Scope b f a) +-- @ +-- +-- Does not work yet for components that are lists or instances of +-- 'Functor' or with a great deal other things. + +makeBound :: Name -> DecsQ +makeBound name = do + let var :: ExpQ + var = ConE `fmap` getPure name + + bind :: ExpQ + bind = constructBind name + +#if __GLASGOW_HASKELL__ < 708 + def :: Name -> DecQ -> [DecQ] +#if __GLASGOW_HASKELL__ < 706 + def _theName dec = [dec] +#else + def theName dec = [pragInlD theName Inline FunLike AllPhases, dec] +#endif + + pureBody :: Name -> [DecQ] + pureBody pure'or'return = + def pure'or'return + (valD (varP pure'or'return) (normalB var) []) + + bindBody :: [DecQ] + bindBody = + def '(>>=) + (valD (varP '(>>=)) (normalB bind) []) + + apBody <- do + ff <- newName "ff" + fy <- newName "fy" + f <- newName "f" + y <- newName "y" + + -- \ff fy -> do + -- f <- ff + -- y <- fy + -- pure (f x) + let ap :: ExpQ + ap = lamE [varP ff, varP fy] (doE + [bindS (varP f) (varE ff), + bindS (varP y) (varE fy), + noBindS (varE 'pure `appE` (varE f `appE` varE y))]) + + pure (def '(<*>) (valD (varP '(<*>)) (normalB ap) [])) + + -- instance Applicative $name where + -- pure = $var + -- (<*>) = \ff fy -> do + -- f <- ff + -- y <- fy + -- pure (f y) + applicative <- + instanceD (cxt []) (appT (conT ''Applicative) (conT name)) + (pureBody 'pure ++ apBody) + + -- instance Monad $name where + -- return = $var + -- (>>=) = $bind + monad <- + instanceD (cxt []) (appT (conT ''Monad) (conT name)) + (pureBody 'return ++ bindBody) + + pure [applicative, monad] +#else + [d| instance Applicative $(conT name) where + pure = $var + {-# INLINE pure #-} + + ff <*> fy = do + f <- ff + y <- fy + pure (f y) + {-# INLINE (<*>) #-} + + instance Monad $(conT name) where +# if __GLASGOW_HASKELL__ < 710 + return = $var + {-# INLINE return #-} +# endif + + (>>=) = $bind + {-# INLINE (>>=) #-} + |] +#endif + +-- Internals +data Prop + = Bound + | Konst + | Exp + deriving Show + +data Components + = Component Name [(Name, Prop)] + | Variable Name + deriving Show + +constructBind :: Name -> ExpQ +constructBind name = do + TyConI dec <- reify name + + interpret =<< construct dec + +construct :: Dec -> Q [Components] +construct (DataD _ name tyvar constructors _) = do + var <- getPure name + for constructors $ \con -> do + case con of + NormalC conName [(_, _)] + | conName == var + -> pure (Variable conName) + NormalC conName types + -> Component conName `fmap` mapM typeToBnd [ ty | (_, ty) <- types ] + RecC conName types + -> Component conName `fmap` mapM typeToBnd [ ty | (_, _, ty) <- types ] + InfixC (_, a) conName (_, b) + -> do + bndA <- typeToBnd a + bndB <- typeToBnd b + pure (Component conName [bndA, bndB]) + ForallC{} -> error "Not implemented." + + where + expa :: Type + expa = ConT name `AppT` VarT (getName (last tyvar)) + + typeToBnd :: Type -> Q (Name, Prop) + typeToBnd ty = do + boundInstance <- isBound ty + var <- newName "var" + pure $ + case () of () + | ty == expa -> (var, Exp) + | boundInstance -> (var, Bound) + | ConT{} <- ty -> (var, Konst) + | otherwise -> error $ "This is bad: " + ++ show ty + ++ " " + ++ show boundInstance + + -- Checks whether a type is an instance of Bound by stripping its last + -- two type arguments: + -- isBound (Scope () EXP a) + -- -> isInstance ''Bound [Scope ()] + -- -> True + isBound :: Type -> Q Bool + isBound ty + | Just a <- stripLast2 ty = isInstance ''Bound [a] + | otherwise = return False +construct _ = error "Must be a data type." + +interpret :: [Components] -> ExpQ +interpret bnds = do + x <- newName "x" + f <- newName "f" + + let + bind :: Components -> MatchQ + bind (Variable name) = do + a <- newName "a" + match + (conP name [varP a]) + (normalB (varE f `appE` varE a)) + [] + + bind (Component name bounds) = do + exprs <- foldM bindOne (ConE name) bounds + pure $ + Match + (ConP name [ VarP arg | (arg, _) <- bounds ]) + (NormalB + exprs) + [] + + bindOne :: Exp -> (Name, Prop) -> Q Exp + bindOne expr (name, bnd) = case bnd of + Bound -> + pure expr `appE` (varE '(>>>=) `appE` varE name `appE` varE f) + Konst -> + pure expr `appE` varE name + Exp -> + pure expr `appE` (varE '(>>=) `appE` varE name `appE` varE f) + + matches <- for bnds bind + pure $ LamE [VarP x, VarP f] (CaseE (VarE x) matches) + +stripLast2 :: Type -> Maybe Type +stripLast2 (a `AppT` b `AppT` _ `AppT` d) + | AppT{} <- d = Nothing + | otherwise = Just (a `AppT` b) +stripLast2 _ = Nothing + +getName :: TyVarBndr -> Name +getName (PlainTV name) = name +getName (KindedTV name _) = name + +-- Returns candidate +getPure :: Name -> Q Name +getPure name = do + TyConI (DataD _ _ tyvr cons _) <- reify name + + let + findReturn :: Type -> [(Name, [Type])] -> Name + findReturn ty constrs = + case [ constr | (constr, [ty']) <- constrs, ty' == ty ] of + [] -> error "Too few candidates for a variable constructor." + [x] -> x + -- data Exp a = Var1 a | Var2 a | ... + -- result in + -- Too many candidates: Var1, Var2 + xs -> error ("Too many candidates: " ++ intercalate ", " (map pprint xs)) + + -- Gets the last type variable, given 'data Exp a b c = ...' + -- + -- lastTyVar = c + lastTyVar :: Type + lastTyVar = VarT (last (map getName tyvr)) + + allTypeArgs :: Con -> (Name, [Type]) + allTypeArgs con = case con of + NormalC conName tys -> + (conName, [ ty | (_, ty) <- tys ]) + RecC conName tys -> + (conName, [ ty | (_, _, ty) <- tys ]) + InfixC (_, t1) conName (_, t2) -> + (conName, [ t1, t2 ]) + ForallC _ _ conName -> + allTypeArgs conName + + return (findReturn lastTyVar (allTypeArgs `fmap` cons)) +#else +#endif diff --git a/src/Bound/Var.hs b/src/Bound/Var.hs --- a/src/Bound/Var.hs +++ b/src/Bound/Var.hs @@ -181,7 +181,7 @@ {-# INLINE (<*>) #-} instance Monad (Var b) where - return = F + return = pure {-# INLINE return #-} F a >>= f = f a B b >>= _ = B b