mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 19:22:50 -06:00
changed names of resource-1.3; added a note on homepage on release
This commit is contained in:
aarne
143
src/GF/Data/Assoc.hs
Normal file
143
src/GF/Data/Assoc.hs
Normal file
@@ -0,0 +1,143 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Assoc
|
||||
-- Maintainer : Peter Ljunglöf
|
||||
-- Stability : Stable
|
||||
-- Portability : Haskell 98
|
||||
--
|
||||
-- > CVS $Date: 2005/05/09 09:28:44 $
|
||||
-- > CVS $Author: peb $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- Association lists, or finite maps,
|
||||
-- including sets as maps with result type @()@.
|
||||
-- function names stolen from module @Array@.
|
||||
-- /O(log n)/ key lookup
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.Assoc ( Assoc,
|
||||
Set,
|
||||
emptyAssoc,
|
||||
emptySet,
|
||||
listAssoc,
|
||||
listSet,
|
||||
accumAssoc,
|
||||
aAssocs,
|
||||
aElems,
|
||||
assocMap,
|
||||
assocFilter,
|
||||
lookupAssoc,
|
||||
lookupWith,
|
||||
(?),
|
||||
(?=)
|
||||
) where
|
||||
|
||||
import GF.Data.SortedList
|
||||
|
||||
infixl 9 ?, ?=
|
||||
|
||||
-- | a set is a finite map with empty values
|
||||
type Set a = Assoc a ()
|
||||
|
||||
emptyAssoc :: Ord a => Assoc a b
|
||||
emptySet :: Ord a => Set a
|
||||
|
||||
-- | creating a finite map from a sorted key-value list
|
||||
listAssoc :: Ord a => SList (a, b) -> Assoc a b
|
||||
|
||||
-- | creating a set from a sorted list
|
||||
listSet :: Ord a => SList a -> Set a
|
||||
|
||||
-- | building a finite map from a list of keys and 'b's,
|
||||
-- and a function that combines a sorted list of 'b's into a value
|
||||
accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b
|
||||
|
||||
-- | all key-value pairs from an association list
|
||||
aAssocs :: Ord a => Assoc a b -> SList (a, b)
|
||||
|
||||
-- | all keys from an association list
|
||||
aElems :: Ord a => Assoc a b -> SList a
|
||||
|
||||
-- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b'
|
||||
|
||||
-- | mapping values to other values.
|
||||
-- the mapping function can take the key as information
|
||||
assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b'
|
||||
|
||||
assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b
|
||||
assocFilter pred = listAssoc . filter (pred . snd) . aAssocs
|
||||
|
||||
-- | monadic lookup function,
|
||||
-- returning failure if the key does not exist
|
||||
lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b
|
||||
|
||||
-- | if the key does not exist,
|
||||
-- the first argument is returned
|
||||
lookupWith :: Ord a => b -> Assoc a b -> a -> b
|
||||
|
||||
-- | if the values are monadic, we can return the value type
|
||||
(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b
|
||||
|
||||
-- | checking wheter the map contains a given key
|
||||
(?=) :: Ord a => Assoc a b -> a -> Bool
|
||||
|
||||
|
||||
------------------------------------------------------------
|
||||
|
||||
data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
emptyAssoc = ANil
|
||||
emptySet = emptyAssoc
|
||||
|
||||
listAssoc as = assoc
|
||||
where (assoc, []) = sl2bst (length as) as
|
||||
sl2bst 0 xs = (ANil, xs)
|
||||
sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs)
|
||||
sl2bst n xs = (ANode left (fst x) (snd x) right, zs)
|
||||
where llen = (n-1) `div` 2
|
||||
rlen = n - 1 - llen
|
||||
(left, x:ys) = sl2bst llen xs
|
||||
(right, zs) = sl2bst rlen ys
|
||||
|
||||
listSet as = listAssoc (zip as (repeat ()))
|
||||
|
||||
accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort
|
||||
where mapSnd f (a, b) = (a, f b)
|
||||
|
||||
aAssocs as = prs as []
|
||||
where prs ANil = id
|
||||
prs (ANode left a b right) = prs left . ((a,b) :) . prs right
|
||||
|
||||
aElems = map fst . aAssocs
|
||||
|
||||
|
||||
instance Ord a => Functor (Assoc a) where
|
||||
fmap f = assocMap (const f)
|
||||
|
||||
assocMap f ANil = ANil
|
||||
assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right)
|
||||
|
||||
|
||||
lookupAssoc ANil _ = fail "key not found"
|
||||
lookupAssoc (ANode left a b right) a' = case compare a a' of
|
||||
GT -> lookupAssoc left a'
|
||||
LT -> lookupAssoc right a'
|
||||
EQ -> return b
|
||||
|
||||
lookupWith z ANil _ = z
|
||||
lookupWith z (ANode left a b right) a' = case compare a a' of
|
||||
GT -> lookupWith z left a'
|
||||
LT -> lookupWith z right a'
|
||||
EQ -> b
|
||||
|
||||
(?) = lookupWith (fail "key not found")
|
||||
|
||||
(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
93
src/GF/Data/BacktrackM.hs
Normal file
93
src/GF/Data/BacktrackM.hs
Normal file
@@ -0,0 +1,93 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : BacktrackM
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:00 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.4 $
|
||||
--
|
||||
-- Backtracking state monad, with r\/o environment
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
{-# OPTIONS_GHC -fglasgow-exts #-}
|
||||
module GF.Data.BacktrackM ( -- * the backtracking state monad
|
||||
BacktrackM,
|
||||
-- * controlling the monad
|
||||
failure,
|
||||
(|||),
|
||||
-- * handling the state & environment
|
||||
readState,
|
||||
writeState,
|
||||
-- * monad specific utilities
|
||||
member,
|
||||
-- * running the monad
|
||||
foldBM, runBM,
|
||||
foldSolutions, solutions,
|
||||
foldFinalStates, finalStates
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Control.Monad
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- Combining endomorphisms and continuations
|
||||
-- a la Ralf Hinze
|
||||
|
||||
-- BacktrackM = state monad transformer over the backtracking monad
|
||||
|
||||
newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b)
|
||||
|
||||
-- * running the monad
|
||||
|
||||
runBM :: BacktrackM s a -> s -> [(s,a)]
|
||||
runBM (BM m) s = m (\x s xs -> (s,x) : xs) s []
|
||||
|
||||
foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b
|
||||
foldBM f b (BM m) s = m f s b
|
||||
|
||||
foldSolutions :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b
|
||||
foldSolutions f b (BM m) s = m (\x s b -> f x b) s b
|
||||
|
||||
solutions :: BacktrackM s a -> s -> [a]
|
||||
solutions = foldSolutions (:) []
|
||||
|
||||
foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b
|
||||
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
|
||||
|
||||
|
||||
-- * handling the state & environment
|
||||
|
||||
readState :: BacktrackM s s
|
||||
readState = BM (\c s b -> c s s b)
|
||||
|
||||
writeState :: s -> BacktrackM s ()
|
||||
writeState s = BM (\c _ b -> c () s b)
|
||||
|
||||
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
|
||||
fail _ = failure
|
||||
|
||||
-- * controlling the monad
|
||||
|
||||
failure :: BacktrackM s a
|
||||
failure = BM (\c s b -> b)
|
||||
|
||||
(|||) :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a
|
||||
(BM f) ||| (BM g) = BM (\c s b -> g c s $! f c s b)
|
||||
|
||||
instance MonadPlus (BacktrackM s) where
|
||||
mzero = failure
|
||||
mplus = (|||)
|
||||
|
||||
-- * specific functions on the backtracking monad
|
||||
|
||||
member :: [a] -> BacktrackM s a
|
||||
member xs = BM (\c s b -> foldl' (\b x -> c x s b) b xs)
|
||||
38
src/GF/Data/ErrM.hs
Normal file
38
src/GF/Data/ErrM.hs
Normal file
@@ -0,0 +1,38 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : ErrM
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:00 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.5 $
|
||||
--
|
||||
-- hack for BNFC generated files. AR 21/9/2003
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.ErrM (Err(..)) where
|
||||
|
||||
import Control.Monad (MonadPlus(..))
|
||||
|
||||
-- | like @Maybe@ type with error msgs
|
||||
data Err a = Ok a | Bad String
|
||||
deriving (Read, Show, Eq)
|
||||
|
||||
instance Monad Err where
|
||||
return = Ok
|
||||
fail = Bad
|
||||
Ok a >>= f = f a
|
||||
Bad s >>= f = Bad s
|
||||
|
||||
-- | added 2\/10\/2003 by PEB
|
||||
instance Functor Err where
|
||||
fmap f (Ok a) = Ok (f a)
|
||||
fmap f (Bad s) = Bad s
|
||||
|
||||
-- | added by KJ
|
||||
instance MonadPlus Err where
|
||||
mzero = Bad "error (no reason given)"
|
||||
mplus (Ok a) _ = Ok a
|
||||
mplus (Bad s) b = b
|
||||
47
src/GF/Data/MultiMap.hs
Normal file
47
src/GF/Data/MultiMap.hs
Normal file
@@ -0,0 +1,47 @@
|
||||
module GF.Data.MultiMap where
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Prelude hiding (map)
|
||||
import qualified Prelude
|
||||
|
||||
type MultiMap k a = Map k (Set a)
|
||||
|
||||
empty :: MultiMap k a
|
||||
empty = Map.empty
|
||||
|
||||
keys :: MultiMap k a -> [k]
|
||||
keys = Map.keys
|
||||
|
||||
elems :: MultiMap k a -> [a]
|
||||
elems = concatMap Set.toList . Map.elems
|
||||
|
||||
(!) :: Ord k => MultiMap k a -> k -> [a]
|
||||
m ! k = Set.toList $ Map.findWithDefault Set.empty k m
|
||||
|
||||
member :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Bool
|
||||
member k x m = x `Set.member` Map.findWithDefault Set.empty k m
|
||||
|
||||
insert :: (Ord k, Ord a) => k -> a -> MultiMap k a -> MultiMap k a
|
||||
insert k x m = Map.insertWith Set.union k (Set.singleton x) m
|
||||
|
||||
insert' :: (Ord k, Ord a) => k -> a -> MultiMap k a -> Maybe (MultiMap k a)
|
||||
insert' k x m | member k x m = Nothing -- FIXME: inefficient
|
||||
| otherwise = Just (insert k x m)
|
||||
|
||||
union :: (Ord k, Ord a) => MultiMap k a -> MultiMap k a -> MultiMap k a
|
||||
union = Map.unionWith Set.union
|
||||
|
||||
size :: MultiMap k a -> Int
|
||||
size = sum . Prelude.map Set.size . Map.elems
|
||||
|
||||
map :: (Ord a, Ord b) => (a -> b) -> MultiMap k a -> MultiMap k b
|
||||
map f = Map.map (Set.map f)
|
||||
|
||||
fromList :: (Ord k, Ord a) => [(k,a)] -> MultiMap k a
|
||||
fromList xs = Map.fromListWith Set.union [(k, Set.singleton x) | (k,x) <- xs]
|
||||
|
||||
toList :: MultiMap k a -> [(k,a)]
|
||||
toList m = [(k,x) | (k,s) <- Map.toList m, x <- Set.toList s]
|
||||
676
src/GF/Data/Operations.hs
Normal file
676
src/GF/Data/Operations.hs
Normal file
@@ -0,0 +1,676 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- 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, onSnd,
|
||||
|
||||
-- * the Error monad
|
||||
Err(..), err, maybeErr, testErr, errVal, errIn, derrIn,
|
||||
performOps, repeatUntilErr, repeatUntil, okError, isNotError,
|
||||
showBad, lookupErr, lookupErrMsg, lookupDefault, updateLookupList,
|
||||
mapPairListM, mapPairsM, pairM, mapErr, mapErrN, foldErr,
|
||||
(!?), errList, singleton, mapsErr, mapsErrTree,
|
||||
|
||||
-- ** checking
|
||||
checkUnique, titleIfNeeded, errMsg, errAndMsg,
|
||||
|
||||
-- * a three-valued maybe type to express indirections
|
||||
Perhaps(..), yes, may, nope,
|
||||
mapP,
|
||||
unifPerhaps, updatePerhaps, updatePerhapsHard,
|
||||
|
||||
-- * binary search trees; now with FiniteMap
|
||||
BinTree, emptyBinTree, isInBinTree, justLookupTree,
|
||||
lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree,
|
||||
buildTree, filterBinTree,
|
||||
sorted2tree, mapTree, mapMTree, tree2list,
|
||||
|
||||
|
||||
-- * parsing
|
||||
WParser, wParseResults, paragraphs,
|
||||
|
||||
-- * printing
|
||||
indent, (+++), (++-), (++++), (+++++),
|
||||
prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly,
|
||||
prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes,
|
||||
numberedParagraphs, prConjList, prIfEmpty, wrapLines,
|
||||
|
||||
-- ** LaTeX code producing functions
|
||||
dollar, mbox, ital, boldf, verbat, mkLatexFile,
|
||||
begindocument, enddocument,
|
||||
|
||||
-- * extra
|
||||
sortByLongest, combinations, mkTextFile, initFilePath,
|
||||
|
||||
-- * topological sorting with test of cyclicity
|
||||
topoTest, topoSort, cyclesIn,
|
||||
|
||||
-- * the generic fix point iterator
|
||||
iterFix,
|
||||
|
||||
-- * association lists
|
||||
updateAssoc, removeAssoc,
|
||||
|
||||
-- * chop into separator-separated parts
|
||||
chunks, readIntArg, subSequences,
|
||||
|
||||
-- * state monad with error; from Agda 6\/11\/2001
|
||||
STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done,
|
||||
|
||||
-- * error monad class
|
||||
ErrorMonad(..), checkAgain, checks, allChecks, doUntil
|
||||
|
||||
) where
|
||||
|
||||
import Data.Char (isSpace, toUpper, isSpace, isDigit)
|
||||
import Data.List (nub, sortBy, sort, deleteBy, nubBy)
|
||||
--import Data.FiniteMap
|
||||
import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus)
|
||||
|
||||
import GF.Data.ErrM
|
||||
|
||||
infixr 5 +++
|
||||
infixr 5 ++-
|
||||
infixr 5 ++++
|
||||
infixr 5 +++++
|
||||
infixl 9 !?
|
||||
|
||||
ifNull :: b -> ([a] -> b) -> [a] -> b
|
||||
ifNull b f xs = if null xs then b else f xs
|
||||
|
||||
onSnd :: (a -> b) -> (c,a) -> (c,b)
|
||||
onSnd f (x, y) = (x, f y)
|
||||
|
||||
-- the Error monad
|
||||
|
||||
-- | analogue of @maybe@
|
||||
err :: (String -> b) -> (a -> b) -> Err a -> b
|
||||
err d f e = case e of
|
||||
Ok a -> f a
|
||||
Bad s -> d s
|
||||
|
||||
-- | add msg s to @Maybe@ failures
|
||||
maybeErr :: String -> Maybe a -> Err a
|
||||
maybeErr s = maybe (Bad s) Ok
|
||||
|
||||
testErr :: Bool -> String -> Err ()
|
||||
testErr cond msg = if cond then return () else Bad msg
|
||||
|
||||
errVal :: a -> Err a -> a
|
||||
errVal a = err (const a) id
|
||||
|
||||
errIn :: String -> Err a -> Err a
|
||||
errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return
|
||||
|
||||
-- | used for extra error reports when developing GF
|
||||
derrIn :: String -> Err a -> Err a
|
||||
derrIn m = errIn m -- id
|
||||
|
||||
performOps :: [a -> Err a] -> a -> Err a
|
||||
performOps ops a = case ops of
|
||||
f:fs -> f a >>= performOps fs
|
||||
[] -> return a
|
||||
|
||||
repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a
|
||||
repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f
|
||||
|
||||
repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a
|
||||
repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a)
|
||||
|
||||
okError :: Err a -> a
|
||||
-- okError = err (error "no result Ok") id
|
||||
okError = err (error . ("Bad result occurred" ++++)) id
|
||||
|
||||
isNotError :: Err a -> Bool
|
||||
isNotError = err (const False) (const True)
|
||||
|
||||
showBad :: Show a => String -> a -> Err b
|
||||
showBad s a = Bad (s +++ show a)
|
||||
|
||||
lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b
|
||||
lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
|
||||
|
||||
lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b
|
||||
lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs)
|
||||
|
||||
lookupDefault :: Eq a => b -> a -> [(a,b)] -> b
|
||||
lookupDefault d x l = maybe d id $ lookup x l
|
||||
|
||||
updateLookupList :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
|
||||
updateLookupList ab abs = insert ab [] abs where
|
||||
insert c cc [] = cc ++ [c]
|
||||
insert (a,b) cc ((a',b'):cc') = if a == a'
|
||||
then cc ++ [(a,b)] ++ cc'
|
||||
else insert (a,b) (cc ++ [(a',b')]) cc'
|
||||
|
||||
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 a => (b -> a c) -> (b,b) -> a (c,c)
|
||||
pairM op (t1,t2) = liftM2 (,) (op t1) (op t2)
|
||||
|
||||
-- | like @mapM@, but continue instead of halting with 'Err'
|
||||
mapErr :: (a -> Err b) -> [a] -> Err ([b], String)
|
||||
mapErr f xs = Ok (ys, unlines ss)
|
||||
where
|
||||
(ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs])
|
||||
fxs = map f xs
|
||||
|
||||
-- | alternative variant, peb 9\/6-04
|
||||
mapErrN :: Int -> (a -> Err b) -> [a] -> Err ([b], String)
|
||||
mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2))
|
||||
where
|
||||
(ys, ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs])
|
||||
errHdr = show nss ++ " errors occured" ++
|
||||
if nss > maxN then ", showing the first " ++ show maxN else ""
|
||||
ss2 = map ("* "++) $ take maxN ss
|
||||
nss = length ss
|
||||
fxs = map f xs
|
||||
|
||||
|
||||
-- | like @foldM@, but also return the latest value if fails
|
||||
foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String)
|
||||
foldErr f s xs = case xs of
|
||||
[] -> return (s,Nothing)
|
||||
x:xx -> case f s x of
|
||||
Ok v -> foldErr f v xx
|
||||
Bad m -> return $ (s, Just m)
|
||||
|
||||
-- @!!@ with the error monad
|
||||
(!?) :: [a] -> Int -> Err a
|
||||
xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs
|
||||
|
||||
errList :: Err [a] -> [a]
|
||||
errList = errVal []
|
||||
|
||||
singleton :: a -> [a]
|
||||
singleton = (:[])
|
||||
|
||||
-- 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
|
||||
|
||||
titleIfNeeded :: a -> [a] -> [a]
|
||||
titleIfNeeded a [] = []
|
||||
titleIfNeeded a as = a:as
|
||||
|
||||
errMsg :: Err a -> [String]
|
||||
errMsg (Bad m) = [m]
|
||||
errMsg _ = []
|
||||
|
||||
errAndMsg :: Err a -> Err (a,[String])
|
||||
errAndMsg (Bad m) = Bad m
|
||||
errAndMsg (Ok a) = return (a,[])
|
||||
|
||||
-- | a three-valued maybe type to express indirections
|
||||
data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord)
|
||||
|
||||
yes :: a -> Perhaps a b
|
||||
yes = Yes
|
||||
|
||||
may :: b -> Perhaps a b
|
||||
may = May
|
||||
|
||||
nope :: Perhaps a b
|
||||
nope = Nope
|
||||
|
||||
mapP :: (a -> c) -> Perhaps a b -> Perhaps c b
|
||||
mapP f p = case p of
|
||||
Yes a -> Yes (f a)
|
||||
May b -> May b
|
||||
Nope -> Nope
|
||||
|
||||
-- | this is what happens when matching two values in the same module
|
||||
unifPerhaps :: (Eq a, Eq b, Show a, Show b) =>
|
||||
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
|
||||
unifPerhaps p1 p2 = case (p1,p2) of
|
||||
(Nope, _) -> return p2
|
||||
(_, Nope) -> return p1
|
||||
_ -> if p1==p2 then return p1
|
||||
else Bad ("update conflict between" ++++ show p1 ++++ show p2)
|
||||
|
||||
-- | this is what happens when updating a module extension
|
||||
updatePerhaps :: (Eq a,Eq b, Show a, Show b) =>
|
||||
b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
|
||||
updatePerhaps old p1 p2 = case (p1,p2) of
|
||||
(Yes a, Nope) -> return $ may old
|
||||
(May older,Nope) -> return $ may older
|
||||
(_, May a) -> Bad "strange indirection"
|
||||
_ -> unifPerhaps p1 p2
|
||||
|
||||
-- | here the value is copied instead of referred to; used for oper types
|
||||
updatePerhapsHard :: (Eq a, Eq b, Show a, Show b) => b ->
|
||||
Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
|
||||
updatePerhapsHard old p1 p2 = case (p1,p2) of
|
||||
(Yes a, Nope) -> return $ yes a
|
||||
(May older,Nope) -> return $ may older
|
||||
(_, May a) -> Bad "strange indirection"
|
||||
_ -> unifPerhaps p1 p2
|
||||
|
||||
-- binary search trees
|
||||
--- FiniteMap implementation is slower in crucial tests
|
||||
|
||||
data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show)
|
||||
-- type BinTree a b = FiniteMap a b
|
||||
|
||||
emptyBinTree :: BinTree a b
|
||||
emptyBinTree = NT
|
||||
-- emptyBinTree = emptyFM
|
||||
|
||||
isInBinTree :: (Ord a) => a -> BinTree a b -> Bool
|
||||
isInBinTree x = err (const False) (const True) . justLookupTree x
|
||||
-- isInBinTree = elemFM
|
||||
|
||||
justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b
|
||||
justLookupTree = lookupTree (const [])
|
||||
|
||||
lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b
|
||||
lookupTree pr x tree = case tree of
|
||||
NT -> fail ("no occurrence of element" +++ pr x)
|
||||
BT (a,b) left right
|
||||
| x < a -> lookupTree pr x left
|
||||
| x > a -> lookupTree pr x right
|
||||
| x == a -> return b
|
||||
--lookupTree pr x tree = case lookupFM tree x of
|
||||
-- Just y -> return y
|
||||
-- _ -> fail ("no occurrence of element" +++ pr x)
|
||||
|
||||
lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b
|
||||
lookupTreeMany pr (t:ts) x = case lookupTree pr x t of
|
||||
Ok v -> return v
|
||||
_ -> lookupTreeMany pr ts x
|
||||
lookupTreeMany pr [] x = Bad $ "failed to find" +++ 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 = []
|
||||
|
||||
-- | destructive update
|
||||
updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b
|
||||
-- updateTree (a,b) tr = addToFM tr a b
|
||||
updateTree = updateTreeGen True
|
||||
|
||||
-- | destructive or not
|
||||
updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree a b -> BinTree a b
|
||||
updateTreeGen destr z@(x,y) tree = case tree of
|
||||
NT -> BT z NT NT
|
||||
BT c@(a,b) left right
|
||||
| x < a -> let left' = updateTree z left in BT c left' right
|
||||
| x > a -> let right' = updateTree z right in BT c left right'
|
||||
| otherwise -> if destr
|
||||
then BT z left right -- removing the old value of a
|
||||
else tree -- retaining the old value if one exists
|
||||
|
||||
buildTree :: (Ord a) => [(a,b)] -> BinTree a b
|
||||
buildTree = sorted2tree . sortBy fs where
|
||||
fs (x,_) (y,_)
|
||||
| x < y = LT
|
||||
| x > y = GT
|
||||
| True = EQ
|
||||
-- buildTree = listToFM
|
||||
|
||||
sorted2tree :: Ord a => [(a,b)] -> BinTree a b
|
||||
sorted2tree [] = NT
|
||||
sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where
|
||||
(t1,(x:t2)) = splitAt (length xs `div` 2) xs
|
||||
--sorted2tree = listToFM
|
||||
|
||||
--- dm less general than orig
|
||||
mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c
|
||||
mapTree f NT = NT
|
||||
mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right)
|
||||
--mapTree f = mapFM (\k v -> snd (f (k,v)))
|
||||
|
||||
--- fm less efficient than orig?
|
||||
mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c)
|
||||
mapMTree f NT = return NT
|
||||
mapMTree f (BT a left right) = do
|
||||
a' <- f a
|
||||
left' <- mapMTree f left
|
||||
right' <- mapMTree f right
|
||||
return $ BT a' left' right'
|
||||
--mapMTree f t = liftM listToFM $ mapM f $ fmToList t
|
||||
|
||||
filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b
|
||||
-- filterFM f t
|
||||
filterBinTree f = sorted2tree . filter (uncurry f) . tree2list
|
||||
|
||||
tree2list :: BinTree a b -> [(a,b)] -- inorder
|
||||
tree2list NT = []
|
||||
tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
|
||||
--tree2list = fmToList
|
||||
|
||||
-- parsing
|
||||
|
||||
type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser
|
||||
|
||||
wParseResults :: WParser a b -> [a] -> [b]
|
||||
wParseResults p aa = [b | (b,[]) <- p aa]
|
||||
|
||||
paragraphs :: String -> [String]
|
||||
paragraphs = map unlines . chop . lines where
|
||||
chop [] = []
|
||||
chop ss = let (ps,rest) = break empty ss in ps : chop (dropWhile empty rest)
|
||||
empty = all isSpace
|
||||
|
||||
-- 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
|
||||
|
||||
-- LaTeX code producing functions
|
||||
dollar, mbox, ital, boldf, verbat :: String -> String
|
||||
dollar s = '$' : s ++ "$"
|
||||
mbox s = "\\mbox{" ++ s ++ "}"
|
||||
ital s = "{\\em" +++ s ++ "}"
|
||||
boldf s = "{\\bf" +++ s ++ "}"
|
||||
verbat s = "\\verbat!" ++ s ++ "!"
|
||||
|
||||
mkLatexFile :: String -> String
|
||||
mkLatexFile s = begindocument +++++ s +++++ enddocument
|
||||
|
||||
begindocument, enddocument :: String
|
||||
begindocument =
|
||||
"\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02
|
||||
"\\setlength{\\parskip}{2mm}" ++++
|
||||
"\\setlength{\\parindent}{0mm}" ++++
|
||||
"\\setlength{\\oddsidemargin}{0mm}" ++++
|
||||
("\\setlength{\\evensidemargin}{"++"-2mm}") ++++ -- peb 27/5-04: to prevent hugs-mode
|
||||
("\\setlength{\\topmargin}{"++"-8mm}") ++++ -- from treating the rest as comments
|
||||
"\\setlength{\\textheight}{240mm}" ++++
|
||||
"\\setlength{\\textwidth}{158mm}" ++++
|
||||
"\\begin{document}\n"
|
||||
enddocument =
|
||||
"\n\\end{document}\n"
|
||||
|
||||
|
||||
sortByLongest :: [[a]] -> [[a]]
|
||||
sortByLongest = sortBy longer where
|
||||
longer x y
|
||||
| x' > y' = LT
|
||||
| x' < y' = GT
|
||||
| True = EQ
|
||||
where
|
||||
x' = length x
|
||||
y' = length y
|
||||
|
||||
-- | '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]
|
||||
|
||||
|
||||
mkTextFile :: String -> IO ()
|
||||
mkTextFile name = do
|
||||
s <- readFile name
|
||||
let s' = prelude name ++ "\n\n" ++ heading name ++ "\n" ++ object s
|
||||
writeFile (name ++ ".hs") s'
|
||||
where
|
||||
prelude name = "module " ++ name ++ " where"
|
||||
heading name = "txt" ++ name ++ " ="
|
||||
object s = mk s ++ " \"\""
|
||||
mk s = unlines [" \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s]
|
||||
escs s = case s of
|
||||
c:cs | elem c "\"\\" -> '\\' : c : escs cs
|
||||
c:cs -> c : escs cs
|
||||
_ -> s
|
||||
|
||||
initFilePath :: FilePath -> FilePath
|
||||
initFilePath f = reverse (dropWhile (/='/') (reverse f))
|
||||
|
||||
-- | topological sorting with test of cyclicity
|
||||
topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]]
|
||||
topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]])
|
||||
where
|
||||
g' = topoSort g
|
||||
|
||||
cyclesIn :: Eq a => [(a,[a])] -> [[a]]
|
||||
cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where
|
||||
immediate = [[y,x] | (x,xs) <- deps, y <- xs]
|
||||
findDep chains = [y:x:chain |
|
||||
x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs,
|
||||
notElem y (init chain)]
|
||||
|
||||
clean = map remdup
|
||||
nubb = nubBy (\x y -> y == reverse x)
|
||||
filt = filter (\xs -> last xs == head xs)
|
||||
remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs
|
||||
remdup [] = []
|
||||
|
||||
|
||||
-- | topological sorting
|
||||
topoSort :: Eq a => [(a,[a])] -> [a]
|
||||
topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where
|
||||
tsort _ [] r = r
|
||||
tsort k (ffs@(f,fs) : cs) r
|
||||
| elem f r = tsort k cs r
|
||||
| k > lx = r
|
||||
| otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r)
|
||||
info hs = [(f,fs) | (f,fs) <- g, elem f hs]
|
||||
inDeg f = length [t | (h,hs) <- g, t <- hs, t == f]
|
||||
lx = length g
|
||||
|
||||
-- | 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)
|
||||
|
||||
-- association lists
|
||||
|
||||
updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)]
|
||||
updateAssoc ab@(a,b) as = case as of
|
||||
(x,y): xs | x == a -> (a,b):xs
|
||||
xy : xs -> xy : updateAssoc ab xs
|
||||
[] -> [ab]
|
||||
|
||||
removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)]
|
||||
removeAssoc a = filter ((/=a) . fst)
|
||||
|
||||
-- | 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 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 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
|
||||
|
||||
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))
|
||||
|
||||
-- error recovery with multiple reporting AR 30/5/2008
|
||||
mapsErr :: (a -> Err b) -> [a] -> Err [b]
|
||||
|
||||
mapsErr f = seqs . map f where
|
||||
seqs es = case es of
|
||||
Ok v : ms -> case seqs ms of
|
||||
Ok vs -> return (v : vs)
|
||||
b -> b
|
||||
Bad s : ms -> case seqs ms of
|
||||
Ok vs -> Bad s
|
||||
Bad ss -> Bad (s +++++ ss)
|
||||
[] -> return []
|
||||
|
||||
mapsErrTree :: (Ord a) => ((a,b) -> Err (a,c)) -> BinTree a b -> Err (BinTree a c)
|
||||
mapsErrTree f t = mapsErr f (tree2list t) >>= return . sorted2tree
|
||||
|
||||
|
||||
-- | 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"
|
||||
|
||||
-- subsequences sorted from longest to shortest ; their number is 2^n
|
||||
subSequences :: [a] -> [[a]]
|
||||
subSequences = sortBy (\x y -> compare (length y) (length x)) . subs where
|
||||
subs xs = case xs of
|
||||
[] -> [[]]
|
||||
x:xs -> let xss = subs xs in [x:y | y <- xss] ++ xss
|
||||
127
src/GF/Data/SortedList.hs
Normal file
127
src/GF/Data/SortedList.hs
Normal file
@@ -0,0 +1,127 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : Peter Ljunglöf
|
||||
-- Stability : stable
|
||||
-- Portability : portable
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:08 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.3 $
|
||||
--
|
||||
-- Sets as sorted lists
|
||||
--
|
||||
-- * /O(n)/ union, difference and intersection
|
||||
--
|
||||
-- * /O(n log n)/ creating a set from a list (=sorting)
|
||||
--
|
||||
-- * /O(n^2)/ fixed point iteration
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.SortedList
|
||||
( -- * type declarations
|
||||
SList, SMap,
|
||||
-- * set operations
|
||||
nubsort, union,
|
||||
(<++>), (<\\>), (<**>),
|
||||
limit,
|
||||
hasCommonElements, subset,
|
||||
-- * map operations
|
||||
groupPairs, groupUnion,
|
||||
unionMap, mergeMap
|
||||
) where
|
||||
|
||||
import Data.List (groupBy)
|
||||
import GF.Data.Utilities (split, foldMerge)
|
||||
|
||||
-- | The list must be sorted and contain no duplicates.
|
||||
type SList a = [a]
|
||||
|
||||
-- | A sorted map also has unique keys,
|
||||
-- i.e. 'map fst m :: SList a', if 'm :: SMap a b'
|
||||
type SMap a b = SList (a, b)
|
||||
|
||||
-- | Group a set of key-value pairs into a sorted map
|
||||
groupPairs :: Ord a => SList (a, b) -> SMap a (SList b)
|
||||
groupPairs = map mapFst . groupBy eqFst
|
||||
where mapFst as = (fst (head as), map snd as)
|
||||
eqFst a b = fst a == fst b
|
||||
|
||||
-- | Group a set of key-(sets-of-values) pairs into a sorted map
|
||||
groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b)
|
||||
groupUnion = map unionSnd . groupPairs
|
||||
where unionSnd (a, bs) = (a, union bs)
|
||||
|
||||
-- | True is the two sets has common elements
|
||||
hasCommonElements :: Ord a => SList a -> SList a -> Bool
|
||||
hasCommonElements as bs = not (null (as <**> bs))
|
||||
|
||||
-- | True if the first argument is a subset of the second argument
|
||||
subset :: Ord a => SList a -> SList a -> Bool
|
||||
xs `subset` ys = null (xs <\\> ys)
|
||||
|
||||
-- | Create a set from any list.
|
||||
-- This function can also be used as an alternative to @nub@ in @List.hs@
|
||||
nubsort :: Ord a => [a] -> SList a
|
||||
nubsort = union . map return
|
||||
|
||||
-- | the union of a list of sorted maps
|
||||
unionMap :: Ord a => (b -> b -> b)
|
||||
-> [SMap a b] -> SMap a b
|
||||
unionMap plus = foldMerge (mergeMap plus) []
|
||||
|
||||
-- | merging two sorted maps
|
||||
mergeMap :: Ord a => (b -> b -> b)
|
||||
-> SMap a b -> SMap a b -> SMap a b
|
||||
mergeMap plus [] abs = abs
|
||||
mergeMap plus abs [] = abs
|
||||
mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds')
|
||||
= case compare a c of
|
||||
EQ -> (a, plus bs ds) : mergeMap plus abs' cds'
|
||||
LT -> ab : mergeMap plus abs' cds
|
||||
GT -> cd : mergeMap plus abs cds'
|
||||
|
||||
-- | The union of a list of sets
|
||||
union :: Ord a => [SList a] -> SList a
|
||||
union = foldMerge (<++>) []
|
||||
|
||||
-- | The union of two sets
|
||||
(<++>) :: Ord a => SList a -> SList a -> SList a
|
||||
[] <++> bs = bs
|
||||
as <++> [] = as
|
||||
as@(a:as') <++> bs@(b:bs') = case compare a b of
|
||||
LT -> a : (as' <++> bs)
|
||||
GT -> b : (as <++> bs')
|
||||
EQ -> a : (as' <++> bs')
|
||||
|
||||
-- | The difference of two sets
|
||||
(<\\>) :: Ord a => SList a -> SList a -> SList a
|
||||
[] <\\> bs = []
|
||||
as <\\> [] = as
|
||||
as@(a:as') <\\> bs@(b:bs') = case compare a b of
|
||||
LT -> a : (as' <\\> bs)
|
||||
GT -> (as <\\> bs')
|
||||
EQ -> (as' <\\> bs')
|
||||
|
||||
-- | The intersection of two sets
|
||||
(<**>) :: Ord a => SList a -> SList a -> SList a
|
||||
[] <**> bs = []
|
||||
as <**> [] = []
|
||||
as@(a:as') <**> bs@(b:bs') = case compare a b of
|
||||
LT -> (as' <**> bs)
|
||||
GT -> (as <**> bs')
|
||||
EQ -> a : (as' <**> bs')
|
||||
|
||||
-- | A fixed point iteration
|
||||
limit :: Ord a => (a -> SList a) -- ^ The iterator function
|
||||
-> SList a -- ^ The initial set
|
||||
-> SList a -- ^ The result of the iteration
|
||||
limit more start = limit' start start
|
||||
where limit' chart agenda | null new' = chart
|
||||
| otherwise = limit' (chart <++> new') new'
|
||||
where new = union (map more agenda)
|
||||
new'= new <\\> chart
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
134
src/GF/Data/Str.hs
Normal file
134
src/GF/Data/Str.hs
Normal file
@@ -0,0 +1,134 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Str
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/04/21 16:22:09 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.8 $
|
||||
--
|
||||
-- (Description of the module)
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.Str (
|
||||
Str (..), Tok (..), --- constructors needed in PrGrammar
|
||||
str2strings, str2allStrings, str, sstr, sstrV,
|
||||
isZeroTok, prStr, plusStr, glueStr,
|
||||
strTok,
|
||||
allItems
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
import Data.List (isPrefixOf, isSuffixOf, intersperse)
|
||||
|
||||
-- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003
|
||||
newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord)
|
||||
|
||||
-- | notice that having both pre and post would leave to inconsistent situations:
|
||||
--
|
||||
-- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"}
|
||||
--
|
||||
-- always violates a condition expressed by the one or the other
|
||||
data Tok =
|
||||
TK String
|
||||
| TN Ss [(Ss, [String])] -- ^ variants depending on next string
|
||||
--- | TP Ss [(Ss, [String])] -- variants depending on previous string
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
|
||||
|
||||
-- | a variant can itself be a token list, but for simplicity only a list of strings
|
||||
-- i.e. not itself containing variants
|
||||
type Ss = [String]
|
||||
|
||||
-- matching functions in both ways
|
||||
|
||||
matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss
|
||||
matchPrefix s vs t =
|
||||
head $ [u |
|
||||
(u,as) <- vs,
|
||||
any (\c -> isPrefixOf c (concat (unmarkup t))) as
|
||||
] ++ [s]
|
||||
|
||||
matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss
|
||||
matchSuffix t s vs =
|
||||
head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s])
|
||||
|
||||
unmarkup :: [String] -> [String]
|
||||
unmarkup = filter (not . isXMLtag) where
|
||||
isXMLtag s = case s of
|
||||
'<':cs@(_:_) -> last cs == '>'
|
||||
_ -> False
|
||||
|
||||
str2strings :: Str -> Ss
|
||||
str2strings (Str st) = alls st where
|
||||
alls st = case st of
|
||||
TK s : ts -> s : alls ts
|
||||
TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts
|
||||
---- u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts
|
||||
[] -> []
|
||||
|
||||
str2allStrings :: Str -> [Ss]
|
||||
str2allStrings (Str st) = alls st where
|
||||
alls st = case st of
|
||||
TK s : ts -> [s : t | t <- alls ts]
|
||||
TN ds vs : [] -> [ds ++ v | v <- map fst vs]
|
||||
TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts]
|
||||
[] -> [[]]
|
||||
|
||||
sstr :: Str -> String
|
||||
sstr = unwords . str2strings
|
||||
|
||||
-- | to handle a list of variants
|
||||
sstrV :: [Str] -> String
|
||||
sstrV ss = case ss of
|
||||
[] -> "*"
|
||||
_ -> unwords $ intersperse "/" $ map (unwords . str2strings) ss
|
||||
|
||||
str :: String -> Str
|
||||
str s = if null s then Str [] else Str [itS s]
|
||||
|
||||
itS :: String -> Tok
|
||||
itS s = TK s
|
||||
|
||||
isZeroTok :: Str -> Bool
|
||||
isZeroTok t = case t of
|
||||
Str [] -> True
|
||||
Str [TK []] -> True
|
||||
_ -> False
|
||||
|
||||
strTok :: Ss -> [(Ss,[String])] -> Str
|
||||
strTok ds vs = Str [TN ds vs]
|
||||
|
||||
prStr :: Str -> String
|
||||
prStr = prQuotedString . sstr
|
||||
|
||||
plusStr :: Str -> Str -> Str
|
||||
plusStr (Str ss) (Str tt) = Str (ss ++ tt)
|
||||
|
||||
glueStr :: Str -> Str -> Str
|
||||
glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of
|
||||
([],_) -> tt
|
||||
(_,[]) -> ss
|
||||
_ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt
|
||||
where
|
||||
glueIt t u = case (t,u) of
|
||||
(TK s, TK s') -> return $ TK $ s ++ s'
|
||||
(TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es)
|
||||
[(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws]
|
||||
(TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s]
|
||||
(TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws]
|
||||
|
||||
glues :: [[a]] -> [[a]] -> [[a]]
|
||||
glues ss tt = case (ss,tt) of
|
||||
([],_) -> tt
|
||||
(_,[]) -> ss
|
||||
_ -> init ss ++ [last ss ++ head tt] ++ tail tt
|
||||
|
||||
-- | to create the list of all lexical items
|
||||
allItems :: Str -> [String]
|
||||
allItems (Str s) = concatMap allOne s where
|
||||
allOne t = case t of
|
||||
TK s -> [s]
|
||||
TN ds vs -> ds ++ concatMap fst vs
|
||||
190
src/GF/Data/Utilities.hs
Normal file
190
src/GF/Data/Utilities.hs
Normal file
@@ -0,0 +1,190 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Maintainer : PL
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/10/26 18:47:16 $
|
||||
-- > CVS $Author: bringert $
|
||||
-- > CVS $Revision: 1.6 $
|
||||
--
|
||||
-- Basic functions not in the standard libraries
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
|
||||
module GF.Data.Utilities where
|
||||
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import Control.Monad (MonadPlus(..),liftM)
|
||||
|
||||
-- * functions on lists
|
||||
|
||||
sameLength :: [a] -> [a] -> Bool
|
||||
sameLength [] [] = True
|
||||
sameLength (_:xs) (_:ys) = sameLength xs ys
|
||||
sameLength _ _ = False
|
||||
|
||||
notLongerThan, longerThan :: Int -> [a] -> Bool
|
||||
notLongerThan n = null . snd . splitAt n
|
||||
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
|
||||
|
||||
split :: [a] -> ([a], [a])
|
||||
split (x : y : as) = (x:xs, y:ys)
|
||||
where (xs, ys) = split as
|
||||
split as = (as, [])
|
||||
|
||||
splitBy :: (a -> Bool) -> [a] -> ([a], [a])
|
||||
splitBy p [] = ([], [])
|
||||
splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys)
|
||||
where (xs, ys) = splitBy p as
|
||||
|
||||
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
|
||||
|
||||
select :: [a] -> [(a, [a])]
|
||||
select [] = []
|
||||
select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ]
|
||||
|
||||
updateNth :: (a -> a) -> Int -> [a] -> [a]
|
||||
updateNth update 0 (a : as) = update a : as
|
||||
updateNth update n (a : as) = a : updateNth update (n-1) as
|
||||
|
||||
updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
|
||||
updateNthM update 0 (a : as) = liftM (:as) (update a)
|
||||
updateNthM update n (a : as) = liftM (a:) (updateNthM update (n-1) as)
|
||||
|
||||
-- | Like 'init', but returns the empty list when the input is empty.
|
||||
safeInit :: [a] -> [a]
|
||||
safeInit [] = []
|
||||
safeInit xs = init xs
|
||||
|
||||
-- | Like 'nub', but more efficient as it uses sorting internally.
|
||||
sortNub :: Ord a => [a] -> [a]
|
||||
sortNub = map head . group . sort
|
||||
|
||||
-- | Like 'nubBy', but more efficient as it uses sorting internally.
|
||||
sortNubBy :: (a -> a -> Ordering) -> [a] -> [a]
|
||||
sortNubBy f = map head . sortGroupBy f
|
||||
|
||||
-- | Sorts and then groups elements given and ordering of the
|
||||
-- elements.
|
||||
sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]]
|
||||
sortGroupBy f = groupBy (compareEq f) . sortBy f
|
||||
|
||||
-- | Take the union of a list of lists.
|
||||
unionAll :: Eq a => [[a]] -> [a]
|
||||
unionAll = nub . concat
|
||||
|
||||
-- | Like 'lookup', but fails if the argument is not found,
|
||||
-- instead of returning Nothing.
|
||||
lookup' :: (Show a, Eq a) => a -> [(a,b)] -> b
|
||||
lookup' x = fromMaybe (error $ "Not found: " ++ show x) . lookup x
|
||||
|
||||
-- | Like 'find', but fails if nothing is found.
|
||||
find' :: (a -> Bool) -> [a] -> a
|
||||
find' p = fromJust . find p
|
||||
|
||||
-- | Set a value in a lookup table.
|
||||
tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)]
|
||||
tableSet x y [] = [(x,y)]
|
||||
tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs
|
||||
| otherwise = p:tableSet x y xs
|
||||
|
||||
-- | Group tuples by their first elements.
|
||||
buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])]
|
||||
buildMultiMap = map (\g -> (fst (head g), map snd g) )
|
||||
. sortGroupBy (compareBy fst)
|
||||
|
||||
-- | Replace all occurences of an element by another element.
|
||||
replace :: Eq a => a -> a -> [a] -> [a]
|
||||
replace x y = map (\z -> if z == x then y else z)
|
||||
|
||||
-- * equality functions
|
||||
|
||||
-- | Use an ordering function as an equality predicate.
|
||||
compareEq :: (a -> a -> Ordering) -> a -> a -> Bool
|
||||
compareEq f x y = case f x y of
|
||||
EQ -> True
|
||||
_ -> False
|
||||
|
||||
-- * ordering functions
|
||||
|
||||
compareBy :: Ord b => (a -> b) -> a -> a -> Ordering
|
||||
compareBy f = both f compare
|
||||
|
||||
both :: (a -> b) -> (b -> b -> c) -> a -> a -> c
|
||||
both f g x y = g (f x) (f y)
|
||||
|
||||
-- * functions on pairs
|
||||
|
||||
mapFst :: (a -> a') -> (a, b) -> (a', b)
|
||||
mapFst f (a, b) = (f a, b)
|
||||
|
||||
mapSnd :: (b -> b') -> (a, b) -> (a, b')
|
||||
mapSnd f (a, b) = (a, f b)
|
||||
|
||||
-- * functions on monads
|
||||
|
||||
-- | Return the given value if the boolean is true, els return 'mzero'.
|
||||
whenMP :: MonadPlus m => Bool -> a -> m a
|
||||
whenMP b x = if b then return x else mzero
|
||||
|
||||
-- * functions on Maybes
|
||||
|
||||
-- | Returns true if the argument is Nothing or Just []
|
||||
nothingOrNull :: Maybe [a] -> Bool
|
||||
nothingOrNull = maybe True null
|
||||
|
||||
-- * functions on functions
|
||||
|
||||
-- | Apply all the functions in the list to the argument.
|
||||
foldFuns :: [a -> a] -> a -> a
|
||||
foldFuns fs x = foldl (flip ($)) x fs
|
||||
|
||||
-- | Fixpoint iteration.
|
||||
fix :: Eq a => (a -> a) -> a -> a
|
||||
fix f x = let x' = f x in if x' == x then x else fix f x'
|
||||
|
||||
-- * functions on strings
|
||||
|
||||
-- | Join a number of lists by using the given glue
|
||||
-- between the lists.
|
||||
join :: [a] -- ^ glue
|
||||
-> [[a]] -- ^ lists to join
|
||||
-> [a]
|
||||
join g = concat . intersperse g
|
||||
|
||||
-- * ShowS-functions
|
||||
|
||||
nl :: ShowS
|
||||
nl = showChar '\n'
|
||||
|
||||
sp :: ShowS
|
||||
sp = showChar ' '
|
||||
|
||||
wrap :: String -> ShowS -> String -> ShowS
|
||||
wrap o s c = showString o . s . showString c
|
||||
|
||||
concatS :: [ShowS] -> ShowS
|
||||
concatS = foldr (.) id
|
||||
|
||||
unwordsS :: [ShowS] -> ShowS
|
||||
unwordsS = joinS " "
|
||||
|
||||
unlinesS :: [ShowS] -> ShowS
|
||||
unlinesS = joinS "\n"
|
||||
|
||||
joinS :: String -> [ShowS] -> ShowS
|
||||
joinS glue = concatS . intersperse (showString glue)
|
||||
|
||||
|
||||
|
||||
53
src/GF/Data/XML.hs
Normal file
53
src/GF/Data/XML.hs
Normal file
@@ -0,0 +1,53 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : XML
|
||||
--
|
||||
-- Utilities for creating XML documents.
|
||||
----------------------------------------------------------------------
|
||||
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
|
||||
|
||||
import GF.Data.Utilities
|
||||
|
||||
data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
|
||||
deriving (Ord,Eq,Show)
|
||||
|
||||
type Attr = (String,String)
|
||||
|
||||
comments :: [String] -> [XML]
|
||||
comments = map Comment
|
||||
|
||||
showXMLDoc :: XML -> String
|
||||
showXMLDoc xml = showsXMLDoc xml ""
|
||||
|
||||
showsXMLDoc :: XML -> ShowS
|
||||
showsXMLDoc xml = showString header . showsXML xml
|
||||
where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
|
||||
|
||||
showsXML :: XML -> ShowS
|
||||
showsXML (Data s) = showString s
|
||||
showsXML (CData s) = showString "<![CDATA[" . showString s .showString "]]>"
|
||||
showsXML (ETag t as) = showChar '<' . showString t . showsAttrs as . showString "/>"
|
||||
showsXML (Tag t as cs) =
|
||||
showChar '<' . showString t . showsAttrs as . showChar '>'
|
||||
. concatS (map showsXML cs) . showString "</" . showString t . showChar '>'
|
||||
showsXML (Comment c) = showString "<!-- " . showString c . showString " -->"
|
||||
showsXML (Empty) = id
|
||||
|
||||
showsAttrs :: [Attr] -> ShowS
|
||||
showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
|
||||
|
||||
showsAttr :: Attr -> ShowS
|
||||
showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
|
||||
|
||||
escape :: String -> String
|
||||
escape = concatMap escChar
|
||||
where
|
||||
escChar '<' = "<"
|
||||
escChar '>' = ">"
|
||||
escChar '&' = "&"
|
||||
escChar '"' = """
|
||||
escChar c = [c]
|
||||
|
||||
bottomUpXML :: (XML -> XML) -> XML -> XML
|
||||
bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs))
|
||||
bottomUpXML f x = f x
|
||||
257
src/GF/Data/Zipper.hs
Normal file
257
src/GF/Data/Zipper.hs
Normal file
@@ -0,0 +1,257 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Zipper
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/06/11 20:27:05 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.9 $
|
||||
--
|
||||
-- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.Zipper (-- * types
|
||||
Tr(..),
|
||||
Path(..),
|
||||
Loc(..),
|
||||
-- * basic (original) functions
|
||||
leaf,
|
||||
goLeft, goRight, goUp, goDown,
|
||||
changeLoc,
|
||||
changeNode,
|
||||
forgetNode,
|
||||
-- * added sequential representation
|
||||
goAhead,
|
||||
goBack,
|
||||
-- ** n-ary versions
|
||||
goAheadN,
|
||||
goBackN,
|
||||
-- * added mappings between locations and trees
|
||||
loc2tree,
|
||||
loc2treeMarked,
|
||||
tree2loc,
|
||||
goRoot,
|
||||
goLast,
|
||||
goPosition,
|
||||
getPosition,
|
||||
keepPosition,
|
||||
-- * added some utilities
|
||||
traverseCollect,
|
||||
scanTree,
|
||||
mapTr,
|
||||
mapTrM,
|
||||
mapPath,
|
||||
mapPathM,
|
||||
mapLoc,
|
||||
mapLocM,
|
||||
foldTr,
|
||||
foldTrM,
|
||||
mapSubtrees,
|
||||
mapSubtreesM,
|
||||
changeRoot,
|
||||
nthSubtree,
|
||||
arityTree
|
||||
) where
|
||||
|
||||
import GF.Data.Operations
|
||||
|
||||
newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq)
|
||||
|
||||
data Path a =
|
||||
Top
|
||||
| Node ([Tr a], (Path a, a), [Tr a])
|
||||
deriving Show
|
||||
|
||||
leaf :: a -> Tr a
|
||||
leaf a = Tr (a,[])
|
||||
|
||||
newtype Loc a = Loc (Tr a, Path a) deriving Show
|
||||
|
||||
goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a)
|
||||
goLeft (Loc (t,p)) = case p of
|
||||
Top -> Bad "left of top"
|
||||
Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right))
|
||||
Node _ -> Bad "left of first"
|
||||
goRight (Loc (t,p)) = case p of
|
||||
Top -> Bad "right of top"
|
||||
Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right))
|
||||
Node _ -> Bad "right of first"
|
||||
goUp (Loc (t,p)) = case p of
|
||||
Top -> Bad "up of top"
|
||||
Node (left, (up,v), right) ->
|
||||
return $ Loc (Tr (v, reverse left ++ (t:right)), up)
|
||||
goDown (Loc (t,p)) = case t of
|
||||
Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees))
|
||||
_ -> Bad "down of empty"
|
||||
|
||||
changeLoc :: Loc a -> Tr a -> Err (Loc a)
|
||||
changeLoc (Loc (_,p)) t = return $ Loc (t,p)
|
||||
|
||||
changeNode :: (a -> a) -> Loc a -> Loc a
|
||||
changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p)
|
||||
|
||||
forgetNode :: Loc a -> Err (Loc a)
|
||||
forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p)
|
||||
forgetNode _ = Bad $ "not a one-branch tree"
|
||||
|
||||
-- added sequential representation
|
||||
|
||||
-- | a successor function
|
||||
goAhead :: Loc a -> Err (Loc a)
|
||||
goAhead s@(Loc (t,p)) = case (t,p) of
|
||||
(Tr (_,_:_),Node (_,_,_:_)) -> goDown s
|
||||
(Tr (_,[]), _) -> upsRight s
|
||||
(_, _) -> goDown s
|
||||
where
|
||||
upsRight t = case goRight t of
|
||||
Ok t' -> return t'
|
||||
Bad _ -> goUp t >>= upsRight
|
||||
|
||||
-- | a predecessor function
|
||||
goBack :: Loc a -> Err (Loc a)
|
||||
goBack s@(Loc (t,p)) = case goLeft s of
|
||||
Ok s' -> downRight s'
|
||||
_ -> goUp s
|
||||
where
|
||||
downRight s = case goDown s of
|
||||
Ok s' -> case goRight s' of
|
||||
Ok s'' -> downRight s''
|
||||
_ -> downRight s'
|
||||
_ -> return s
|
||||
|
||||
-- n-ary versions
|
||||
|
||||
goAheadN :: Int -> Loc a -> Err (Loc a)
|
||||
goAheadN i st
|
||||
| i < 1 = return st
|
||||
| otherwise = goAhead st >>= goAheadN (i-1)
|
||||
|
||||
goBackN :: Int -> Loc a -> Err (Loc a)
|
||||
goBackN i st
|
||||
| i < 1 = return st
|
||||
| otherwise = goBack st >>= goBackN (i-1)
|
||||
|
||||
-- added mappings between locations and trees
|
||||
|
||||
loc2tree :: Loc a -> Tr a
|
||||
loc2tree (Loc (t,p)) = case p of
|
||||
Top -> t
|
||||
Node (left,(p',v),right) ->
|
||||
loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p'))
|
||||
|
||||
loc2treeMarked :: Loc a -> Tr (a, Bool)
|
||||
loc2treeMarked (Loc (Tr (a,ts),p)) =
|
||||
loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p))
|
||||
where
|
||||
(mark, nomark) = (\a -> (a,True), \a -> (a, False))
|
||||
|
||||
tree2loc :: Tr a -> Loc a
|
||||
tree2loc t = Loc (t,Top)
|
||||
|
||||
goRoot :: Loc a -> Loc a
|
||||
goRoot = tree2loc . loc2tree
|
||||
|
||||
goLast :: Loc a -> Err (Loc a)
|
||||
goLast = rep goAhead where
|
||||
rep f s = err (const (return s)) (rep f) (f s)
|
||||
|
||||
goPosition :: [Int] -> Loc a -> Err (Loc a)
|
||||
goPosition p = go p . goRoot where
|
||||
go [] s = return s
|
||||
go (p:ps) s = goDown s >>= apply p goRight >>= go ps
|
||||
|
||||
getPosition :: Loc a -> [Int]
|
||||
getPosition = reverse . getp where
|
||||
getp (Loc (t,p)) = case p of
|
||||
Top -> []
|
||||
Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p'))
|
||||
|
||||
keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a))
|
||||
keepPosition f s = do
|
||||
let p = getPosition s
|
||||
s' <- f s
|
||||
goPosition p s'
|
||||
|
||||
apply :: Monad m => Int -> (a -> m a) -> a -> m a
|
||||
apply n f a = case n of
|
||||
0 -> return a
|
||||
_ -> f a >>= apply (n-1) f
|
||||
|
||||
-- added some utilities
|
||||
|
||||
traverseCollect :: Path a -> [a]
|
||||
traverseCollect p = reverse $ case p of
|
||||
Top -> []
|
||||
Node (_, (p',v), _) -> v : traverseCollect p'
|
||||
|
||||
scanTree :: Tr a -> [a]
|
||||
scanTree (Tr (a,ts)) = a : concatMap scanTree ts
|
||||
|
||||
mapTr :: (a -> b) -> Tr a -> Tr b
|
||||
mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts)
|
||||
|
||||
mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b)
|
||||
mapTrM f (Tr (x,ts)) = do
|
||||
fx <- f x
|
||||
fts <- mapM (mapTrM f) ts
|
||||
return $ Tr (fx,fts)
|
||||
|
||||
mapPath :: (a -> b) -> Path a -> Path b
|
||||
mapPath f p = case p of
|
||||
Node (ts1, (p,v), ts2) ->
|
||||
Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2)
|
||||
Top -> Top
|
||||
|
||||
mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b)
|
||||
mapPathM f p = case p of
|
||||
Node (ts1, (p,v), ts2) -> do
|
||||
ts1' <- mapM (mapTrM f) ts1
|
||||
p' <- mapPathM f p
|
||||
v' <- f v
|
||||
ts2' <- mapM (mapTrM f) ts2
|
||||
return $ Node (ts1', (p',v'), ts2')
|
||||
Top -> return Top
|
||||
|
||||
mapLoc :: (a -> b) -> Loc a -> Loc b
|
||||
mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p)
|
||||
|
||||
mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b)
|
||||
mapLocM f (Loc (t,p)) = do
|
||||
t' <- mapTrM f t
|
||||
p' <- mapPathM f p
|
||||
return $ (Loc (t',p'))
|
||||
|
||||
foldTr :: (a -> [b] -> b) -> Tr a -> b
|
||||
foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts)
|
||||
|
||||
foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b
|
||||
foldTrM f (Tr (x,ts)) = do
|
||||
fts <- mapM (foldTrM f) ts
|
||||
f x fts
|
||||
|
||||
mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a
|
||||
mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts)
|
||||
|
||||
mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a)
|
||||
mapSubtreesM f t = do
|
||||
Tr (x,ts) <- f t
|
||||
ts' <- mapM (mapSubtreesM f) ts
|
||||
return $ Tr (x, ts')
|
||||
|
||||
-- | change the root without moving the pointer
|
||||
changeRoot :: (a -> a) -> Loc a -> Loc a
|
||||
changeRoot f loc = case loc of
|
||||
Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top)
|
||||
Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right))
|
||||
where
|
||||
chPath pv = case pv of
|
||||
(Top,a) -> (Top, f a)
|
||||
(Node (left,pv,right),v) -> (Node (left, chPath pv,right),v)
|
||||
|
||||
nthSubtree :: Int -> Tr a -> Err (Tr a)
|
||||
nthSubtree n (Tr (a,ts)) = ts !? n
|
||||
|
||||
arityTree :: Tr a -> Int
|
||||
arityTree (Tr (_,ts)) = length ts
|
||||
Reference in New Issue
Block a user