diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,15 @@ +0.11.2 (2022-05-25): + - Adjusted Applicative/Monad instances to avoid warnings on GHC 9.2 + due to + - Adjusted Alternative/MonadPlus similarly, though not strictly required. + - Adjusted the CPP version guard for importing Data.Monoid.(<>) + in Control.Unification.Types, to remove an unused-imports warning + on GHC 8.8 + - Relaxed upper bound on logict + +0.11.1.1 (2021-11-02): + - Added `Tested-With: GHC == 9.2.1` (didn't actually need to + nudge the upper bound on 'base', because it's already lenient) 0.11.1 (2021-02-24): - Migrating from TravisCI to GithubActions - Properly fixed the logict-0.7.1 issue. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,27 +1,7 @@ #!/usr/bin/env runhaskell --- Cf. --- -{-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-missing-signatures #-} module Main (main) where import Distribution.Simple -import Distribution.Simple.LocalBuildInfo (withPrograms) -import Distribution.Simple.Program (userSpecifyArgs) ----------------------------------------------------------------- --- | Define __HADDOCK__ when building documentation. main :: IO () -main = defaultMainWithHooks - $ simpleUserHooks `modify_haddockHook` \oldHH pkg lbi hooks flags -> do - - -- Call the old haddockHook with a modified LocalBuildInfo - (\lbi' -> oldHH pkg lbi' hooks flags) - $ lbi `modify_withPrograms` \oldWP -> - userSpecifyArgs "haddock" ["--optghc=-D__HADDOCK__"] oldWP - - -modify_haddockHook hooks f = hooks { haddockHook = f (haddockHook hooks) } -modify_withPrograms lbi f = lbi { withPrograms = f (withPrograms lbi) } - ----------------------------------------------------------------- ------------------------------------------------------------ fin. +main = defaultMain diff --git a/src/Control/Monad/EitherK.hs b/src/Control/Monad/EitherK.hs --- a/src/Control/Monad/EitherK.hs +++ b/src/Control/Monad/EitherK.hs @@ -2,20 +2,12 @@ -- mtl:Control.Monad.{Error,Except}.MonadError {-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses, FlexibleInstances #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} - --- HACK: in GHC 7.10, Haddock complains about unused imports; but, --- if we use CPP to avoid including them under Haddock, then it --- will fail! -#ifdef __HADDOCK__ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -#endif - ---------------------------------------------------------------- --- ~ 2015.03.29 +-- ~ 2021.11.07 -- | -- Module : Control.Monad.EitherK -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : semi-portable (CPP, Rank2Types, MPTCs, FlexibleInstances) -- @@ -46,7 +38,7 @@ import Control.Applicative (Applicative(..)) #endif import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus(..), ap) +import Control.Monad (MonadPlus(..)) import Control.Monad.Trans (MonadTrans(..)) #if (MIN_VERSION_mtl(2,2,1)) -- aka: transformers(0,4,1) @@ -116,34 +108,58 @@ {-# INLINE eitherK #-} eitherK left right m = case runEitherK m of - Left e -> left e - Right a -> right a + Left e -> left e + Right a -> right a instance Functor (EitherK e) where fmap f (EK m) = EK (\k -> m (k . f)) + x <$ EK m = EK (\k -> m (\_ -> k x)) instance Applicative (EitherK e) where - pure = return - (<*>) = ap - (*>) = (>>) - x <* y = x >>= \a -> y >> return a + pure x = EK (\k -> k x) + EK m <*> EK n = EK (\k -> m (\f -> n (k . f))) + EK m *> EK n = EK (\k -> m (\_ -> n k)) + EK m <* EK n = EK (\k -> m (\x -> n (\_ -> k x))) +-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. +-- Since ghc-9.2.1 we get a warning about providing any other +-- definition, and should instead define both 'pure' and @(*>)@ +-- directly, leaving 'return' and @(>>)@ as their defaults so they +-- can eventually be removed from the class. +-- +-- +-- However, base-4.16 (ghc-9.2.1) still uses the @m >> n = m >>= \_ -> n@ +-- default. In principle, that ought to compile down to the same +-- thing as our @(*>)@; however, there's a decent chance the case +-- analysis on @n@ won't get lifted out from under the lambdas, and +-- thus the default definition would loose the strictness of the +-- second argument. Therefore, we're going to keep defining @(>>)@ +-- until whatever future version of GHC actually removes it from +-- the class to make it a proper alias of @(*>)@. instance Monad (EitherK e) where - return a = EK (\k -> k a) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif + (>>) = (*>) EK m >>= f = EK (\k -> m (\a -> case f a of EK n -> n k)) -- Using case instead of let seems to improve performance -- considerably by removing excessive laziness. +-- TODO: is there anything to optimize over the default definitions +-- of 'some' and 'many'? instance (Monoid e) => Alternative (EitherK e) where - empty = mzero - (<|>) = mplus + empty = throwEitherK mempty + m <|> n = catchEitherK m $ \me -> + catchEitherK n $ \ne -> + throwEitherK $ me `mappend` ne -instance (Monoid e) => MonadPlus (EitherK e) where - mzero = throwEitherK mempty - m `mplus` n = catchEitherK m $ \me -> - catchEitherK n $ \ne -> - throwEitherK $ me `mappend` ne +instance (Monoid e) => MonadPlus (EitherK e) +#if (!(MIN_VERSION_base(4,8,0))) + where + mzero = empty + mplus = (<|>) +#endif instance MonadError e (EitherK e) where throwError = throwEitherK @@ -213,36 +229,43 @@ :: (Applicative m, Monad m) => EitherKT e m a -> (e -> EitherKT f m a) -> EitherKT f m a {-# INLINE catchEitherKT #-} -catchEitherKT m handler = EKT $ \k -> do - ea <- runEitherKT m +catchEitherKT m handler = EKT $ \k -> + runEitherKT m >>= \ea -> case ea of - Left e -> case handler e of EKT m' -> m' k - Right a -> k a + Left e -> case handler e of EKT n -> n k + Right a -> k a instance Functor (EitherKT e m) where fmap f (EKT m) = EKT (\k -> m (k . f)) + x <$ EKT m = EKT (\k -> m (\_ -> k x)) instance Applicative (EitherKT e m) where - pure = return - (<*>) = ap - (*>) = (>>) - x <* y = x >>= \a -> y >> return a + pure x = EKT (\k -> k x) + EKT m <*> EKT n = EKT (\k -> m (\f -> n (k . f))) + EKT m *> EKT n = EKT (\k -> m (\_ -> n k)) + EKT m <* EKT n = EKT (\k -> m (\x -> n (\_ -> k x))) instance Monad (EitherKT e m) where - return a = EKT (\k -> k a) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif + (>>) = (*>) EKT m >>= f = EKT (\k -> m (\a -> case f a of EKT n -> n k)) --- In order to define a @(<|>)@ which only requires @Applicative --- m@ we'd need a law @m (Either e a) -> Either (m e) (m a)@; or +-- In order to define a @(<|>)@ which only requires @Applicative m@ +-- we'd need a law @m (Either e a) -> Either (m e) (m a)@; or -- equivalently, we'd need to use a 2-CPS style. instance (Applicative m, Monad m, Monoid e) => Alternative (EitherKT e m) where - empty = mzero - (<|>) = mplus + empty = throwEitherKT mempty + m <|> n = catchEitherKT m (catchEitherKT n . (throwEitherKT .) . mappend) -instance (Applicative m, Monad m, Monoid e) => MonadPlus (EitherKT e m) where - mzero = throwEitherKT mempty - m `mplus` n = catchEitherKT m (catchEitherKT n . (throwEitherKT .) . mappend) +instance (Applicative m, Monad m, Monoid e) => MonadPlus (EitherKT e m) +#if (!(MIN_VERSION_base(4,8,0))) + where + mzero = empty + mplus = (<|>) +#endif instance (Applicative m, Monad m) => MonadError e (EitherKT e m) where throwError = throwEitherKT diff --git a/src/Control/Monad/MaybeK.hs b/src/Control/Monad/MaybeK.hs --- a/src/Control/Monad/MaybeK.hs +++ b/src/Control/Monad/MaybeK.hs @@ -1,20 +1,12 @@ -- The MPTCs is only for mtl:Control.Monad.Error.MonadError {-# LANGUAGE CPP, Rank2Types, MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} - --- HACK: in GHC 7.10, Haddock complains about unused imports; but, --- if we use CPP to avoid including them under Haddock, then it --- will fail! -#ifdef __HADDOCK__ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -#endif - ---------------------------------------------------------------- --- ~ 2015.03.29 +-- ~ 2021.11.07 -- | -- Module : Control.Monad.MaybeK -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : semi-portable (CPP, Rank2Types, MPTCs) -- @@ -45,7 +37,7 @@ import Control.Applicative (Applicative(..)) #endif import Control.Applicative (Alternative(..)) -import Control.Monad (MonadPlus(..), ap) +import Control.Monad (MonadPlus(..)) import Control.Monad.Trans (MonadTrans(..)) #if (MIN_VERSION_mtl(2,2,1)) -- aka: transformers(0,4,1) @@ -100,27 +92,49 @@ instance Functor MaybeK where fmap f (MK m) = MK (\k -> m (k . f)) + x <$ MK m = MK (\k -> m (\_ -> k x)) instance Applicative MaybeK where - pure = return - (<*>) = ap - (*>) = (>>) - x <* y = x >>= \a -> y >> return a + pure x = MK (\k -> k x) + MK m <*> MK n = MK (\k -> m (\f -> n (k . f))) + MK m *> MK n = MK (\k -> m (\_ -> n k)) + MK m <* MK n = MK (\k -> m (\x -> n (\_ -> k x))) +-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. +-- Since ghc-9.2.1 we get a warning about providing any other +-- definition, and should instead define both 'pure' and @(*>)@ +-- directly, leaving 'return' and @(>>)@ as their defaults so they +-- can eventually be removed from the class. +-- +-- +-- However, base-4.16 (ghc-9.2.1) still uses the @m >> n = m >>= \_ -> n@ +-- default. In principle, that ought to compile down to the same +-- thing as our @(*>)@; however, there's a decent chance the case +-- analysis on @n@ won't get lifted out from under the lambdas, and +-- thus the default definition would loose the strictness of the +-- second argument. Therefore, we're going to keep defining @(>>)@ +-- until whatever future version of GHC actually removes it from +-- the class to make it a proper alias of @(*>)@. instance Monad MaybeK where - return a = MK (\k -> k a) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif + (>>) = (*>) MK m >>= f = MK (\k -> m (\a -> case f a of MK n -> n k)) -- Using case instead of let seems to improve performance -- considerably by removing excessive laziness. -- This is non-commutative, but it's the same as Alternative Maybe. instance Alternative MaybeK where - empty = mzero - (<|>) = mplus + empty = MK (\_ -> Nothing) + m <|> n = maybeK n pure m -instance MonadPlus MaybeK where - mzero = MK (\_ -> Nothing) - m `mplus` n = maybeK n return m +instance MonadPlus MaybeK +#if (!(MIN_VERSION_base(4,8,0))) + where + mzero = empty + mplus = (<|>) +#endif instance MonadError () MaybeK where throwError _ = mzero @@ -176,40 +190,46 @@ instance Functor (MaybeKT m) where fmap f (MKT m) = MKT (\k -> m (k . f)) + x <$ MKT m = MKT (\k -> m (\_ -> k x)) instance Applicative (MaybeKT m) where - pure = return - (<*>) = ap - (*>) = (>>) - x <* y = x >>= \a -> y >> return a + pure x = MKT (\k -> k x) + MKT m <*> MKT n = MKT (\k -> m (\f -> n (k . f))) + MKT m *> MKT n = MKT (\k -> m (\_ -> n k)) + MKT m <* MKT n = MKT (\k -> m (\x -> n (\_ -> k x))) instance Monad (MaybeKT m) where - return a = MKT (\k -> k a) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif + (>>) = (*>) MKT m >>= f = MKT (\k -> m (\a -> case f a of MKT n -> n k)) --- In order to define a @(<|>)@ which only requires @Applicative --- m@ we'd need a law @m (Either e a) -> Either (m e) (m a)@; or +-- In order to define a @(<|>)@ which only requires @Applicative m@ +-- we'd need a law @m (Either e a) -> Either (m e) (m a)@; or -- equivalently, we'd need to use a 2-CPS style. instance (Applicative m, Monad m) => Alternative (MaybeKT m) where - empty = mzero - (<|>) = mplus - -instance (Applicative m, Monad m) => MonadPlus (MaybeKT m) where - mzero = MKT (\_ -> return Nothing) - - m `mplus` n = MKT $ \k -> do - mb <- runMaybeKT m + empty = MKT (\_ -> pure Nothing) + m <|> n = MKT $ \k -> + runMaybeKT m >>= \mb -> case mb of - Nothing -> case n of MKT n' -> n' k - Just a -> k a + Nothing -> case n of MKT n' -> n' k + Just a -> k a +instance (Applicative m, Monad m) => MonadPlus (MaybeKT m) +#if (!(MIN_VERSION_base(4,8,0))) + where + mzero = empty + mplus = (<|>) +#endif + instance (Applicative m, Monad m) => MonadError () (MaybeKT m) where throwError _ = mzero - catchError m f = MKT $ \k -> do - mb <- runMaybeKT m + catchError m f = MKT $ \k -> + runMaybeKT m >>= \mb -> case mb of - Nothing -> case f () of MKT n -> n k - Just a -> k a + Nothing -> case f () of MKT n -> n k + Just a -> k a instance MonadTrans MaybeKT where lift m = MKT (\k -> m >>= k) diff --git a/src/Control/Monad/State/UnificationExtras.hs b/src/Control/Monad/State/UnificationExtras.hs --- a/src/Control/Monad/State/UnificationExtras.hs +++ b/src/Control/Monad/State/UnificationExtras.hs @@ -1,12 +1,12 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- ~ 2011.07.05 +-- ~ 2021.10.17 -- | -- Module : Control.Monad.State.UnificationExtras --- Copyright : Copyright (c) 2008--2015 wren gayle romano +-- Copyright : Copyright (c) 2008--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : perpetually unstable -- Portability : semi-portable (MPTCs) -- @@ -46,7 +46,7 @@ liftReader = liftReaderT --- | A strict version of 'modify'. +-- | A strict version of 'Control.Monad.State.modify'. modify' :: (MonadState s m) => (s -> s) -> m () {-# INLINE modify' #-} modify' f = do diff --git a/src/Control/Unification.hs b/src/Control/Unification.hs --- a/src/Control/Unification.hs +++ b/src/Control/Unification.hs @@ -1,19 +1,12 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts #-} {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-name-shadowing #-} - --- HACK: in GHC 7.10, Haddock complains about unused imports; but, --- if we use CPP to avoid including them under Haddock, then it --- will fail! -#ifdef __HADDOCK__ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -#endif ---------------------------------------------------------------- --- ~ 2015.03.29 +-- ~ 2021.10.17 -- | -- Module : Control.Unification --- Copyright : Copyright (c) 2007--2015 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : experimental -- Portability : semi-portable (CPP, MPTCs, FlexibleContexts) -- @@ -44,7 +37,7 @@ , Unifiable(..) , Variable(..) , BindingMonad(..) - + -- * Operations on one term , getFreeVars , applyBindings @@ -53,7 +46,7 @@ -- unskolemize -- convert Skolemized variables to free variables -- skolemize -- convert free variables to Skolemized variables -- getSkolems -- compute the skolem variables in a term; helpful? - + -- * Operations on two terms -- ** Symbolic names , (===) @@ -66,7 +59,7 @@ , unify , unifyOccurs , subsumes - + -- * Operations on many terms , getFreeVarsAll , applyBindingsAll @@ -492,12 +485,12 @@ (UVar _, UTerm _ ) -> mzero (UTerm _, UVar _ ) -> mzero (UTerm tl, UTerm tr) -> match tl tr - + match tl tr = case zipMatch tl tr of Nothing -> mzero Just tlr -> mapM_ loop_ tlr - + loop_ (Left _) = return () -- success loop_ (Right (tl,tr)) = loop tl tr @@ -532,14 +525,14 @@ | x == ir -> return () -- success; no changes | otherwise -> lift mzero Nothing -> put $! IM.insert il ir xs - + (UVar _, UTerm _ ) -> lift mzero (UTerm _, UVar _ ) -> lift mzero (UTerm tl, UTerm tr) -> case zipMatch tl tr of Nothing -> lift mzero Just tlr -> mapM_ loop_ tlr - + loop_ (Left _) = return () -- success; no changes loop_ (Right (tl,tr)) = loop tl tr @@ -568,14 +561,14 @@ where {-# INLINE (=:) #-} v =: t = lift $ v `bindVar` t - + {-# INLINE acyclicBindVar #-} acyclicBindVar v t = do b <- lift $ v `occursIn` t if b then throwError $ occursFailure v t else v =: t - + -- TODO: cf todos in 'unify' loop tl0 tr0 = do tl0 <- lift $ semiprune tl0 @@ -602,7 +595,7 @@ vl =: tr0 return tr0 _ -> error _impossible_unifyOccurs - + (UVar vl, UTerm tr) -> do mtl <- lift $ lookupVar vl case mtl of @@ -614,7 +607,7 @@ vl =: t return tl0 _ -> error _impossible_unifyOccurs - + (UTerm tl, UVar vr) -> do mtr <- lift $ lookupVar vr case mtr of @@ -626,14 +619,14 @@ vr =: t return tr0 _ -> error _impossible_unifyOccurs - + (UTerm tl, UTerm tr) -> match tl tr - + match tl tr = case zipMatch tl tr of Nothing -> throwError $ mismatchFailure tl tr Just tlr -> UTerm <$> mapM loop_ tlr - + loop_ (Left t) = return t loop_ (Right (tl,tr)) = loop tl tr @@ -668,7 +661,7 @@ where {-# INLINE (=:) #-} v =: t = lift . lift $ v `bindVar` t - + -- TODO: would it be beneficial to manually fuse @x <- lift m; y <- lift n@ to @(x,y) <- lift (m;n)@ everywhere we can? loop tl0 tr0 = do tl0 <- lift . lift $ semiprune tl0 @@ -692,7 +685,7 @@ vl =: tr0 return tr0 _ -> error _impossible_unify - + (UVar vl, UTerm tr) -> do t <- do mtl <- lift . lift $ lookupVar vl @@ -704,7 +697,7 @@ _ -> error _impossible_unify vl =: t return tl0 - + (UTerm tl, UVar vr) -> do t <- do mtr <- lift . lift $ lookupVar vr @@ -716,14 +709,14 @@ _ -> error _impossible_unify vr =: t return tr0 - + (UTerm tl, UTerm tr) -> match tl tr - + match tl tr = case zipMatch tl tr of Nothing -> lift . throwError $ mismatchFailure tl tr Just tlr -> UTerm <$> mapM loop_ tlr - + loop_ (Left t) = return t loop_ (Right (tl,tr)) = loop tl tr @@ -770,7 +763,7 @@ where {-# INLINE (=:) #-} v =: t = lift . lift $ do v `bindVar` t ; return True - + -- TODO: cf todos in 'unify' loop tl0 tr0 = do tl0 <- lift . lift $ semiprune tl0 @@ -791,7 +784,7 @@ vr `seenAs` tr match tl tr _ -> error _impossible_subsumes - + (UVar vl, UTerm tr) -> do mtl <- lift . lift $ lookupVar vl case mtl of @@ -800,16 +793,16 @@ vl `seenAs` tl match tl tr _ -> error _impossible_subsumes - + (UTerm _, UVar _ ) -> return False - + (UTerm tl, UTerm tr) -> match tl tr - + match tl tr = case zipMatch tl tr of Nothing -> return False Just tlr -> and <$> mapM loop_ tlr -- TODO: use foldlM? - + loop_ (Left _) = return True loop_ (Right (tl,tr)) = loop tl tr diff --git a/src/Control/Unification/IntVar.hs b/src/Control/Unification/IntVar.hs --- a/src/Control/Unification/IntVar.hs +++ b/src/Control/Unification/IntVar.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE MultiParamTypeClasses +{-# LANGUAGE CPP + , MultiParamTypeClasses , FlexibleInstances , UndecidableInstances #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- ~ 2012.03.18 +-- ~ 2021.11.07 -- | -- Module : Control.Unification.IntVar --- Copyright : Copyright (c) 2007--2015 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : experimental -- Portability : semi-portable (MPTCs,...) -- @@ -111,26 +112,37 @@ -- BUG: can't reduce dependency to Applicative because of StateT's instance. instance (Functor m, Monad m) => Applicative (IntBindingT t m) where - pure = IBT . pure - x <*> y = IBT (unIBT x <*> unIBT y) - x *> y = IBT (unIBT x *> unIBT y) - x <* y = IBT (unIBT x <* unIBT y) + pure = IBT . pure + IBT m <*> IBT n = IBT (m <*> n) + IBT m *> IBT n = IBT (m *> n) + IBT m <* IBT n = IBT (m <* n) +-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. +-- Since ghc-9.2.1 we get a warning about providing any other +-- definition, and should instead define both 'pure' and @(*>)@ +-- directly, leaving 'return' and @(>>)@ as their defaults so they +-- can eventually be removed from the class. +-- instance (Monad m) => Monad (IntBindingT t m) where - return = IBT . return - m >>= f = IBT (unIBT m >>= unIBT . f) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif + IBT m >>= f = IBT (m >>= unIBT . f) instance MonadTrans (IntBindingT t) where lift = IBT . lift -- BUG: can't reduce dependency to Alternative because of StateT's instance. instance (Functor m, MonadPlus m) => Alternative (IntBindingT t m) where - empty = IBT empty - x <|> y = IBT (unIBT x <|> unIBT y) + empty = IBT empty + IBT x <|> IBT y = IBT (x <|> y) -instance (MonadPlus m) => MonadPlus (IntBindingT t m) where - mzero = IBT mzero - mplus ml mr = IBT (mplus (unIBT ml) (unIBT mr)) +instance (MonadPlus m) => MonadPlus (IntBindingT t m) +#if (!(MIN_VERSION_base(4,8,0))) + where + mzero = empty + mplus = (<|>) +#endif instance (Monad m) => MonadState (IntBindingState t) (IntBindingT t m) where get = IBT get @@ -145,13 +157,13 @@ where coerce Nothing = Nothing coerce (Just (a, m')) = Just (a, IBT m') - + interleave (IBT l) (IBT r) = IBT (interleave l r) - + IBT m >>- f = IBT (m >>- (unIBT . f)) - + ifte (IBT b) t (IBT f) = IBT (ifte b (unIBT . t) f) - + once (IBT m) = IBT (once m) ---------------------------------------------------------------- @@ -174,9 +186,9 @@ instance (Unifiable t, Applicative m, Monad m) => BindingMonad t IntVar (IntBindingT t m) where - + lookupVar (IntVar v) = IBT $ gets (IM.lookup v . varBindings) - + freeVar = IBT $ do ibs <- get let v = nextFreeVar ibs @@ -185,7 +197,7 @@ else do put $ ibs { nextFreeVar = v+1 } return $ IntVar v - + newVar t = IBT $ do ibs <- get let v = nextFreeVar ibs @@ -195,7 +207,7 @@ let bs' = IM.insert v t (varBindings ibs) put $ ibs { nextFreeVar = v+1, varBindings = bs' } return $ IntVar v - + bindVar (IntVar v) t = IBT $ do ibs <- get let bs' = IM.insert v t (varBindings ibs) diff --git a/src/Control/Unification/Ranked.hs b/src/Control/Unification/Ranked.hs --- a/src/Control/Unification/Ranked.hs +++ b/src/Control/Unification/Ranked.hs @@ -1,12 +1,12 @@ {-# LANGUAGE CPP, MultiParamTypeClasses, FlexibleContexts #-} {-# OPTIONS_GHC -Wall -fwarn-tabs -fno-warn-name-shadowing #-} ---------------------------------------------------------------- --- ~ 2015.03.29 +-- ~ 2021.10.17 -- | -- Module : Control.Unification.Ranked --- Copyright : Copyright (c) 2007--2015 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : highly experimental -- Portability : semi-portable (CPP, MPTCs, FlexibleContexts) -- @@ -19,7 +19,7 @@ ( -- * Data types, classes, etc module Control.Unification.Types - + -- * Operations on one term , getFreeVars , applyBindings @@ -28,7 +28,7 @@ -- unskolemize -- convert Skolemized variables to free variables -- skolemize -- convert free variables to Skolemized variables -- getSkolems -- compute the skolem variables in a term; helpful? - + -- * Operations on two terms -- ** Symbolic names , (===) @@ -41,7 +41,7 @@ , unify -- unifyOccurs -- subsumes - + -- * Operations on many terms , getFreeVarsAll , applyBindingsAll @@ -132,7 +132,7 @@ where {-# INLINE (=:) #-} v =: t = bindVar v t >> return t - + loop tl0 tr0 = do tl0 <- lift . lift $ semiprune tl0 tr0 <- lift . lift $ semiprune tr0 @@ -149,19 +149,19 @@ LT -> do { vl =: tr0 } EQ -> do { incrementRank vr ; vl =: tr0 } GT -> do { vr =: tl0 } - + (Nothing, Just tr) -> lift . lift $ case cmp of LT -> do { vl =: tr0 } EQ -> do { incrementRank vr ; vl =: tr0 } GT -> do { vl `bindVar` tr ; vr =: tl0 } - + (Just tl, Nothing) -> lift . lift $ case cmp of LT -> do { vr `bindVar` tl ; vl =: tr0 } EQ -> do { incrementRank vl ; vr =: tl0 } GT -> do { vr =: tl0 } - + (Just (UTerm tl), Just (UTerm tr)) -> do t <- localState $ do vl `seenAs` tl @@ -173,7 +173,7 @@ EQ -> do { incrementBindVar vl t ; vr =: tl0 } GT -> do { vl `bindVar` t ; vr =: tl0 } _ -> error _impossible_unify - + (UVar vl, UTerm tr) -> do t <- do mtl <- lift . lift $ lookupVar vl @@ -186,7 +186,7 @@ lift . lift $ do vl `bindVar` t return tl0 - + (UTerm tl, UVar vr) -> do t <- do mtr <- lift . lift $ lookupVar vr @@ -199,14 +199,14 @@ lift . lift $ do vr `bindVar` t return tr0 - + (UTerm tl, UTerm tr) -> match tl tr - + match tl tr = case zipMatch tl tr of Nothing -> lift . throwError $ mismatchFailure tl tr Just tlr -> UTerm <$> mapM loop_ tlr - + loop_ (Left t) = return t loop_ (Right (tl,tr)) = loop tl tr diff --git a/src/Control/Unification/Ranked/IntVar.hs b/src/Control/Unification/Ranked/IntVar.hs --- a/src/Control/Unification/Ranked/IntVar.hs +++ b/src/Control/Unification/Ranked/IntVar.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE MultiParamTypeClasses +{-# LANGUAGE CPP + , MultiParamTypeClasses , FlexibleInstances , UndecidableInstances #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- ~ 2012.03.18 +-- ~ 2021.11.07 -- | -- Module : Control.Unification.Ranked.IntVar --- Copyright : Copyright (c) 2007--2015 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : highly experimental -- Portability : semi-portable (MPTCs,...) -- @@ -70,14 +71,22 @@ -- N.B., it's not possible to reduce the dependency to Applicative. instance (Functor m, Monad m) => Applicative (IntRBindingT t m) where - pure = IRBT . pure - x <*> y = IRBT (unIRBT x <*> unIRBT y) - x *> y = IRBT (unIRBT x *> unIRBT y) - x <* y = IRBT (unIRBT x <* unIRBT y) + pure = IRBT . pure + IRBT m <*> IRBT n = IRBT (m <*> n) + IRBT m *> IRBT n = IRBT (m *> n) + IRBT m <* IRBT n = IRBT (m <* n) +-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. +-- Since ghc-9.2.1 we get a warning about providing any other +-- definition, and should instead define both 'pure' and @(*>)@ +-- directly, leaving 'return' and @(>>)@ as their defaults so they +-- can eventually be removed from the class. +-- instance (Monad m) => Monad (IntRBindingT t m) where - return = IRBT . return - m >>= f = IRBT (unIRBT m >>= unIRBT . f) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif + IRBT m >>= f = IRBT (m >>= unIRBT . f) instance MonadTrans (IntRBindingT t) where lift = IRBT . lift @@ -87,9 +96,12 @@ empty = IRBT empty x <|> y = IRBT (unIRBT x <|> unIRBT y) -instance (MonadPlus m) => MonadPlus (IntRBindingT t m) where - mzero = IRBT mzero - mplus ml mr = IRBT (mplus (unIRBT ml) (unIRBT mr)) +instance (MonadPlus m) => MonadPlus (IntRBindingT t m) +#if (!(MIN_VERSION_base(4,8,0))) + where + mzero = empty + mplus = (<|>) +#endif instance (Monad m) => MonadState (IntRBindingState t) (IntRBindingT t m) where get = IRBT get @@ -104,13 +116,13 @@ where coerce Nothing = Nothing coerce (Just (a, m')) = Just (a, IRBT m') - + interleave (IRBT l) (IRBT r) = IRBT (interleave l r) - + IRBT m >>- f = IRBT (m >>- (unIRBT . f)) - + ifte (IRBT b) t (IRBT f) = IRBT (ifte b (unIRBT . t) f) - + once (IRBT m) = IRBT (once m) ---------------------------------------------------------------- @@ -133,13 +145,13 @@ instance (Unifiable t, Applicative m, Monad m) => BindingMonad t IntVar (IntRBindingT t m) where - + lookupVar (IntVar v) = IRBT $ do mb <- gets (IM.lookup v . varBindings) case mb of Nothing -> return Nothing Just (Rank _ mb') -> return mb' - + freeVar = IRBT $ do ibs <- get let v = nextFreeVar ibs @@ -148,7 +160,7 @@ else do put $ ibs { nextFreeVar = v+1 } return $ IntVar v - + newVar t = IRBT $ do ibs <- get let v = nextFreeVar ibs @@ -158,14 +170,14 @@ let bs' = IM.insert v (Rank 0 (Just t)) (varBindings ibs) put $ ibs { nextFreeVar = v+1, varBindings = bs' } return $ IntVar v - + bindVar (IntVar v) t = IRBT $ do ibs <- get let bs' = IM.insertWith f v (Rank 0 (Just t)) (varBindings ibs) f (Rank _0 jt) (Rank r _) = Rank r jt put $ ibs { varBindings = bs' } - - + + instance (Unifiable t, Applicative m, Monad m) => RankedBindingMonad t IntVar (IntRBindingT t m) where @@ -174,13 +186,13 @@ case mb of Nothing -> return (Rank 0 Nothing) Just rk -> return rk - + incrementRank (IntVar v) = IRBT $ do ibs <- get let bs' = IM.insertWith f v (Rank 1 Nothing) (varBindings ibs) f (Rank _1 _n) (Rank r mb) = Rank (r+1) mb put $ ibs { varBindings = bs' } - + incrementBindVar (IntVar v) t = IRBT $ do ibs <- get let bs' = IM.insertWith f v (Rank 1 (Just t)) (varBindings ibs) diff --git a/src/Control/Unification/Ranked/STVar.hs b/src/Control/Unification/Ranked/STVar.hs --- a/src/Control/Unification/Ranked/STVar.hs +++ b/src/Control/Unification/Ranked/STVar.hs @@ -6,12 +6,12 @@ #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- ~ 2015.03.29 +-- ~ 2021.11.07 -- | -- Module : Control.Unification.Ranked.STVar --- Copyright : Copyright (c) 2007--2015 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : highly experimental -- Portability : semi-portable (Rank2Types, MPTCs,...) -- @@ -30,7 +30,6 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..)) #endif -import Control.Monad (ap) import Control.Monad.Trans (lift) import Control.Monad.ST import Control.Monad.Reader (ReaderT, runReaderT, ask) @@ -53,7 +52,7 @@ instance Eq (STRVar s t) where (STRVar i _ _) == (STRVar j _ _) = (i == j) - + instance Variable (STRVar s t) where getVarID (STRVar i _ _) = i @@ -76,8 +75,10 @@ -- such references. However, in order to remove the references from -- terms, you'll need to explicitly apply the bindings. runSTRBinding :: (forall s. STRBinding s a) -> a -runSTRBinding stb = - runST (newSTRef minBound >>= runReaderT (unSTRB stb)) +runSTRBinding m = + runST (newSTRef minBound >>= runReaderT (unSTRB m)) + -- N.B., because of the rank-2 quantification, cannot use the + -- 'STRB' pattern in lieu of 'unSTRB' here. -- For portability reasons, we're intentionally avoiding @@ -87,14 +88,22 @@ fmap f = STRB . fmap f . unSTRB instance Applicative (STRBinding s) where - pure = return - (<*>) = ap - (*>) = (>>) - x <* y = x >>= \a -> y >> return a + pure = STRB . pure + STRB m <*> STRB n = STRB (m <*> n) + STRB m *> STRB n = STRB (m *> n) + STRB m <* STRB n = STRB (m <* n) +-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. +-- Since ghc-9.2.1 we get a warning about providing any other +-- definition, and should instead define both 'pure' and @(*>)@ +-- directly, leaving 'return' and @(>>)@ as their defaults so they +-- can eventually be removed from the class. +-- instance Monad (STRBinding s) where - return = STRB . return - stb >>= f = STRB (unSTRB stb >>= unSTRB . f) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif + STRB m >>= f = STRB (m >>= unSTRB . f) ---------------------------------------------------------------- @@ -119,27 +128,27 @@ instance (Unifiable t) => BindingMonad t (STRVar s t) (STRBinding s) where lookupVar (STRVar _ _ p) = STRB . lift $ readSTRef p - + freeVar = _newSTRVar "freeVar" Nothing - + newVar t = _newSTRVar "newVar" (Just t) - + bindVar (STRVar _ _ p) t = STRB . lift $ writeSTRef p (Just t) instance (Unifiable t) => RankedBindingMonad t (STRVar s t) (STRBinding s) where - + lookupRankVar (STRVar _ r p) = STRB . lift $ do n <- readSTRef r mb <- readSTRef p return (Rank n mb) - + incrementRank (STRVar _ r _) = STRB . lift $ do n <- readSTRef r writeSTRef r $! n+1 - + -- incrementBindVar = default ---------------------------------------------------------------- diff --git a/src/Control/Unification/STVar.hs b/src/Control/Unification/STVar.hs --- a/src/Control/Unification/STVar.hs +++ b/src/Control/Unification/STVar.hs @@ -6,12 +6,12 @@ #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- ~ 2015.03.29 +-- ~ 2021.11.07 -- | -- Module : Control.Unification.STVar --- Copyright : Copyright (c) 2007--2015 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : experimental -- Portability : semi-portable (Rank2Types, MPTCs,...) -- @@ -30,7 +30,6 @@ #if __GLASGOW_HASKELL__ < 710 import Control.Applicative (Applicative(..), (<$>)) #endif -import Control.Monad (ap) import Control.Monad.Trans (lift) import Control.Monad.ST import Control.Monad.Reader (ReaderT, runReaderT, ask) @@ -77,6 +76,8 @@ runSTBinding :: (forall s. STBinding s a) -> a runSTBinding stb = runST (newSTRef minBound >>= runReaderT (unSTB stb)) + -- N.B., because of the rank-2 quantification, cannot use the + -- 'STB' pattern in lieu of 'unSTB' here. -- For portability reasons, we're intentionally avoiding @@ -86,14 +87,23 @@ fmap f = STB . fmap f . unSTB instance Applicative (STBinding s) where - pure = return - (<*>) = ap - (*>) = (>>) - x <* y = x >>= \a -> y >> return a + pure = STB . pure + STB m <*> STB n = STB (m <*> n) + STB m *> STB n = STB (m *> n) + STB m <* STB n = STB (m <* n) +-- Since base-4.8 (ghc-7.10.1) we have the default @return = pure@. +-- Since ghc-9.2.1 we get a warning about providing any other +-- definition, and should instead define both 'pure' and @(*>)@ +-- directly, leaving 'return' and @(>>)@ as their defaults so they +-- can eventually be removed from the class. +-- instance Monad (STBinding s) where - return = STB . return - stb >>= f = STB (unSTB stb >>= unSTB . f) +#if (!(MIN_VERSION_base(4,8,0))) + return = pure + (>>) = (*>) +#endif + STB m >>= f = STB (m >>= unSTB . f) ---------------------------------------------------------------- @@ -117,11 +127,11 @@ where lookupVar (STVar _ p) = STB . lift $ readSTRef p - + freeVar = _newSTVar "freeVar" Nothing - + newVar t = _newSTVar "newVar" (Just t) - + bindVar (STVar _ p) t = STB . lift $ writeSTRef p (Just t) ---------------------------------------------------------------- diff --git a/src/Control/Unification/Types.hs b/src/Control/Unification/Types.hs --- a/src/Control/Unification/Types.hs +++ b/src/Control/Unification/Types.hs @@ -19,20 +19,13 @@ #-} {-# OPTIONS_GHC -Wall -fwarn-tabs #-} --- HACK: in GHC 7.10, Haddock complains about unused imports; but, --- if we use CPP to avoid including them under Haddock, then it --- will fail! -#ifdef __HADDOCK__ -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -#endif - ---------------------------------------------------------------- --- ~ 2017.06.21 +-- ~ 2021.11.07 -- | -- Module : Control.Unification.Types --- Copyright : Copyright (c) 2007--2017 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : experimental -- Portability : semi-portable (MPTCs, fundeps,...) -- @@ -61,7 +54,7 @@ import Data.Word (Word8) import Data.Functor.Fixedpoint (Fix(..), unFix) -#if __GLASGOW_HASKELL__ < 810 +#if __GLASGOW_HASKELL__ < 804 import Data.Monoid ((<>)) #endif import Data.Traversable (Traversable(..)) @@ -128,7 +121,9 @@ -- building terms at least; though bind is inefficient for that. -- Should use the cheaper free... instance (Functor t) => Monad (UTerm t) where - return = UVar +#if (!(MIN_VERSION_base(4,8,0))) + return = pure +#endif UVar v >>= f = f v UTerm t >>= f = UTerm ((>>= f) <$> t) diff --git a/src/Data/Functor/Fixedpoint.hs b/src/Data/Functor/Fixedpoint.hs --- a/src/Data/Functor/Fixedpoint.hs +++ b/src/Data/Functor/Fixedpoint.hs @@ -24,12 +24,12 @@ {-# OPTIONS_GHC -Wall -fwarn-tabs #-} ---------------------------------------------------------------- --- 2014.05.28 +-- 2021.12.31 -- | -- Module : Data.Functor.Fixedpoint --- Copyright : Copyright (c) 2007--2015 wren gayle romano +-- Copyright : Copyright (c) 2007--2021 wren gayle romano -- License : BSD --- Maintainer : wren@community.haskell.org +-- Maintainer : wren@cpan.org -- Stability : provisional -- Portability : semi-portable (Rank2Types) -- @@ -101,14 +101,14 @@ instance (Show (f (Fix f))) => Show (Fix f) where showsPrec p (Fix f) = showsPrec p f +-- (2021.12.31): removed the definition of @(/=)@ for: +-- instance (Eq (f (Fix f))) => Eq (Fix f) where Fix x == Fix y = x == y - Fix x /= Fix y = x /= y -- BUGFIX: Inlining causes a code explosion on GHC 8.0.1 and 8.0.2, but -- will be fixed in 8.0.3. #if __GLASGOW_HASKELL__ == 800 {-# NOINLINE (==) #-} - {-# NOINLINE (/=) #-} #endif instance (Ord (f (Fix f))) => Ord (Fix f) where diff --git a/unification-fd.cabal b/unification-fd.cabal --- a/unification-fd.cabal +++ b/unification-fd.cabal @@ -1,5 +1,5 @@ ---------------------------------------------------------------- --- wren gayle romano ~ 2021.02.24 +-- wren gayle romano ~ 2022.05.25 ---------------------------------------------------------------- -- Hackage requires us to require Cabal-Version >=1.10; otherwise @@ -10,12 +10,13 @@ Build-Type: Simple Name: unification-fd -Version: 0.11.1 +Version: 0.11.2 Stability: experimental Homepage: https://wrengr.org/software/hackage.html +Bug-Reports: https://github.com/wrengr/unification-fd/issues Author: wren gayle romano -Maintainer: winterkoninkje@gmail.com -Copyright: Copyright (c) 2007--2021 wren gayle romano +Maintainer: wren@cpan.org +Copyright: Copyright (c) 2007–2021 wren gayle romano License: BSD3 License-File: LICENSE @@ -26,23 +27,27 @@ unification (think of programming in Prolog, or of the metavariables in type inference). --- No longer compiles with GHC-6.12.1 since Data.Monoid does not --- export (<>) in Control.Unification.Types. The backwards compatibility --- is not considered worth adding CPP noise... --- FIXME(2021.02.24): versions 7.x are no longer available on GitHub --- for CI (at least not on ubuntu-latest); so we should probably --- remove them from here --- FIXME(2021.02.24): version 9.0.1 is not yet cached on GitHub for CI either. -Tested-With: - GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, - GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5, - GHC == 8.8.4, GHC == 8.10.3, GHC == 9.0.1 - Extra-source-files: AUTHORS, README.md, CHANGELOG + +-- This should work as far back as GHC 7.4.2, but we don't verify that by CI. +-- (No longer compiles with GHC-6.12.1 since "Data.Monoid" does not +-- export @(<>)@ in "Control.Unification.Types"; and adding the +-- backwards compatibility isn't worth adding CPP noise...) +-- +Tested-With: + GHC ==8.0.2, + GHC ==8.2.2, + GHC ==8.4.4, + GHC ==8.6.5, + GHC ==8.8.4, + GHC ==8.10.3, + GHC ==9.0.1, + GHC ==9.2.1 + Source-Repository head Type: git - Location: https://github.com/wrengr/unification-fd + Location: https://github.com/wrengr/unification-fd.git ---------------------------------------------------------------- Library @@ -65,7 +70,7 @@ -- should be resolved now. Cf., -- -- - Build-Depends: logict >= 0.4 && < 0.7.2 + Build-Depends: logict >= 0.4 && < 0.8.1 -- N.B., Tasty requires base>=4.5.0.0; which -- means we aren't CI testing anything older than -- that anymore, so we might as well just require