summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/binary/Data/Binary/Builder.hs2
-rw-r--r--src/binary/Data/Binary/Get.hs28
-rw-r--r--src/binary/Data/Binary/Put.hs6
-rw-r--r--src/compiler/GF/Compile.hs8
-rw-r--r--src/compiler/GF/Compile/GeneratePMCFG.hs5
-rw-r--r--src/compiler/GF/Compile/GetGrammar.hs2
-rw-r--r--src/compiler/GF/Compile/TypeCheck/ConcreteNew.hs6
-rw-r--r--src/compiler/GF/Data/BacktrackM.hs9
-rw-r--r--src/compiler/GF/Data/ErrM.hs11
-rw-r--r--src/compiler/GF/Data/Operations.hs7
-rw-r--r--src/compiler/GF/Grammar/Lexer.x9
-rw-r--r--src/compiler/GF/Infra/CheckM.hs7
-rw-r--r--src/compiler/GF/Infra/SIO.hs9
-rw-r--r--src/compiler/GF/Infra/UseIO.hs5
-rw-r--r--src/compiler/GFC.hs2
-rw-r--r--src/runtime/haskell/PGF/TypeCheck.hs9
16 files changed, 91 insertions, 34 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 05:58:28 +0000