diff --git a/src/binary/Data/Binary/Builder.hs b/src/binary/Data/Binary/Builder.hs index 18b45763c..66e2fa497 100644 --- a/src/binary/Data/Binary/Builder.hs +++ b/src/binary/Data/Binary/Builder.hs @@ -54,7 +54,7 @@ module Data.Binary.Builder ( ) where -import Foreign(Word,Word8,Ptr,Storable,ForeignPtr,withForeignPtr,poke,plusPtr,sizeOf) +import Foreign(Word8,Ptr,Storable,ForeignPtr,withForeignPtr,poke,plusPtr,sizeOf) import System.IO.Unsafe(unsafePerformIO) import Data.Monoid --import Data.Word diff --git a/src/binary/Data/Binary/Get.hs b/src/binary/Data/Binary/Get.hs index 719b7d803..6e98434f5 100644 --- a/src/binary/Data/Binary/Get.hs +++ b/src/binary/Data/Binary/Get.hs @@ -68,7 +68,7 @@ module Data.Binary.Get ( ) where -import Control.Monad (when,liftM) -- ap +import Control.Monad (when,liftM, ap) import Control.Monad.Fix import Data.Maybe (isNothing) @@ -82,9 +82,7 @@ import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Lazy.Internal as L #endif -#ifdef APPLICATIVE_IN_BASE import Control.Applicative (Applicative(..)) -#endif import Foreign @@ -116,11 +114,9 @@ instance Functor Get where (a, s') -> (f a, s')) {-# INLINE fmap #-} -#ifdef APPLICATIVE_IN_BASE instance Applicative Get where pure = return (<*>) = ap -#endif instance Monad Get where return a = Get (\s -> (a, s)) @@ -187,7 +183,7 @@ runGet m str = case unGet m (initState str) of (a, _) -> a runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64) runGetState m str off = case unGet m (mkState str off) of - (a, ~(S s ss newOff)) -> (a, s `join` ss, newOff) + (a, ~(S s ss newOff)) -> (a, s `joinBS` ss, newOff) ------------------------------------------------------------------------ @@ -246,7 +242,7 @@ uncheckedLookAhead n = do S s ss _ <- get if n <= fromIntegral (B.length s) then return (L.fromChunks [B.take (fromIntegral n) s]) - else return $ L.take n (s `join` ss) + else return $ L.take n (s `joinBS` ss) ------------------------------------------------------------------------ -- Utility @@ -286,7 +282,7 @@ getByteString n = readN n id getLazyByteString :: Int64 -> Get L.ByteString getLazyByteString n = do S s ss bytes <- get - let big = s `join` ss + let big = s `joinBS` ss case splitAtST n big of (consume, rest) -> do put $ mkState rest (bytes + n) return consume @@ -297,7 +293,7 @@ getLazyByteString n = do getLazyByteStringNul :: Get L.ByteString getLazyByteStringNul = do S s ss bytes <- get - let big = s `join` ss + let big = s `joinBS` ss (consume, t) = L.break (== 0) big (h, rest) = L.splitAt 1 t if L.null h @@ -311,7 +307,7 @@ getLazyByteStringNul = do getRemainingLazyByteString :: Get L.ByteString getRemainingLazyByteString = do S s ss _ <- get - return (s `join` ss) + return (s `joinBS` ss) ------------------------------------------------------------------------ -- Helpers @@ -325,7 +321,7 @@ getBytes n = do put $! S rest ss (bytes + fromIntegral n) return $! consume else - case L.splitAt (fromIntegral n) (s `join` ss) of + case L.splitAt (fromIntegral n) (s `joinBS` ss) of (consuming, rest) -> do let now = B.concat . L.toChunks $ consuming put $! mkState rest (bytes + fromIntegral n) @@ -339,19 +335,19 @@ getBytes n = do -- ^ important #ifndef BYTESTRING_IN_BASE -join :: B.ByteString -> L.ByteString -> L.ByteString -join bb lb +joinBS :: B.ByteString -> L.ByteString -> L.ByteString +joinBS bb lb | B.null bb = lb | otherwise = L.Chunk bb lb #else -join :: B.ByteString -> L.ByteString -> L.ByteString -join bb (B.LPS lb) +joinBS :: B.ByteString -> L.ByteString -> L.ByteString +joinBS bb (B.LPS lb) | B.null bb = B.LPS lb | otherwise = B.LPS (bb:lb) #endif -- don't use L.append, it's strict in it's second argument :/ -{- INLINE join -} +{- INLINE joinBS -} -- | Split a ByteString. If the first result is consumed before the -- -- second, this runs in constant heap space. diff --git a/src/binary/Data/Binary/Put.hs b/src/binary/Data/Binary/Put.hs index a1f78dfba..070f5ab40 100644 --- a/src/binary/Data/Binary/Put.hs +++ b/src/binary/Data/Binary/Put.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Binary.Put @@ -56,10 +55,7 @@ import qualified Data.Binary.Builder as B import Data.Word import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L - -#ifdef APPLICATIVE_IN_BASE import Control.Applicative -#endif ------------------------------------------------------------------------ @@ -80,14 +76,12 @@ instance Functor PutM where fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w {-# INLINE fmap #-} -#ifdef APPLICATIVE_IN_BASE instance Applicative PutM where pure = return m <*> k = Put $ let PairS f w = unPut m PairS x w' = unPut k in PairS (f x) (w `mappend` w') -#endif -- Standard Writer monad, with aggressive inlining instance Monad PutM where diff --git a/src/compiler/GF/Compile.hs b/src/compiler/GF/Compile.hs index c7818165c..f48396488 100644 --- a/src/compiler/GF/Compile.hs +++ b/src/compiler/GF/Compile.hs @@ -5,10 +5,10 @@ import GF.Compile.ReadFiles(ModEnv,getOptionsFromFile,getAllFiles, importsOfModule) import GF.CompileOne(compileOne) -import GF.Grammar.Grammar(SourceGrammar,msrc,modules,emptySourceGrammar, - abstractOfConcrete,prependModule) +import GF.Grammar.Grammar(SourceGrammar,emptySourceGrammar, + abstractOfConcrete,prependModule)--,msrc,modules -import GF.Infra.Ident(Ident,identS,showIdent) +import GF.Infra.Ident(Ident,identS)--,showIdent import GF.Infra.Option import GF.Infra.UseIO(IOE,FullPath,liftIO,getLibraryDirectory,putIfVerb, justModuleName,extendPathEnv,putStrE,putPointE) @@ -17,7 +17,7 @@ import GF.Data.Operations(raise,(+++),err) import Control.Monad(foldM,when) import GF.System.Directory(doesFileExist,getModificationTime) import System.FilePath((),isRelative,dropFileName) -import qualified Data.Map as Map(empty,insert,lookup,elems) +import qualified Data.Map as Map(empty,insert,elems) --lookup import Data.List(nub) import Data.Time(UTCTime) import GF.Text.Pretty(render,($$),(<+>),nest) diff --git a/src/compiler/GF/Compile/GeneratePMCFG.hs b/src/compiler/GF/Compile/GeneratePMCFG.hs index b8edda00f..e6067c854 100644 --- a/src/compiler/GF/Compile/GeneratePMCFG.hs +++ b/src/compiler/GF/Compile/GeneratePMCFG.hs @@ -36,6 +36,7 @@ import Data.Array.IArray import Data.Array.Unboxed --import Data.Maybe --import Data.Char (isDigit) +import Control.Applicative(Applicative(..)) import Control.Monad import Control.Monad.Identity --import Control.Exception @@ -247,6 +248,10 @@ newtype CnvMonad a = CM {unCM :: SourceGrammar -> ([ProtoFCat],[Symbol]) -> Branch b} +instance Applicative CnvMonad where + pure = return + (<*>) = ap + instance Monad CnvMonad where return a = CM (\gr c s -> c a s) CM m >>= k = CM (\gr c s -> m gr (\a s -> unCM (k a) gr c s) s) diff --git a/src/compiler/GF/Compile/GetGrammar.hs b/src/compiler/GF/Compile/GetGrammar.hs index 4647cfcb4..e10081cff 100644 --- a/src/compiler/GF/Compile/GetGrammar.hs +++ b/src/compiler/GF/Compile/GetGrammar.hs @@ -30,7 +30,7 @@ import GF.Compile.ReadFiles(parseSource,lift) import qualified Data.ByteString.Char8 as BS import Data.Char(isAscii) import Control.Monad (foldM,when,unless) -import System.Cmd (system) +import System.Process (system) import System.Directory(removeFile,getCurrentDirectory) import System.FilePath(makeRelative) diff --git a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs index 67f6e5fda..0701b23f4 100644 --- a/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs +++ b/src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs @@ -9,6 +9,8 @@ import GF.Compile.TypeCheck.Primitives import GF.Infra.CheckM --import GF.Infra.UseIO import GF.Data.Operations +import Control.Applicative(Applicative(..)) +import Control.Monad(ap) import GF.Text.Pretty import Data.List (nub, (\\), tails) @@ -467,6 +469,10 @@ instance Monad TcM where TcFail msgs -> TcFail msgs) fail = tcError . pp +instance Applicative TcM where + pure = return + (<*>) = ap + instance Functor TcM where fmap f g = TcM (\ms msgs -> case unTcM g ms msgs of TcOk x ms msgs -> TcOk (f x) ms msgs diff --git a/src/compiler/GF/Data/BacktrackM.hs b/src/compiler/GF/Data/BacktrackM.hs index 4e84022f4..f5ae63997 100644 --- a/src/compiler/GF/Data/BacktrackM.hs +++ b/src/compiler/GF/Data/BacktrackM.hs @@ -29,6 +29,7 @@ module GF.Data.BacktrackM ( ) where import Data.List +import Control.Applicative import Control.Monad import Control.Monad.State.Class @@ -60,6 +61,10 @@ foldFinalStates f b (BM m) s = m (\x s b -> f s b) s b finalStates :: BacktrackM s () -> s -> [s] finalStates bm = map fst . runBM bm +instance Applicative (BacktrackM s) where + pure = return + (<*>) = ap + instance Monad (BacktrackM s) where return a = BM (\c s b -> c a s b) BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) @@ -69,6 +74,10 @@ instance Monad (BacktrackM s) where instance Functor (BacktrackM s) where fmap f (BM m) = BM (\c s b -> m (\a s b -> c (f a) s b) s b) +instance Alternative (BacktrackM s) where + empty = mzero + (<|>) = mplus + instance MonadPlus (BacktrackM s) where mzero = BM (\c s b -> b) (BM f) `mplus` (BM g) = BM (\c s b -> g c s $! f c s b) diff --git a/src/compiler/GF/Data/ErrM.hs b/src/compiler/GF/Data/ErrM.hs index e8cea12d4..d687a70a5 100644 --- a/src/compiler/GF/Data/ErrM.hs +++ b/src/compiler/GF/Data/ErrM.hs @@ -14,7 +14,8 @@ module GF.Data.ErrM (Err(..)) where -import Control.Monad (MonadPlus(..)) +import Control.Monad (MonadPlus(..),ap) +import Control.Applicative -- | like @Maybe@ type with error msgs data Err a = Ok a | Bad String @@ -31,8 +32,16 @@ instance Functor Err where fmap f (Ok a) = Ok (f a) fmap f (Bad s) = Bad s +instance Applicative Err where + pure = return + (<*>) = ap + -- | added by KJ instance MonadPlus Err where mzero = Bad "error (no reason given)" mplus (Ok a) _ = Ok a mplus (Bad s) b = b + +instance Alternative Err where + empty = mzero + (<|>) = mplus diff --git a/src/compiler/GF/Data/Operations.hs b/src/compiler/GF/Data/Operations.hs index cd42156d4..ef34de27b 100644 --- a/src/compiler/GF/Data/Operations.hs +++ b/src/compiler/GF/Data/Operations.hs @@ -67,7 +67,8 @@ import Data.Char (isSpace, toUpper, isSpace, isDigit) import Data.List (nub, partition, (\\)) import qualified Data.Map as Map import Data.Map (Map) -import Control.Monad (liftM,liftM2) +import Control.Applicative(Applicative(..)) +import Control.Monad (liftM,liftM2,ap) import GF.Data.ErrM import GF.Data.Relation @@ -330,6 +331,10 @@ stmr f = stm (\s -> return (f s)) instance Functor (STM s) where fmap = liftM +instance Applicative (STM s) where + pure = return + (<*>) = ap + instance Monad (STM s) where return a = STM (\s -> return (a,s)) STM c >>= f = STM (\s -> do diff --git a/src/compiler/GF/Grammar/Lexer.x b/src/compiler/GF/Grammar/Lexer.x index 681ae9024..c2cbb4c47 100644 --- a/src/compiler/GF/Grammar/Lexer.x +++ b/src/compiler/GF/Grammar/Lexer.x @@ -6,6 +6,8 @@ module GF.Grammar.Lexer , isReservedWord ) where +import Control.Applicative +import Control.Monad(ap) import GF.Infra.Ident --import GF.Data.Operations import qualified Data.ByteString.Char8 as BS @@ -258,6 +260,13 @@ data ParseResult a newtype P a = P { unP :: AlexInput -> ParseResult a } +instance Functor P where + fmap = (<$>) + +instance Applicative P where + pure = return + (<*>) = ap + instance Monad P where return a = a `seq` (P $ \s -> POk a) (P m) >>= k = P $ \ s -> case m s of diff --git a/src/compiler/GF/Infra/CheckM.hs b/src/compiler/GF/Infra/CheckM.hs index 24fbc3644..80f2409fa 100644 --- a/src/compiler/GF/Infra/CheckM.hs +++ b/src/compiler/GF/Infra/CheckM.hs @@ -28,7 +28,8 @@ import qualified Data.Map as Map import GF.Text.Pretty import System.FilePath(makeRelative) import Control.Parallel.Strategies(parList,rseq,using) -import Control.Monad(liftM) +import Control.Monad(liftM,ap) +import Control.Applicative(Applicative(..)) type Message = Doc type Error = Message @@ -50,6 +51,10 @@ instance Monad Check where (ws,Success x) -> unCheck (g x) {-ctxt-} ws (ws,Fail msg) -> (ws,Fail msg) +instance Applicative Check where + pure = return + (<*>) = ap + instance ErrorMonad Check where raise s = checkError (pp s) handle f h = handle' f (h . render) diff --git a/src/compiler/GF/Infra/SIO.hs b/src/compiler/GF/Infra/SIO.hs index ff2072987..39c3da489 100644 --- a/src/compiler/GF/Infra/SIO.hs +++ b/src/compiler/GF/Infra/SIO.hs @@ -19,10 +19,11 @@ module GF.Infra.SIO( restricted,restrictedSystem ) where import Prelude hiding (putStrLn,print) -import Control.Monad(liftM) +import Control.Applicative(Applicative(..)) +import Control.Monad(liftM,ap) import System.IO(hPutStrLn,hFlush,stdout) import GF.System.Catch(try) -import System.Cmd(system) +import System.Process(system) import System.Environment(getEnv) import Control.Concurrent.Chan(newChan,writeChan,getChanContents) import qualified System.CPUTime as IO(getCPUTime) @@ -39,6 +40,10 @@ newtype SIO a = SIO {unS::PutStrLn->IO a} instance Functor SIO where fmap = liftM +instance Applicative SIO where + pure = return + (<*>) = ap + instance Monad SIO where return x = SIO (const (return x)) SIO m1 >>= xm2 = SIO $ \ h -> m1 h >>= \ x -> unS (xm2 x) h diff --git a/src/compiler/GF/Infra/UseIO.hs b/src/compiler/GF/Infra/UseIO.hs index 17894c682..a0a36ad52 100644 --- a/src/compiler/GF/Infra/UseIO.hs +++ b/src/compiler/GF/Infra/UseIO.hs @@ -31,6 +31,7 @@ import System.Exit import System.CPUTime --import System.Cmd import Text.Printf +import Control.Applicative(Applicative(..)) import Control.Monad import Control.Monad.Trans(MonadIO(..)) import Control.Exception(evaluate) @@ -150,6 +151,10 @@ instance ErrorMonad IOE where instance Functor IOE where fmap = liftM +instance Applicative IOE where + pure = return + (<*>) = ap + instance Monad IOE where return a = ioe (return (return a)) IOE c >>= f = IOE $ do diff --git a/src/compiler/GFC.hs b/src/compiler/GFC.hs index 4bd6ce25c..4b1034faa 100644 --- a/src/compiler/GFC.hs +++ b/src/compiler/GFC.hs @@ -2,7 +2,7 @@ module GFC (mainGFC, writePGF) where -- module Main where import PGF -import PGF.Internal(PGF,concretes,optimizePGF,unionPGF) +import PGF.Internal(concretes,optimizePGF,unionPGF) import PGF.Internal(putSplitAbs,encodeFile,runPut) import GF.Compile import GF.Compile.Export diff --git a/src/runtime/haskell/PGF/TypeCheck.hs b/src/runtime/haskell/PGF/TypeCheck.hs index 0818aeb4a..8860ed17b 100644 --- a/src/runtime/haskell/PGF/TypeCheck.hs +++ b/src/runtime/haskell/PGF/TypeCheck.hs @@ -37,6 +37,7 @@ import Data.Map as Map import Data.IntMap as IntMap import Data.Maybe as Maybe import Data.List as List +import Control.Applicative import Control.Monad --import Control.Monad.Identity import Control.Monad.State @@ -92,10 +93,18 @@ class Selector s where splitSelector :: s -> (s,s) select :: CId -> Scope -> Maybe Int -> TcM s (Expr,TType) +instance Applicative (TcM s) where + pure = return + (<*>) = ap + instance Monad (TcM s) where return x = TcM (\abstr k h -> k x) f >>= g = TcM (\abstr k h -> unTcM f abstr (\x -> unTcM (g x) abstr k h) h) +instance Selector s => Alternative (TcM s) where + empty = mzero + (<|>) = mplus + instance Selector s => MonadPlus (TcM s) where mzero = TcM (\abstr k h ms s -> id) mplus f g = TcM (\abstr k h ms s -> let (s1,s2) = splitSelector s