forked from GitHub/gf-core
55aebadd5a
* The following modules are no longer used and have been removed completely: GF.Compile.Compute.ConcreteLazy GF.Compile.Compute.ConcreteStrict GF.Compile.Refresh * The STM monad has been commented out. It was only used in GF.Compile.SubExpOpt, where could be replaced with a plain State monad, since no error handling was needed. One of the functions was hardwired to the Err monad, but did in fact not use error handling, so it was turned into a pure function. * The function errVal has been renamed to fromErr (since it is analogous to fromMaybe). * Replaced 'fail' with 'raise' and 'return ()' with 'done' in a few places. * Some additional old code that was already commented out has been removed.
378 lines
10 KiB
Haskell
378 lines
10 KiB
Haskell
----------------------------------------------------------------------
|
|
-- |
|
|
-- Module : Operations
|
|
-- Maintainer : AR
|
|
-- Stability : (stable)
|
|
-- Portability : (portable)
|
|
--
|
|
-- > CVS $Date: 2005/11/11 16:12:41 $
|
|
-- > CVS $Author: bringert $
|
|
-- > CVS $Revision: 1.22 $
|
|
--
|
|
-- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
|
|
--
|
|
-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
|
|
-----------------------------------------------------------------------------
|
|
|
|
module GF.Data.Operations (-- ** Misc functions
|
|
ifNull,
|
|
|
|
-- ** The Error monad
|
|
Err(..), err, maybeErr, testErr, fromErr, errIn,
|
|
lookupErr,
|
|
|
|
--- ** Monadic operations on lists and pairs
|
|
mapPairListM, mapPairsM, pairM,
|
|
|
|
-- ** Checking
|
|
checkUnique, unifyMaybeBy, unifyMaybe,
|
|
|
|
-- ** Binary search trees; now with FiniteMap
|
|
BinTree, emptyBinTree, isInBinTree, --justLookupTree,
|
|
lookupTree, --lookupTreeMany,
|
|
lookupTreeManyAll, updateTree,
|
|
buildTree, filterBinTree,
|
|
mapTree, --mapMTree,
|
|
tree2list,
|
|
|
|
|
|
-- ** Printing
|
|
indent, (+++), (++-), (++++), (+++++),
|
|
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
|
|
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
|
|
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
|
|
|
|
-- ** Extra
|
|
combinations, done, readIntArg, --singleton,
|
|
|
|
-- ** Topological sorting with test of cyclicity
|
|
topoTest, topoTest2,
|
|
|
|
-- ** The generic fix point iterator
|
|
iterFix,
|
|
|
|
-- ** Chop into separator-separated parts
|
|
chunks,
|
|
{-
|
|
-- ** State monad with error; from Agda 6\/11\/2001
|
|
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM,
|
|
-}
|
|
-- ** Error monad class
|
|
ErrorMonad(..), checks, allChecks, doUntil, --checkAgain,
|
|
liftErr
|
|
|
|
) where
|
|
|
|
import Data.Char (isSpace, toUpper, isSpace, isDigit)
|
|
import Data.List (nub, partition, (\\))
|
|
import qualified Data.Map as Map
|
|
import Data.Map (Map)
|
|
--import Control.Applicative(Applicative(..))
|
|
import Control.Monad (liftM,liftM2) --,ap
|
|
|
|
import GF.Data.ErrM
|
|
import GF.Data.Relation
|
|
|
|
infixr 5 +++
|
|
infixr 5 ++-
|
|
infixr 5 ++++
|
|
infixr 5 +++++
|
|
|
|
ifNull :: b -> ([a] -> b) -> [a] -> b
|
|
ifNull b f xs = if null xs then b else f xs
|
|
|
|
-- the Error monad
|
|
|
|
-- | Add msg s to 'Maybe' failures
|
|
maybeErr :: ErrorMonad m => String -> Maybe a -> m a
|
|
maybeErr s = maybe (raise s) return
|
|
|
|
testErr :: ErrorMonad m => Bool -> String -> m ()
|
|
testErr cond msg = if cond then done else raise msg
|
|
|
|
errIn :: ErrorMonad m => String -> m a -> m a
|
|
errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
|
|
|
|
lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
|
|
lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
|
|
|
|
mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
|
|
mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys
|
|
|
|
mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
|
|
mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys
|
|
|
|
pairM :: Monad m => (b -> m c) -> (b,b) -> m (c,c)
|
|
pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
|
|
|
|
-- checking
|
|
|
|
checkUnique :: (Show a, Eq a) => [a] -> [String]
|
|
checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where
|
|
overloads = filter overloaded ss
|
|
overloaded s = length (filter (==s) ss) > 1
|
|
|
|
-- | this is what happens when matching two values in the same module
|
|
unifyMaybe :: (Eq a, Monad m) => Maybe a -> Maybe a -> m (Maybe a)
|
|
unifyMaybe = unifyMaybeBy id
|
|
|
|
unifyMaybeBy :: (Eq b, Monad m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
|
|
unifyMaybeBy f (Just p1) (Just p2)
|
|
| f p1==f p2 = return (Just p1)
|
|
| otherwise = fail ""
|
|
unifyMaybeBy _ Nothing mp2 = return mp2
|
|
unifyMaybeBy _ mp1 _ = return mp1
|
|
|
|
-- binary search trees
|
|
|
|
type BinTree a b = Map a b
|
|
|
|
emptyBinTree :: BinTree a b
|
|
emptyBinTree = Map.empty
|
|
|
|
isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
|
|
isInBinTree = Map.member
|
|
{-
|
|
justLookupTree :: (ErrorMonad m,Ord a) => a -> BinTree a b -> m b
|
|
justLookupTree = lookupTree (const [])
|
|
-}
|
|
lookupTree :: (ErrorMonad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
|
|
lookupTree pr x = maybeErr no . Map.lookup x
|
|
where no = "no occurrence of element" +++ pr x
|
|
|
|
lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b]
|
|
lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of
|
|
Ok v -> v : lookupTreeManyAll pr ts x
|
|
_ -> lookupTreeManyAll pr ts x
|
|
lookupTreeManyAll pr [] x = []
|
|
|
|
updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
|
|
updateTree (a,b) = Map.insert a b
|
|
|
|
buildTree :: (Ord a) => [(a,b)] -> BinTree a b
|
|
buildTree = Map.fromList
|
|
|
|
mapTree :: ((a,b) -> c) -> BinTree a b -> BinTree a c
|
|
mapTree f = Map.mapWithKey (\k v -> f (k,v))
|
|
|
|
filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
|
|
filterBinTree = Map.filterWithKey
|
|
|
|
tree2list :: BinTree a b -> [(a,b)] -- inorder
|
|
tree2list = Map.toList
|
|
|
|
-- printing
|
|
|
|
indent :: Int -> String -> String
|
|
indent i s = replicate i ' ' ++ s
|
|
|
|
(+++), (++-), (++++), (+++++) :: String -> String -> String
|
|
a +++ b = a ++ " " ++ b
|
|
a ++- "" = a
|
|
a ++- b = a +++ b
|
|
a ++++ b = a ++ "\n" ++ b
|
|
a +++++ b = a ++ "\n\n" ++ b
|
|
|
|
prUpper :: String -> String
|
|
prUpper s = s1 ++ s2' where
|
|
(s1,s2) = span isSpace s
|
|
s2' = case s2 of
|
|
c:t -> toUpper c : t
|
|
_ -> s2
|
|
|
|
prReplicate :: Int -> String -> String
|
|
prReplicate n s = concat (replicate n s)
|
|
|
|
prTList :: String -> [String] -> String
|
|
prTList t ss = case ss of
|
|
[] -> ""
|
|
[s] -> s
|
|
s:ss -> s ++ t ++ prTList t ss
|
|
|
|
prQuotedString :: String -> String
|
|
prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
|
|
|
|
prParenth :: String -> String
|
|
prParenth s = if s == "" then "" else "(" ++ s ++ ")"
|
|
|
|
prCurly, prBracket :: String -> String
|
|
prCurly s = "{" ++ s ++ "}"
|
|
prBracket s = "[" ++ s ++ "]"
|
|
|
|
prArgList, prSemicList, prCurlyList :: [String] -> String
|
|
prArgList = prParenth . prTList ","
|
|
prSemicList = prTList " ; "
|
|
prCurlyList = prCurly . prSemicList
|
|
|
|
restoreEscapes :: String -> String
|
|
restoreEscapes s =
|
|
case s of
|
|
[] -> []
|
|
'"' : t -> '\\' : '"' : restoreEscapes t
|
|
'\\': t -> '\\' : '\\' : restoreEscapes t
|
|
c : t -> c : restoreEscapes t
|
|
|
|
numberedParagraphs :: [[String]] -> [String]
|
|
numberedParagraphs t = case t of
|
|
[] -> []
|
|
p:[] -> p
|
|
_ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
|
|
|
|
prConjList :: String -> [String] -> String
|
|
prConjList c [] = ""
|
|
prConjList c [s] = s
|
|
prConjList c [s,t] = s +++ c +++ t
|
|
prConjList c (s:tt) = s ++ "," +++ prConjList c tt
|
|
|
|
prIfEmpty :: String -> String -> String -> String -> String
|
|
prIfEmpty em _ _ [] = em
|
|
prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2
|
|
|
|
-- | Thomas Hallgren's wrap lines
|
|
wrapLines :: Int -> String -> String
|
|
wrapLines n "" = ""
|
|
wrapLines n s@(c:cs) =
|
|
if isSpace c
|
|
then c:wrapLines (n+1) cs
|
|
else case lex s of
|
|
[(w,rest)] -> if n'>=76
|
|
then '\n':w++wrapLines l rest
|
|
else w++wrapLines n' rest
|
|
where n' = n+l
|
|
l = length w
|
|
_ -> s -- give up!!
|
|
|
|
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
|
|
|
|
-- | 'combinations' is the same as 'sequence'!!!
|
|
-- peb 30\/5-04
|
|
combinations :: [[a]] -> [[a]]
|
|
combinations t = case t of
|
|
[] -> [[]]
|
|
aa:uu -> [a:u | a <- aa, u <- combinations uu]
|
|
|
|
{-
|
|
-- | 'singleton' is the same as 'return'!!!
|
|
singleton :: a -> [a]
|
|
singleton = (:[])
|
|
-}
|
|
|
|
-- | topological sorting with test of cyclicity
|
|
topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
|
|
topoTest = topologicalSort . mkRel'
|
|
|
|
-- | topological sorting with test of cyclicity, new version /TH 2012-06-26
|
|
topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
|
|
topoTest2 g0 = maybe (Right cycles) Left (tsort g)
|
|
where
|
|
g = g0++[(n,[])|n<-nub (concatMap snd g0)\\map fst g0]
|
|
|
|
cycles = findCycles (mkRel' g)
|
|
|
|
tsort nes =
|
|
case partition (null.snd) nes of
|
|
([],[]) -> Just []
|
|
([],_) -> Nothing
|
|
(ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
|
|
where leaves = map fst ns
|
|
|
|
|
|
-- | the generic fix point iterator
|
|
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
|
|
iterFix more start = iter start start
|
|
where
|
|
iter old new = if (null new')
|
|
then old
|
|
else iter (new' ++ old) new'
|
|
where
|
|
new' = filter (`notElem` old) (more new)
|
|
|
|
-- | chop into separator-separated parts
|
|
chunks :: Eq a => a -> [a] -> [[a]]
|
|
chunks sep ws = case span (/= sep) ws of
|
|
(a,_:b) -> a : bs where bs = chunks sep b
|
|
(a, []) -> if null a then [] else [a]
|
|
|
|
readIntArg :: String -> Int
|
|
readIntArg n = if (not (null n) && all isDigit n) then read n else 0
|
|
|
|
{-
|
|
-- state monad with error; from Agda 6/11/2001
|
|
|
|
newtype STM s a = STM (s -> Err (a,s))
|
|
|
|
appSTM :: STM s a -> s -> Err (a,s)
|
|
appSTM (STM f) s = f s
|
|
|
|
stm :: (s -> Err (a,s)) -> STM s a
|
|
stm = STM
|
|
|
|
stmr :: (s -> (a,s)) -> STM s a
|
|
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
|
|
(x,s') <- c s
|
|
let STM f' = f x
|
|
f' s')
|
|
|
|
readSTM :: STM s s
|
|
readSTM = stmr (\s -> (s,s))
|
|
|
|
updateSTM :: (s -> s) -> STM s ()
|
|
updateSTM f = stmr (\s -> ((),f s))
|
|
|
|
writeSTM :: s -> STM s ()
|
|
writeSTM s = stmr (const ((),s))
|
|
-}
|
|
done :: Monad m => m ()
|
|
done = return ()
|
|
|
|
class (Functor m,Monad m) => ErrorMonad m where
|
|
raise :: String -> m a
|
|
handle :: m a -> (String -> m a) -> m a
|
|
handle_ :: m a -> m a -> m a
|
|
handle_ a b = a `handle` (\_ -> b)
|
|
|
|
instance ErrorMonad Err where
|
|
raise = Bad
|
|
handle a@(Ok _) _ = a
|
|
handle (Bad i) f = f i
|
|
|
|
liftErr e = err raise return e
|
|
{-
|
|
instance ErrorMonad (STM s) where
|
|
raise msg = STM (\s -> raise msg)
|
|
handle (STM f) g = STM (\s -> (f s)
|
|
`handle` (\e -> let STM g' = (g e) in
|
|
g' s))
|
|
|
|
-}
|
|
|
|
-- | if the first check fails try another one
|
|
checkAgain :: ErrorMonad m => m a -> m a -> m a
|
|
checkAgain c1 c2 = handle_ c1 c2
|
|
|
|
checks :: ErrorMonad m => [m a] -> m a
|
|
checks [] = raise "no chance to pass"
|
|
checks cs = foldr1 checkAgain cs
|
|
|
|
allChecks :: ErrorMonad m => [m a] -> m [a]
|
|
allChecks ms = case ms of
|
|
(m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs
|
|
_ -> return []
|
|
|
|
doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a
|
|
doUntil cond ms = case ms of
|
|
a:as -> do
|
|
v <- a
|
|
if cond v then return v else doUntil cond as
|
|
_ -> raise "no result"
|