module GF.Data.Operations (
Err(..), err, maybeErr, testErr, fromErr, errIn,
lookupErr,
ErrorMonad(..), checks,
liftErr,
checkUnique, unifyMaybeBy, unifyMaybe,
mapPairsM, pairM,
indent, (+++), (++-), (++++), (+++-), (+++++),
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
topoTest, topoTest2,
readIntArg,
iterFix, chunks,
) 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.Monad (liftM,liftM2)
import GF.Data.ErrM
import GF.Data.Relation
import qualified Control.Monad.Fail as Fail
infixr 5 +++
infixr 5 ++-
infixr 5 ++++
infixr 5 +++++
maybeErr :: ErrorMonad m => String -> Maybe a -> m a
maybeErr :: String -> Maybe a -> m a
maybeErr String
s = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m a
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise String
s) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
testErr :: ErrorMonad m => Bool -> String -> m ()
testErr :: Bool -> String -> m ()
testErr Bool
cond String
msg = if Bool
cond then () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () else String -> m ()
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise String
msg
errIn :: ErrorMonad m => String -> m a -> m a
errIn :: String -> m a -> m a
errIn String
msg m a
m = m a -> (String -> m a) -> m a
forall (m :: * -> *) a.
ErrorMonad m =>
m a -> (String -> m a) -> m a
handle m a
m (\String
s -> String -> m a
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise (String
s String -> String -> String
++++ String
"OCCURRED IN" String -> String -> String
++++ String
msg))
lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
lookupErr :: a -> [(a, b)] -> m b
lookupErr a
a [(a, b)]
abs = String -> Maybe b -> m b
forall (m :: * -> *) a. ErrorMonad m => String -> Maybe a -> m a
maybeErr (String
"Unknown" String -> String -> String
+++ a -> String
forall a. Show a => a -> String
show a
a) (a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
a [(a, b)]
abs)
mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
mapPairsM :: (b -> m c) -> [(a, b)] -> m [(a, c)]
mapPairsM b -> m c
f [(a, b)]
xys = ((a, b) -> m (a, c)) -> [(a, b)] -> m [(a, c)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ (a
x,b
y) -> (c -> (a, c)) -> m c -> m (a, c)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ((,) a
x) (b -> m c
f b
y)) [(a, b)]
xys
pairM :: Monad m => (b -> m c) -> (b,b) -> m (c,c)
pairM :: (b -> m c) -> (b, b) -> m (c, c)
pairM b -> m c
op (b
t1,b
t2) = (c -> c -> (c, c)) -> m c -> m c -> m (c, c)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (b -> m c
op b
t1) (b -> m c
op b
t2)
checkUnique :: (Show a, Eq a) => [a] -> [String]
checkUnique :: [a] -> [String]
checkUnique [a]
ss = [String
"overloaded" String -> String -> String
+++ a -> String
forall a. Show a => a -> String
show a
s | a
s <- [a] -> [a]
forall a. Eq a => [a] -> [a]
nub [a]
overloads] where
overloads :: [a]
overloads = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
overloaded [a]
ss
overloaded :: a -> Bool
overloaded a
s = [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
s) [a]
ss) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
unifyMaybe :: (Eq a, Fail.MonadFail m) => Maybe a -> Maybe a -> m (Maybe a)
unifyMaybe :: Maybe a -> Maybe a -> m (Maybe a)
unifyMaybe = (a -> a) -> Maybe a -> Maybe a -> m (Maybe a)
forall b (m :: * -> *) a.
(Eq b, MonadFail m) =>
(a -> b) -> Maybe a -> Maybe a -> m (Maybe a)
unifyMaybeBy a -> a
forall a. a -> a
id
unifyMaybeBy :: (Eq b, Fail.MonadFail m) => (a->b) -> Maybe a -> Maybe a -> m (Maybe a)
unifyMaybeBy :: (a -> b) -> Maybe a -> Maybe a -> m (Maybe a)
unifyMaybeBy a -> b
f (Just a
p1) (Just a
p2)
| a -> b
f a
p1b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==a -> b
f a
p2 = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Maybe a
forall a. a -> Maybe a
Just a
p1)
| Bool
otherwise = String -> m (Maybe a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
""
unifyMaybeBy a -> b
_ Maybe a
Nothing Maybe a
mp2 = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mp2
unifyMaybeBy a -> b
_ Maybe a
mp1 Maybe a
_ = Maybe a -> m (Maybe a)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mp1
indent :: Int -> String -> String
indent :: Int -> String -> String
indent Int
i String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
i Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
(+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
String
a +++ :: String -> String -> String
+++ String
b = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
String
a ++- :: String -> String -> String
++- String
"" = String
a
String
a ++- String
b = String
a String -> String -> String
+++ String
b
String
a ++++ :: String -> String -> String
++++ String
b = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
String
a +++- :: String -> String -> String
+++- String
"" = String
a
String
a +++- String
b = String
a String -> String -> String
++++ String
b
String
a +++++ :: String -> String -> String
+++++ String
b = String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
b
prUpper :: String -> String
prUpper :: String -> String
prUpper String
s = String
s1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s2' where
(String
s1,String
s2) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isSpace String
s
s2' :: String
s2' = case String
s2 of
Char
c:String
t -> Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
t
String
_ -> String
s2
prReplicate :: Int -> String -> String
prReplicate :: Int -> String -> String
prReplicate Int
n String
s = [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Int -> String -> [String]
forall a. Int -> a -> [a]
replicate Int
n String
s)
prTList :: String -> [String] -> String
prTList :: String -> [String] -> String
prTList String
t [String]
ss = case [String]
ss of
[] -> String
""
[String
s] -> String
s
String
s:[String]
ss -> String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
prTList String
t [String]
ss
prQuotedString :: String -> String
prQuotedString :: String -> String
prQuotedString String
x = String
"\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
restoreEscapes String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\""
prParenth :: String -> String
prParenth :: String -> String
prParenth String
s = if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then String
"" else String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
prCurly, prBracket :: String -> String
prCurly :: String -> String
prCurly String
s = String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}"
prBracket :: String -> String
prBracket String
s = String
"[" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
prArgList, prSemicList, prCurlyList :: [String] -> String
prArgList :: [String] -> String
prArgList = String -> String
prParenth (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String] -> String
prTList String
","
prSemicList :: [String] -> String
prSemicList = String -> [String] -> String
prTList String
" ; "
prCurlyList :: [String] -> String
prCurlyList = String -> String
prCurly (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
prSemicList
restoreEscapes :: String -> String
restoreEscapes :: String -> String
restoreEscapes String
s =
case String
s of
[] -> []
Char
'"' : String
t -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'"' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
restoreEscapes String
t
Char
'\\': String
t -> Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
'\\' Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
restoreEscapes String
t
Char
c : String
t -> Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
restoreEscapes String
t
numberedParagraphs :: [[String]] -> [String]
numberedParagraphs :: [[String]] -> [String]
numberedParagraphs [[String]]
t = case [[String]]
t of
[] -> []
[String]
p:[] -> [String]
p
[[String]]
_ -> [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [(Integer -> String
forall a. Show a => a -> String
show Integer
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
s | (Integer
n,[String]
s) <- [Integer] -> [[String]] -> [(Integer, [String])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Integer
1..] [[String]]
t]
prConjList :: String -> [String] -> String
prConjList :: String -> [String] -> String
prConjList String
c [] = String
""
prConjList String
c [String
s] = String
s
prConjList String
c [String
s,String
t] = String
s String -> String -> String
+++ String
c String -> String -> String
+++ String
t
prConjList String
c (String
s:[String]
tt) = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"," String -> String -> String
+++ String -> [String] -> String
prConjList String
c [String]
tt
prIfEmpty :: String -> String -> String -> String -> String
prIfEmpty :: String -> String -> String -> String -> String
prIfEmpty String
em String
_ String
_ [] = String
em
prIfEmpty String
em String
nem1 String
nem2 String
s = String
nem1 String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
nem2
wrapLines :: Int -> String -> String
wrapLines :: Int -> String -> String
wrapLines Int
n String
"" = String
""
wrapLines Int
n s :: String
s@(Char
c:String
cs) =
if Char -> Bool
isSpace Char
c
then Char
cChar -> String -> String
forall a. a -> [a] -> [a]
:Int -> String -> String
wrapLines (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) String
cs
else case ReadS String
lex String
s of
[(String
w,String
rest)] -> if Int
n'Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
76
then Char
'\n'Char -> String -> String
forall a. a -> [a] -> [a]
:String
wString -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String -> String
wrapLines Int
l String
rest
else String
wString -> String -> String
forall a. [a] -> [a] -> [a]
++Int -> String -> String
wrapLines Int
n' String
rest
where n' :: Int
n' = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
l
l :: Int
l = String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
w
[(String, String)]
_ -> String
s
topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
topoTest :: [(a, [a])] -> Either [a] [[a]]
topoTest = Rel a -> Either [a] [[a]]
forall a. Ord a => Rel a -> Either [a] [[a]]
topologicalSort (Rel a -> Either [a] [[a]])
-> ([(a, [a])] -> Rel a) -> [(a, [a])] -> Either [a] [[a]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(a, [a])] -> Rel a
forall a. Ord a => [(a, [a])] -> Rel a
mkRel'
topoTest2 :: Ord a => [(a,[a])] -> Either [[a]] [[a]]
topoTest2 :: [(a, [a])] -> Either [[a]] [[a]]
topoTest2 [(a, [a])]
g0 = Either [[a]] [[a]]
-> ([[a]] -> Either [[a]] [[a]])
-> Maybe [[a]]
-> Either [[a]] [[a]]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([[a]] -> Either [[a]] [[a]]
forall a b. b -> Either a b
Right [[a]]
cycles) [[a]] -> Either [[a]] [[a]]
forall a b. a -> Either a b
Left ([(a, [a])] -> Maybe [[a]]
forall a. Eq a => [(a, [a])] -> Maybe [[a]]
tsort [(a, [a])]
g)
where
g :: [(a, [a])]
g = [(a, [a])]
g0[(a, [a])] -> [(a, [a])] -> [(a, [a])]
forall a. [a] -> [a] -> [a]
++[(a
n,[])|a
n<-[a] -> [a]
forall a. Eq a => [a] -> [a]
nub (((a, [a]) -> [a]) -> [(a, [a])] -> [a]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (a, [a]) -> [a]
forall a b. (a, b) -> b
snd [(a, [a])]
g0)[a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\((a, [a]) -> a) -> [(a, [a])] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, [a]) -> a
forall a b. (a, b) -> a
fst [(a, [a])]
g0]
cycles :: [[a]]
cycles = Rel a -> [[a]]
forall a. Ord a => Rel a -> [[a]]
findCycles ([(a, [a])] -> Rel a
forall a. Ord a => [(a, [a])] -> Rel a
mkRel' [(a, [a])]
g)
tsort :: [(a, [a])] -> Maybe [[a]]
tsort [(a, [a])]
nes =
case ((a, [a]) -> Bool) -> [(a, [a])] -> ([(a, [a])], [(a, [a])])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null([a] -> Bool) -> ((a, [a]) -> [a]) -> (a, [a]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(a, [a]) -> [a]
forall a b. (a, b) -> b
snd) [(a, [a])]
nes of
([],[]) -> [[a]] -> Maybe [[a]]
forall a. a -> Maybe a
Just []
([],[(a, [a])]
_) -> Maybe [[a]]
forall a. Maybe a
Nothing
([(a, [a])]
ns,[(a, [a])]
rest) -> ([a]
leaves[a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
:) ([[a]] -> [[a]]) -> Maybe [[a]] -> Maybe [[a]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` [(a, [a])] -> Maybe [[a]]
tsort [(a
n,[a]
es [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
leaves) | (a
n,[a]
es)<-[(a, [a])]
rest]
where leaves :: [a]
leaves = ((a, [a]) -> a) -> [(a, [a])] -> [a]
forall a b. (a -> b) -> [a] -> [b]
map (a, [a]) -> a
forall a b. (a, b) -> a
fst [(a, [a])]
ns
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
iterFix :: ([a] -> [a]) -> [a] -> [a]
iterFix [a] -> [a]
more [a]
start = [a] -> [a] -> [a]
iter [a]
start [a]
start
where
iter :: [a] -> [a] -> [a]
iter [a]
old [a]
new = if ([a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
new')
then [a]
old
else [a] -> [a] -> [a]
iter ([a]
new' [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
old) [a]
new'
where
new' :: [a]
new' = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [a]
old) ([a] -> [a]
more [a]
new)
chunks :: Eq a => a -> [a] -> [[a]]
chunks :: a -> [a] -> [[a]]
chunks a
sep [a]
ws = case (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
sep) [a]
ws of
([a]
a,a
_:[a]
b) -> [a]
a [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: [[a]]
bs where bs :: [[a]]
bs = a -> [a] -> [[a]]
forall a. Eq a => a -> [a] -> [[a]]
chunks a
sep [a]
b
([a]
a, []) -> if [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
a then [] else [[a]
a]
readIntArg :: String -> Int
readIntArg :: String -> Int
readIntArg String
n = if (Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
n) Bool -> Bool -> Bool
&& (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
n) then String -> Int
forall a. Read a => String -> a
read String
n else Int
0
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_ m a
a m a
b = m a
a m a -> (String -> m a) -> m a
forall (m :: * -> *) a.
ErrorMonad m =>
m a -> (String -> m a) -> m a
`handle` (\String
_ -> m a
b)
instance ErrorMonad Err where
raise :: String -> Err a
raise = String -> Err a
forall a. String -> Err a
Bad
handle :: Err a -> (String -> Err a) -> Err a
handle a :: Err a
a@(Ok a
_) String -> Err a
_ = Err a
a
handle (Bad String
i) String -> Err a
f = String -> Err a
f String
i
liftErr :: Err a -> m a
liftErr Err a
e = (String -> m a) -> (a -> m a) -> Err a -> m a
forall b a. (String -> b) -> (a -> b) -> Err a -> b
err String -> m a
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Err a
e
checkAgain :: ErrorMonad m => m a -> m a -> m a
checkAgain :: m a -> m a -> m a
checkAgain m a
c1 m a
c2 = m a -> m a -> m a
forall (m :: * -> *) a. ErrorMonad m => m a -> m a -> m a
handle_ m a
c1 m a
c2
checks :: ErrorMonad m => [m a] -> m a
checks :: [m a] -> m a
checks [] = String -> m a
forall (m :: * -> *) a. ErrorMonad m => String -> m a
raise String
"no chance to pass"
checks [m a]
cs = (m a -> m a -> m a) -> [m a] -> m a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldr1 m a -> m a -> m a
forall (m :: * -> *) a. ErrorMonad m => m a -> m a -> m a
checkAgain [m a]
cs