unification-fd 0.11.1 → 0.11.2
raw patch · 14 files changed
+345/−274 lines, 14 filesdep ~basedep ~logictsetup-changed
Dependency ranges changed: base, logict
Files
- CHANGELOG +12/−0
- Setup.hs +1/−21
- src/Control/Monad/EitherK.hs +64/−41
- src/Control/Monad/MaybeK.hs +62/−42
- src/Control/Monad/State/UnificationExtras.hs +4/−4
- src/Control/Unification.hs +29/−36
- src/Control/Unification/IntVar.hs +35/−23
- src/Control/Unification/Ranked.hs +15/−15
- src/Control/Unification/Ranked/IntVar.hs +37/−25
- src/Control/Unification/Ranked/STVar.hs +28/−19
- src/Control/Unification/STVar.hs +23/−13
- src/Control/Unification/Types.hs +7/−12
- src/Data/Functor/Fixedpoint.hs +5/−5
- unification-fd.cabal +23/−18
CHANGELOG view
@@ -1,3 +1,15 @@+0.11.2 (2022-05-25):+ - Adjusted Applicative/Monad instances to avoid warnings on GHC 9.2+ due to <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return>+ - 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+ <https://github.com/commercialhaskell/stackage/issues/6569>+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.
Setup.hs view
@@ -1,27 +1,7 @@ #!/usr/bin/env runhaskell--- Cf. <http://www.mail-archive.com/haskell-cafe@haskell.org/msg59984.html>--- <http://www.haskell.org/pipermail/haskell-cafe/2008-December/051785.html> -{-# 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
src/Control/Monad/EitherK.hs view
@@ -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.+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return>+--+-- 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
src/Control/Monad/MaybeK.hs view
@@ -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.+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return>+--+-- 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)
src/Control/Monad/State/UnificationExtras.hs view
@@ -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
src/Control/Unification.hs view
@@ -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
src/Control/Unification/IntVar.hs view
@@ -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.+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return> 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)
src/Control/Unification/Ranked.hs view
@@ -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
src/Control/Unification/Ranked/IntVar.hs view
@@ -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.+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return> 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)
src/Control/Unification/Ranked/STVar.hs view
@@ -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.+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return> 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 ----------------------------------------------------------------
src/Control/Unification/STVar.hs view
@@ -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.+-- <https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/monad-of-no-return> 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) ----------------------------------------------------------------
src/Control/Unification/Types.hs view
@@ -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)
src/Data/Functor/Fixedpoint.hs view
@@ -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:+-- <https://github.com/haskell/core-libraries-committee/issues/3> 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. <https://ghc.haskell.org/trac/ghc/ticket/13081> #if __GLASGOW_HASKELL__ == 800 {-# NOINLINE (==) #-}- {-# NOINLINE (/=) #-} #endif instance (Ord (f (Fix f))) => Ord (Fix f) where
unification-fd.cabal view
@@ -1,5 +1,5 @@ ------------------------------------------------------------------- wren gayle romano <wren@community.haskell.org> ~ 2021.02.24+-- wren gayle romano <wren@cpan.org> ~ 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...)+-- <https://github.com/wrengr/unification-fd/actions?query=workflow%3Aci>+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., -- <https://github.com/Bodigrim/logict/issues/20#issuecomment-774528439> -- <https://github.com/wrengr/unification-fd/issues/14>- 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