Merge branch 'master' of https://github.com/GrammaticalFramework/gf-core into release-3.12

5 files changed, 14 insertions, 12 deletions

diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs
index 8dc46f816..e22fa4a4c 100644
--- a/src/runtime/haskell/Data/Binary/Builder.hs
+++ b/src/runtime/haskell/Data/Binary/Builder.hs
@@ -114,7 +114,7 @@ instance Semigroup Builder where
 instance Monoid Builder where
     mempty  = empty
     {-# INLINE mempty #-}
-    mappend = append
+    mappend = (<>)
     {-# INLINE mappend #-}
 
 ------------------------------------------------------------------------
diff --git a/src/runtime/haskell/Data/Binary/Get.hs b/src/runtime/haskell/Data/Binary/Get.hs
index a33c5c5a3..ec6309fae 100644
--- a/src/runtime/haskell/Data/Binary/Get.hs
+++ b/src/runtime/haskell/Data/Binary/Get.hs
@@ -127,11 +127,11 @@ instance Functor Get where
     {-# INLINE fmap #-}
 
 instance Applicative Get where
-    pure  = return
+    pure a = Get (\s -> (a, s))
     (<*>) = ap
 
 instance Monad Get where
-    return a  = Get (\s -> (a, s))
+    return = pure
     {-# INLINE return #-}
 
     m >>= k   = Get (\s -> case unGet m s of
diff --git a/src/runtime/haskell/Data/Binary/Put.hs b/src/runtime/haskell/Data/Binary/Put.hs
index 189cf806f..05d23fba6 100644
--- a/src/runtime/haskell/Data/Binary/Put.hs
+++ b/src/runtime/haskell/Data/Binary/Put.hs
@@ -77,15 +77,20 @@ instance Functor PutM where
         {-# INLINE fmap #-}
 
 instance Applicative PutM where
-        pure    = return
+        pure a  = Put $ PairS a mempty
         m <*> k = Put $
             let PairS f w  = unPut m
                 PairS x w' = unPut k
             in PairS (f x) (w `mappend` w')
+        m *> k  = Put $
+            let PairS _ w  = unPut m
+                PairS b w' = unPut k
+            in PairS b (w `mappend` w')
+        {-# INLINE (*>) #-}
 
 -- Standard Writer monad, with aggressive inlining
 instance Monad PutM where
-    return a = Put $ PairS a mempty
+    return = pure
     {-# INLINE return #-}
 
     m >>= k  = Put $
@@ -94,10 +99,7 @@ instance Monad PutM where
         in PairS b (w `mappend` w')
     {-# INLINE (>>=) #-}
 
-    m >> k  = Put $
-        let PairS _ w  = unPut m
-            PairS b w' = unPut k
-        in PairS b (w `mappend` w')
+    (>>) = (*>)
     {-# INLINE (>>) #-}
 
 tell :: Builder -> Put
diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs
index ff1114235..42c0df14e 100644
--- a/src/runtime/haskell/PGF/Expr.hs
+++ b/src/runtime/haskell/PGF/Expr.hs
@@ -408,7 +408,7 @@ match sig f eqs as0 =
         tryMatch (p          ) (VMeta i envi vs  ) env            = VSusp i envi vs (\v -> tryMatch p v env)

         tryMatch (p          ) (VGen  i vs       ) env            = VConst f as0

         tryMatch (p          ) (VSusp i envi vs k) env            = VSusp i envi vs (\v -> tryMatch p (k v) env)

-        tryMatch (p          ) v@(VConst _ _     ) env            = VConst f as0

+        tryMatch (p          ) v@(VConst _ _     ) env            = match sig f eqs as0

         tryMatch (PApp f1 ps1) (VApp f2 vs2      ) env | f1 == f2 = tryMatches eqs (ps1++ps) (vs2++as) res env

         tryMatch (PLit l1    ) (VLit l2          ) env | l1 == l2 = tryMatches eqs  ps        as  res env

         tryMatch (PImplArg p ) (VImplArg v       ) env            = tryMatch p v env

diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs
index 82bd47b7a..f02986fc0 100644
--- a/src/runtime/haskell/PGF/TypeCheck.hs
+++ b/src/runtime/haskell/PGF/TypeCheck.hs
@@ -94,11 +94,11 @@ class Selector s where
   select        :: CId -> Scope -> Maybe Int -> TcM s (Expr,TType)
 
 instance Applicative (TcM s) where
-  pure = return
+  pure x = TcM (\abstr k h -> k x)
   (<*>) = ap
 
 instance Monad (TcM s) where
-  return x = TcM (\abstr k h -> k x)
+  return   = pure
   f >>= g  = TcM (\abstr k h -> unTcM f abstr (\x -> unTcM (g x) abstr k h) h)
 
 instance Selector s => Alternative (TcM s) where