mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-18 09:19:32 -06:00
Replace tabs for whitespace in source code
This commit is contained in:
@@ -16,18 +16,18 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
module GF.Data.BacktrackM (
|
||||
-- * the backtracking state monad
|
||||
BacktrackM,
|
||||
-- * monad specific utilities
|
||||
member,
|
||||
cut,
|
||||
-- * running the monad
|
||||
foldBM, runBM,
|
||||
foldSolutions, solutions,
|
||||
foldFinalStates, finalStates,
|
||||
|
||||
-- * reexport the 'MonadState' class
|
||||
module Control.Monad.State.Class,
|
||||
) where
|
||||
BacktrackM,
|
||||
-- * monad specific utilities
|
||||
member,
|
||||
cut,
|
||||
-- * running the monad
|
||||
foldBM, runBM,
|
||||
foldSolutions, solutions,
|
||||
foldFinalStates, finalStates,
|
||||
|
||||
-- * reexport the 'MonadState' class
|
||||
module Control.Monad.State.Class,
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Control.Applicative
|
||||
@@ -70,7 +70,7 @@ instance Applicative (BacktrackM s) where
|
||||
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)
|
||||
where unBM (BM m) = m
|
||||
where unBM (BM m) = m
|
||||
|
||||
#if !(MIN_VERSION_base(4,13,0))
|
||||
fail = Fail.fail
|
||||
|
||||
@@ -5,7 +5,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/10 16:43:44 $
|
||||
-- > CVS $Date: 2005/11/10 16:43:44 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.2 $
|
||||
--
|
||||
@@ -34,7 +34,7 @@ import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
data Graph n a b = Graph [n] ![Node n a] ![Edge n b]
|
||||
deriving (Eq,Show)
|
||||
deriving (Eq,Show)
|
||||
|
||||
type Node n a = (n,a)
|
||||
type Edge n b = (n,n,b)
|
||||
@@ -63,7 +63,7 @@ emap f (Graph c ns es) = Graph c ns [(x,y,f l) | (x,y,l) <- es]
|
||||
|
||||
-- | Add a node to the graph.
|
||||
newNode :: a -- ^ Node label
|
||||
-> Graph n a b
|
||||
-> Graph n a b
|
||||
-> (Graph n a b,n) -- ^ Node graph and name of new node
|
||||
newNode l (Graph (c:cs) ns es) = (Graph cs ((c,l):ns) es, c)
|
||||
|
||||
@@ -83,7 +83,7 @@ newEdges es g = foldl' (flip newEdge) g es
|
||||
-- lazy version:
|
||||
-- newEdges es' (Graph c ns es) = Graph c ns (es'++es)
|
||||
|
||||
insertEdgeWith :: Eq n =>
|
||||
insertEdgeWith :: Eq n =>
|
||||
(b -> b -> b) -> Edge n b -> Graph n a b -> Graph n a b
|
||||
insertEdgeWith f e@(x,y,l) (Graph c ns es) = Graph c ns (h es)
|
||||
where h [] = [e]
|
||||
@@ -97,7 +97,7 @@ removeNode n = removeNodes (Set.singleton n)
|
||||
-- | Remove a set of nodes and all edges to and from those nodes.
|
||||
removeNodes :: Ord n => Set n -> Graph n a b -> Graph n a b
|
||||
removeNodes xs (Graph c ns es) = Graph c ns' es'
|
||||
where
|
||||
where
|
||||
keepNode n = not (Set.member n xs)
|
||||
ns' = [ x | x@(n,_) <- ns, keepNode n ]
|
||||
es' = [ e | e@(f,t,_) <- es, keepNode f && keepNode t ]
|
||||
@@ -105,7 +105,7 @@ removeNodes xs (Graph c ns es) = Graph c ns' es'
|
||||
-- | Get a map of node names to info about each node.
|
||||
nodeInfo :: Ord n => Graph n a b -> NodeInfo n a b
|
||||
nodeInfo g = Map.fromList [ (n, (x, fn inc n, fn out n)) | (n,x) <- nodes g ]
|
||||
where
|
||||
where
|
||||
inc = groupEdgesBy edgeTo g
|
||||
out = groupEdgesBy edgeFrom g
|
||||
fn m n = fromMaybe [] (Map.lookup n m)
|
||||
@@ -148,16 +148,16 @@ reverseGraph :: Graph n a b -> Graph n a b
|
||||
reverseGraph (Graph c ns es) = Graph c ns [ (t,f,l) | (f,t,l) <- es ]
|
||||
|
||||
-- | Add the nodes from the second graph to the first graph.
|
||||
-- The nodes in the second graph will be renamed using the name
|
||||
-- The nodes in the second graph will be renamed using the name
|
||||
-- supply in the first graph.
|
||||
-- This function is more efficient when the second graph
|
||||
-- is smaller than the first.
|
||||
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
|
||||
mergeGraphs :: Ord m => Graph n a b -> Graph m a b
|
||||
-> (Graph n a b, m -> n) -- ^ The new graph and a function translating
|
||||
-- the old names of nodes in the second graph
|
||||
-- to names in the new graph.
|
||||
mergeGraphs (Graph c ns1 es1) g2 = (Graph c' (ns2++ns1) (es2++es1), newName)
|
||||
where
|
||||
where
|
||||
(xs,c') = splitAt (length (nodes g2)) c
|
||||
newNames = Map.fromList (zip (map fst (nodes g2)) xs)
|
||||
newName n = fromJust $ Map.lookup n newNames
|
||||
@@ -170,7 +170,7 @@ renameNodes :: (n -> m) -- ^ renaming function
|
||||
-> Graph n a b -> Graph m a b
|
||||
renameNodes newName c (Graph _ ns es) = Graph c ns' es'
|
||||
where ns' = map' (\ (n,x) -> (newName n,x)) ns
|
||||
es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
|
||||
es' = map' (\ (f,t,l) -> (newName f, newName t, l)) es
|
||||
|
||||
-- | A strict 'map'
|
||||
map' :: (a -> b) -> [a] -> [b]
|
||||
|
||||
@@ -5,7 +5,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/09/15 18:10:44 $
|
||||
-- > CVS $Date: 2005/09/15 18:10:44 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.2 $
|
||||
--
|
||||
@@ -13,14 +13,14 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.Graphviz (
|
||||
Graph(..), GraphType(..),
|
||||
Node(..), Edge(..),
|
||||
Attr,
|
||||
addSubGraphs,
|
||||
setName,
|
||||
setAttr,
|
||||
prGraphviz
|
||||
) where
|
||||
Graph(..), GraphType(..),
|
||||
Node(..), Edge(..),
|
||||
Attr,
|
||||
addSubGraphs,
|
||||
setName,
|
||||
setAttr,
|
||||
prGraphviz
|
||||
) where
|
||||
|
||||
import Data.Char
|
||||
|
||||
@@ -70,14 +70,14 @@ prGraphviz g@(Graph t i _ _ _ _) =
|
||||
graphtype t ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}\n"
|
||||
|
||||
prSubGraph :: Graph -> String
|
||||
prSubGraph g@(Graph _ i _ _ _ _) =
|
||||
prSubGraph g@(Graph _ i _ _ _ _) =
|
||||
"subgraph" ++ " " ++ maybe "" esc i ++ " {\n" ++ prGraph g ++ "}"
|
||||
|
||||
prGraph :: Graph -> String
|
||||
prGraph (Graph t id at ns es ss) =
|
||||
prGraph (Graph t id at ns es ss) =
|
||||
unlines $ map (++";") (map prAttr at
|
||||
++ map prNode ns
|
||||
++ map (prEdge t) es
|
||||
++ map prNode ns
|
||||
++ map (prEdge t) es
|
||||
++ map prSubGraph ss)
|
||||
|
||||
graphtype :: GraphType -> String
|
||||
@@ -96,7 +96,7 @@ edgeop Undirected = "--"
|
||||
|
||||
prAttrList :: [Attr] -> String
|
||||
prAttrList [] = ""
|
||||
prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
|
||||
prAttrList at = "[" ++ join "," (map prAttr at) ++ "]"
|
||||
|
||||
prAttr :: Attr -> String
|
||||
prAttr (n,v) = esc n ++ " = " ++ esc v
|
||||
|
||||
@@ -5,7 +5,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/11 16:12:41 $
|
||||
-- > CVS $Date: 2005/11/11 16:12:41 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.22 $
|
||||
--
|
||||
@@ -15,34 +15,34 @@
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.Operations (
|
||||
-- ** The Error monad
|
||||
Err(..), err, maybeErr, testErr, fromErr, errIn,
|
||||
lookupErr,
|
||||
-- ** The Error monad
|
||||
Err(..), err, maybeErr, testErr, fromErr, errIn,
|
||||
lookupErr,
|
||||
|
||||
-- ** Error monad class
|
||||
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
|
||||
liftErr,
|
||||
|
||||
-- ** Checking
|
||||
checkUnique, unifyMaybeBy, unifyMaybe,
|
||||
-- ** Error monad class
|
||||
ErrorMonad(..), checks, --doUntil, allChecks, checkAgain,
|
||||
liftErr,
|
||||
|
||||
-- ** Monadic operations on lists and pairs
|
||||
mapPairsM, pairM,
|
||||
|
||||
-- ** Printing
|
||||
indent, (+++), (++-), (++++), (+++-), (+++++),
|
||||
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
|
||||
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
|
||||
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
|
||||
-- ** Checking
|
||||
checkUnique, unifyMaybeBy, unifyMaybe,
|
||||
|
||||
-- ** Topological sorting
|
||||
topoTest, topoTest2,
|
||||
-- ** Monadic operations on lists and pairs
|
||||
mapPairsM, pairM,
|
||||
|
||||
-- ** Misc
|
||||
readIntArg,
|
||||
iterFix, chunks,
|
||||
|
||||
) where
|
||||
-- ** Printing
|
||||
indent, (+++), (++-), (++++), (+++-), (+++++),
|
||||
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
|
||||
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
|
||||
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
|
||||
|
||||
-- ** Topological sorting
|
||||
topoTest, topoTest2,
|
||||
|
||||
-- ** Misc
|
||||
readIntArg,
|
||||
iterFix, chunks,
|
||||
|
||||
) where
|
||||
|
||||
import Data.Char (isSpace, toUpper, isSpace, isDigit)
|
||||
import Data.List (nub, partition, (\\))
|
||||
@@ -107,7 +107,7 @@ indent i s = replicate i ' ' ++ s
|
||||
(+++), (++-), (++++), (+++-), (+++++) :: String -> String -> String
|
||||
a +++ b = a ++ " " ++ b
|
||||
|
||||
a ++- "" = a
|
||||
a ++- "" = a
|
||||
a ++- b = a +++ b
|
||||
|
||||
a ++++ b = a ++ "\n" ++ b
|
||||
@@ -145,20 +145,20 @@ prCurly s = "{" ++ s ++ "}"
|
||||
prBracket s = "[" ++ s ++ "]"
|
||||
|
||||
prArgList, prSemicList, prCurlyList :: [String] -> String
|
||||
prArgList = prParenth . prTList ","
|
||||
prArgList = prParenth . prTList ","
|
||||
prSemicList = prTList " ; "
|
||||
prCurlyList = prCurly . prSemicList
|
||||
|
||||
restoreEscapes :: String -> String
|
||||
restoreEscapes s =
|
||||
case s of
|
||||
restoreEscapes s =
|
||||
case s of
|
||||
[] -> []
|
||||
'"' : t -> '\\' : '"' : restoreEscapes t
|
||||
'\\': t -> '\\' : '\\' : restoreEscapes t
|
||||
c : t -> c : restoreEscapes t
|
||||
|
||||
numberedParagraphs :: [[String]] -> [String]
|
||||
numberedParagraphs t = case t of
|
||||
numberedParagraphs t = case t of
|
||||
[] -> []
|
||||
p:[] -> p
|
||||
_ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t]
|
||||
@@ -204,12 +204,12 @@ topoTest2 g0 = maybe (Right cycles) Left (tsort g)
|
||||
([],[]) -> Just []
|
||||
([],_) -> Nothing
|
||||
(ns,rest) -> (leaves:) `fmap` tsort [(n,es \\ leaves) | (n,es)<-rest]
|
||||
where leaves = map fst ns
|
||||
where leaves = map fst ns
|
||||
|
||||
|
||||
-- | Fix point iterator (for computing e.g. transitive closures or reachability)
|
||||
iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a]
|
||||
iterFix more start = iter start start
|
||||
iterFix more start = iter start start
|
||||
where
|
||||
iter old new = if (null new')
|
||||
then old
|
||||
@@ -241,7 +241,7 @@ 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 (STM f) g = STM (\s -> (f s)
|
||||
`handle` (\e -> let STM g' = (g e) in
|
||||
g' s))
|
||||
|
||||
|
||||
@@ -5,7 +5,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Date: 2005/10/26 17:13:13 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.1 $
|
||||
--
|
||||
@@ -83,7 +83,7 @@ transitiveClosure r = fix (Map.map growSet) r
|
||||
where growSet ys = foldl Set.union ys (map (allRelated r) $ Set.toList ys)
|
||||
|
||||
reflexiveClosure_ :: Ord a => [a] -- ^ The set over which the relation is defined.
|
||||
-> Rel a -> Rel a
|
||||
-> Rel a -> Rel a
|
||||
reflexiveClosure_ u r = relates [(x,x) | x <- u] r
|
||||
|
||||
-- | Uses 'domain'
|
||||
@@ -104,7 +104,7 @@ reflexiveElements :: Ord a => Rel a -> Set a
|
||||
reflexiveElements r = Set.fromList [ x | (x,ys) <- Map.toList r, x `Set.member` ys ]
|
||||
|
||||
-- | Keep the related pairs for which the predicate is true.
|
||||
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
|
||||
filterRel :: Ord a => (a -> a -> Bool) -> Rel a -> Rel a
|
||||
filterRel p = fst . purgeEmpty . Map.mapWithKey (Set.filter . p)
|
||||
|
||||
-- | Remove keys that map to no elements.
|
||||
@@ -112,16 +112,16 @@ purgeEmpty :: Ord a => Rel a -> (Rel a, Set a)
|
||||
purgeEmpty r = let (r',r'') = Map.partition (not . Set.null) r
|
||||
in (r', Map.keysSet r'')
|
||||
|
||||
-- | Get the equivalence classes from an equivalence relation.
|
||||
-- | Get the equivalence classes from an equivalence relation.
|
||||
equivalenceClasses :: Ord a => Rel a -> [Set a]
|
||||
equivalenceClasses r = equivalenceClasses_ (Map.keys r) r
|
||||
where equivalenceClasses_ [] _ = []
|
||||
equivalenceClasses_ (x:xs) r = ys:equivalenceClasses_ zs r
|
||||
where ys = allRelated r x
|
||||
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
|
||||
where ys = allRelated r x
|
||||
zs = [x' | x' <- xs, not (x' `Set.member` ys)]
|
||||
|
||||
isTransitive :: Ord a => Rel a -> Bool
|
||||
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
|
||||
isTransitive r = and [z `Set.member` ys | (x,ys) <- Map.toList r,
|
||||
y <- Set.toList ys, z <- Set.toList (allRelated r y)]
|
||||
|
||||
isReflexive :: Ord a => Rel a -> Bool
|
||||
@@ -181,7 +181,7 @@ remove x r = let (mss,r') = Map.updateLookupWithKey (\_ _ -> Nothing) x r
|
||||
Nothing -> (r', Set.empty, Set.empty)
|
||||
-- remove element from all incoming and outgoing sets
|
||||
-- of other elements
|
||||
Just (is,os) ->
|
||||
Just (is,os) ->
|
||||
let r'' = foldr (\i -> Map.adjust (\ (is',os') -> (is', Set.delete x os')) i) r' $ Set.toList is
|
||||
r''' = foldr (\o -> Map.adjust (\ (is',os') -> (Set.delete x is', os')) o) r'' $ Set.toList os
|
||||
in (r''', is, os)
|
||||
@@ -190,4 +190,4 @@ incoming :: Ord a => a -> Rel' a -> Set a
|
||||
incoming x r = maybe Set.empty fst $ Map.lookup x r
|
||||
|
||||
--outgoing :: Ord a => a -> Rel' a -> Set a
|
||||
--outgoing x r = maybe Set.empty snd $ Map.lookup x r
|
||||
--outgoing x r = maybe Set.empty snd $ Map.lookup x r
|
||||
|
||||
@@ -4,7 +4,7 @@
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/26 18:47:16 $
|
||||
-- > CVS $Date: 2005/10/26 18:47:16 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
@@ -33,7 +33,7 @@ longerThan n = not . notLongerThan n
|
||||
lookupList :: Eq a => a -> [(a, b)] -> [b]
|
||||
lookupList a [] = []
|
||||
lookupList a (p:ps) | a == fst p = snd p : lookupList a ps
|
||||
| otherwise = lookupList a ps
|
||||
| otherwise = lookupList a ps
|
||||
|
||||
split :: [a] -> ([a], [a])
|
||||
split (x : y : as) = (x:xs, y:ys)
|
||||
@@ -48,8 +48,8 @@ splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
|
||||
foldMerge :: (a -> a -> a) -> a -> [a] -> a
|
||||
foldMerge merge zero = fm
|
||||
where fm [] = zero
|
||||
fm [a] = a
|
||||
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
|
||||
fm [a] = a
|
||||
fm abs = let (as, bs) = split abs in fm as `merge` fm bs
|
||||
|
||||
select :: [a] -> [(a, [a])]
|
||||
select [] = []
|
||||
@@ -68,7 +68,7 @@ safeInit :: [a] -> [a]
|
||||
safeInit [] = []
|
||||
safeInit xs = init xs
|
||||
|
||||
-- | Sorts and then groups elements given an ordering of the
|
||||
-- | Sorts and then groups elements given an ordering of the
|
||||
-- elements.
|
||||
sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
|
||||
sortGroupBy f = groupBy (compareEq f) . sortBy f
|
||||
|
||||
Reference in New Issue
Block a user