summaryrefslogtreecommitdiff
path: root/src/GF/Data
diff options
context:
space:
mode:
Diffstat (limited to 'src/GF/Data')
-rw-r--r--src/GF/Data/Assoc.hs143
-rw-r--r--src/GF/Data/BacktrackM.hs93
-rw-r--r--src/GF/Data/Compos.hs37
-rw-r--r--src/GF/Data/ErrM.hs38
-rw-r--r--src/GF/Data/GeneralDeduction.hs121
-rw-r--r--src/GF/Data/Glue.hs30
-rw-r--r--src/GF/Data/IncrementalDeduction.hs67
-rw-r--r--src/GF/Data/Map.hs61
-rw-r--r--src/GF/Data/Operations.hs658
-rw-r--r--src/GF/Data/OrdMap2.hs127
-rw-r--r--src/GF/Data/OrdSet.hs120
-rw-r--r--src/GF/Data/Parsers.hs196
-rw-r--r--src/GF/Data/RedBlack.hs64
-rw-r--r--src/GF/Data/RedBlackSet.hs150
-rw-r--r--src/GF/Data/SharedString.hs19
-rw-r--r--src/GF/Data/SortedList.hs127
-rw-r--r--src/GF/Data/Str.hs134
-rw-r--r--src/GF/Data/Trie.hs129
-rw-r--r--src/GF/Data/Trie2.hs120
-rw-r--r--src/GF/Data/Utilities.hs190
-rw-r--r--src/GF/Data/XML.hs57
-rw-r--r--src/GF/Data/Zipper.hs257
22 files changed, 0 insertions, 2938 deletions
diff --git a/src/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs
deleted file mode 100644
index f775319ea..000000000
--- a/src/GF/Data/Assoc.hs
+++ /dev/null
@@ -1,143 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
-
-
-
-
-
-
-
diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs
deleted file mode 100644
index 790d11a83..000000000
--- a/src/GF/Data/BacktrackM.hs
+++ /dev/null
@@ -1,93 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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)
diff --git a/src/GF/Data/Compos.hs b/src/GF/Data/Compos.hs
deleted file mode 100644
index 7d46fc5a2..000000000
--- a/src/GF/Data/Compos.hs
+++ /dev/null
@@ -1,37 +0,0 @@
-{-# OPTIONS_GHC -fglasgow-exts #-}
-module GF.Data.Compos (Compos(..),composOp,composM,composM_,composFold) where
-
-import Control.Applicative (Applicative(..), Const(..), WrappedMonad(..))
-import Data.Monoid (Monoid(..))
-
-class Compos t where
- compos :: Applicative f => (forall a. t a -> f (t a)) -> t c -> f (t c)
-
-composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c
-composOp f = runIdentity . compos (Identity . f)
-
-composFold :: (Monoid o, Compos t) => (forall a. t a -> o) -> t c -> o
-composFold f = getConst . compos (Const . f)
-
-composM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c)
-composM f = unwrapMonad . compos (WrapMonad . f)
-
-composM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m ()
-composM_ f = unwrapMonad_ . composFold (WrapMonad_ . f)
-
-
-newtype Identity a = Identity { runIdentity :: a }
-
-instance Functor Identity where
- fmap f (Identity x) = Identity (f x)
-
-instance Applicative Identity where
- pure = Identity
- Identity f <*> Identity x = Identity (f x)
-
-
-newtype WrappedMonad_ m = WrapMonad_ { unwrapMonad_ :: m () }
-
-instance Monad m => Monoid (WrappedMonad_ m) where
- mempty = WrapMonad_ (return ())
- WrapMonad_ x `mappend` WrapMonad_ y = WrapMonad_ (x >> y)
diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs
deleted file mode 100644
index e8cea12d4..000000000
--- a/src/GF/Data/ErrM.hs
+++ /dev/null
@@ -1,38 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
diff --git a/src/GF/Data/GeneralDeduction.hs b/src/GF/Data/GeneralDeduction.hs
deleted file mode 100644
index 137212e5c..000000000
--- a/src/GF/Data/GeneralDeduction.hs
+++ /dev/null
@@ -1,121 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : Peter Ljunglöf
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:01 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.3 $
---
--- Simple implementation of deductive chart parsing
------------------------------------------------------------------------------
-
-module GF.Data.GeneralDeduction
- (-- * Type definition
- ParseChart,
- -- * Main functions
- chartLookup,
- buildChart, buildChartM,
- -- * Probably not needed
- emptyChart,
- chartMember,
- chartInsert, chartInsertM,
- chartList, chartKeys, chartAssocs,
- addToChart, addToChartM
- ) where
-
--- import Trace
-
-import GF.Data.RedBlackSet
-import Control.Monad (foldM)
-
-----------------------------------------------------------------------
--- main functions
-
-chartLookup :: (Ord item, Ord key) => ParseChart item key -> key -> [item]
-chartList :: (Ord item, Ord key) => ParseChart item key -> [item]
-chartKeys :: (Ord item, Ord key) => ParseChart item key -> [key]
-chartAssocs :: (Ord item, Ord key) => ParseChart item key -> [(key,item)]
-buildChart :: (Ord item, Ord key) =>
- (item -> key) -- ^ key lookup function
- -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions
- -- from triggering items to lists of items
- -> [item] -- ^ initial chart
- -> ParseChart item key -- ^ final chart
-buildChartM :: (Ord item, Ord key) =>
- (item -> [key]) -- ^ many-valued key lookup function
- -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions
- -- from triggering items to lists of items
- -> [item] -- ^ initial chart
- -> ParseChart item key -- ^ final chart
-
-buildChart keyof rules axioms = addItems axioms emptyChart
- where addItems [] = id
- addItems (item:items) = addItems items . addItem item
- -- addItem item | trace ("+ "++show item++"\n") False = undefined
- addItem item = addToChart item (keyof item)
- (\chart -> foldr (consequence item) chart rules)
- consequence item rule chart = addItems (rule chart item) chart
-
-buildChartM keysof rules axioms = addItems axioms emptyChart
- where addItems [] = id
- addItems (item:items) = addItems items . addItem item
- -- addItem item | trace ("+ "++show item++"\n") False = undefined
- addItem item = addToChartM item (keysof item)
- (\chart -> foldr (consequence item) chart rules)
- consequence item rule chart = addItems (rule chart item) chart
-
--- probably not needed
-
-emptyChart :: (Ord item, Ord key) => ParseChart item key
-chartMember :: (Ord item, Ord key) => ParseChart item key
- -> item -> key -> Bool
-chartInsert :: (Ord item, Ord key) => ParseChart item key
- -> item -> key -> Maybe (ParseChart item key)
-chartInsertM :: (Ord item, Ord key) => ParseChart item key
- -> item -> [key] -> Maybe (ParseChart item key)
-
-addToChart :: (Ord item, Ord key) => item -> key
- -> (ParseChart item key -> ParseChart item key)
- -> ParseChart item key -> ParseChart item key
-addToChart item keys after chart = maybe chart after (chartInsert chart item keys)
-
-addToChartM :: (Ord item, Ord key) => item -> [key]
- -> (ParseChart item key -> ParseChart item key)
- -> ParseChart item key -> ParseChart item key
-addToChartM item keys after chart = maybe chart after (chartInsertM chart item keys)
-
-
---------------------------------------------------------------------------------
--- key charts as red/black trees
-
-newtype ParseChart item key = KC (RedBlackMap key item)
- deriving Show
-
-emptyChart = KC rbmEmpty
-chartMember (KC tree) item key = rbmElem key item tree
-chartLookup (KC tree) key = rbmLookup key tree
-chartList (KC tree) = concatMap snd (rbmList tree)
-chartKeys (KC tree) = map fst (rbmList tree)
-chartAssocs (KC tree) = [(key,item) | (key,items) <- rbmList tree, item <- items]
-chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree)
-
-chartInsertM (KC tree) item keys = fmap KC (foldM insertItem tree keys)
- where insertItem tree key = rbmInsert key item tree
-
---------------------------------------------------------------------------------}
-
-
-{--------------------------------------------------------------------------------
--- key charts as unsorted association lists -- OBSOLETE!
-
-newtype Chart item key = SC [(key, item)]
-
-emptyChart = SC []
-chartMember (SC chart) item key = (key,item) `elem` chart
-chartInsert (SC chart) item key = if (key,item) `elem` chart then Nothing else Just (SC ((key,item):chart))
-chartLookup (SC chart) key = [ item | (key',item) <- chart, key == key' ]
-chartList (SC chart) = map snd chart
---------------------------------------------------------------------------------}
-
diff --git a/src/GF/Data/Glue.hs b/src/GF/Data/Glue.hs
deleted file mode 100644
index 4f276222b..000000000
--- a/src/GF/Data/Glue.hs
+++ /dev/null
@@ -1,30 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Glue
--- Maintainer : AR
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/04/21 16:22:02 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.7 $
---
--- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@
------------------------------------------------------------------------------
-
-module GF.Data.Glue (decomposeSimple) where
-
-import GF.Data.Trie2
-import GF.Data.Operations
-import Data.List
-
-decomposeSimple :: Trie Char a -> [Char] -> Err [[Char]]
-decomposeSimple t s = do
- let ss = map (decompose t) $ words s
- if any null ss
- then Bad "unknown word in input"
- else return $ concat [intersperse "&+" ws | ws <- ss]
-
-exTrie = tcompile (zip ws ws) where
- ws = words "ett tv\229 tre tjugo trettio hundra tusen"
-
diff --git a/src/GF/Data/IncrementalDeduction.hs b/src/GF/Data/IncrementalDeduction.hs
deleted file mode 100644
index d119610c1..000000000
--- a/src/GF/Data/IncrementalDeduction.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Maintainer : PL
--- Stability : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/05/09 09:28:44 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.3 $
---
--- Implementation of /incremental/ deductive parsing,
--- i.e. parsing one word at the time.
------------------------------------------------------------------------------
-
-module GF.Data.IncrementalDeduction
- (-- * Type definitions
- IncrementalChart,
- -- * Functions
- chartLookup,
- buildChart,
- chartList, chartKeys
- ) where
-
-import Data.Array
-import GF.Data.SortedList
-import GF.Data.Assoc
-
-----------------------------------------------------------------------
--- main functions
-
-chartLookup :: (Ord item, Ord key) =>
- IncrementalChart item key
- -> Int -> key -> SList item
-
-buildChart :: (Ord item, Ord key) =>
- (item -> key) -- ^ key lookup function
- -> (Int -> item -> SList item) -- ^ all inference rules for position k, collected
- -> (Int -> SList item) -- ^ all axioms for position k, collected
- -> (Int, Int) -- ^ input bounds
- -> IncrementalChart item key
-
-chartList :: (Ord item, Ord key) =>
- IncrementalChart item key -- ^ the final chart
- -> (Int -> item -> edge) -- ^ function building an edge from
- -- the position and the item
- -> [edge]
-
-chartKeys :: (Ord item, Ord key) => IncrementalChart item key -> Int -> [key]
-
-type IncrementalChart item key = Array Int (Assoc key (SList item))
-
-----------
-
-chartLookup chart k key = (chart ! k) ? key
-
-buildChart keyof rules axioms bounds = finalChartArray
- where buildState k = limit (rules k) $ axioms k
- finalChartList = map buildState [fst bounds .. snd bounds]
- finalChartArray = listArray bounds $ map stateAssoc finalChartList
- stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ]
-
-chartList chart combine = [ combine k item |
- (k, state) <- assocs chart,
- item <- concatMap snd $ aAssocs state ]
-
-chartKeys chart k = aElems (chart ! k)
-
diff --git a/src/GF/Data/Map.hs b/src/GF/Data/Map.hs
deleted file mode 100644
index c86c9ab55..000000000
--- a/src/GF/Data/Map.hs
+++ /dev/null
@@ -1,61 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Map
--- Maintainer : Markus Forsberg
--- Stability : Stable
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/04/21 16:22:04 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Data.Map (
- Map,
- empty,
- isEmpty,
- (!),
- (!+),
- (|->),
- (|->+),
- (<+>),
- flatten
- ) where
-
-import GF.Data.RedBlack
-
-type Map key el = Tree key el
-
-infixl 6 |->
-infixl 6 |->+
-infixl 5 !
-infixl 5 !+
-infixl 4 <+>
-
-empty :: Map key el
-empty = emptyTree
-
--- | lookup operator.
-(!) :: Ord key => Map key el -> key -> Maybe el
-(!) fm e = lookupTree e fm
-
--- | lookupMany operator.
-(!+) :: Ord key => Map key el -> [key] -> [Maybe el]
-fm !+ [] = []
-fm !+ (e:es) = (lookupTree e fm): (fm !+ es)
-
--- | insert operator.
-(|->) :: Ord key => (key,el) -> Map key el -> Map key el
-(x,y) |-> fm = insertTree (x,y) fm
-
--- | insertMany operator.
-(|->+) :: Ord key => [(key,el)] -> Map key el -> Map key el
-[] |->+ fm = fm
-((x,y):xs) |->+ fm = xs |->+ (insertTree (x,y) fm)
-
--- | union operator.
-(<+>) :: Ord key => Map key el -> Map key el -> Map key el
-(<+>) fm1 fm2 = xs |->+ fm2
- where xs = flatten fm1
diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs
deleted file mode 100644
index 1b2033d69..000000000
--- a/src/GF/Data/Operations.hs
+++ /dev/null
@@ -1,658 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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,
-
- -- ** 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))
-
--- | 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
diff --git a/src/GF/Data/OrdMap2.hs b/src/GF/Data/OrdMap2.hs
deleted file mode 100644
index 3590f0584..000000000
--- a/src/GF/Data/OrdMap2.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : OrdMap2
--- Maintainer : Peter Ljunglöf
--- Stability : Obsolete
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/04/21 16:22:05 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- The class of finite maps, as described in
--- \"Pure Functional Parsing\", section 2.2.2
--- and an example implementation,
--- derived from appendix A.2
---
--- /OBSOLETE/! this is only used in module "ChartParser"
------------------------------------------------------------------------------
-
-module GF.Data.OrdMap2 (OrdMap(..), Map) where
-
-import Data.List (intersperse)
-
-
---------------------------------------------------
--- the class of ordered finite maps
-
-class OrdMap m where
- emptyMap :: Ord s => m s a
- (|->) :: Ord s => s -> a -> m s a
- isEmptyMap :: Ord s => m s a -> Bool
- (?) :: Ord s => m s a -> s -> Maybe a
- lookupWith :: Ord s => a -> m s a -> s -> a
- mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a
- unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a
- makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a
- assocs :: Ord s => m s a -> [(s,a)]
- ordMap :: Ord s => [(s,a)] -> m s a
- mapMap :: Ord s => (a -> b) -> m s a -> m s b
-
- lookupWith z m s = case m ? s of
- Just a -> a
- Nothing -> z
-
- unionMapWith join = union
- where union [] = emptyMap
- union [xs] = xs
- union xyss = mergeWith join (union xss) (union yss)
- where (xss, yss) = split xyss
- split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
- split xs = (xs, [])
-
-
---------------------------------------------------
--- finite maps as ordered associaiton lists,
--- paired with binary search trees
-
-data Map s a = Map [(s,a)] (TreeMap s a)
-
-instance (Eq s, Eq a) => Eq (Map s a) where
- Map xs _ == Map ys _ = xs == ys
-
-instance (Show s, Show a) => Show (Map s a) where
- show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}"
- where show' (s,a) = show s ++ "|->" ++ show a
-
-instance OrdMap Map where
- emptyMap = Map [] (makeTree [])
- s |-> a = Map [(s,a)] (makeTree [(s,a)])
-
- isEmptyMap (Map ass _) = null ass
-
- Map _ tree ? s = lookupTree s tree
-
- mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss)
- where xyss = merge xss yss
- merge [] yss = yss
- merge xss [] = xss
- merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss')
- = case compare s t of
- LT -> x : merge xss' yss
- GT -> y : merge xss yss'
- EQ -> (s, join x' y') : merge xss' yss'
-
- makeMapWith join [] = emptyMap
- makeMapWith join [(s,a)] = s |-> a
- makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss)
- where (xss, yss) = split xyss
- split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys)
- split xs = (xs, [])
-
- assocs (Map xss _) = xss
- ordMap xss = Map xss (makeTree xss)
-
- mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree)
-
-
---------------------------------------------------
--- binary search trees
--- for logarithmic lookup time
-
-data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a)
-
-makeTree ass = tree
- where
- (tree,[]) = sl2bst (length ass) ass
- sl2bst 0 ass = (Nil, ass)
- sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass)
- sl2bst n ass = (Node ltree s a rtree, css)
- where llen = (n-1) `div` 2
- rlen = n - 1 - llen
- (ltree, (s,a):bss) = sl2bst llen ass
- (rtree, css) = sl2bst rlen bss
-
-lookupTree s Nil = Nothing
-lookupTree s (Node left s' a right)
- = case compare s s' of
- LT -> lookupTree s left
- GT -> lookupTree s right
- EQ -> Just a
-
-mapTree f Nil = Nil
-mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right)
-
-
-
-
diff --git a/src/GF/Data/OrdSet.hs b/src/GF/Data/OrdSet.hs
deleted file mode 100644
index 34eb0705d..000000000
--- a/src/GF/Data/OrdSet.hs
+++ /dev/null
@@ -1,120 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : OrdSet
--- Maintainer : Peter Ljunglöf
--- Stability : Obsolete
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/04/21 16:22:06 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- The class of ordered sets, as described in
--- \"Pure Functional Parsing\", section 2.2.1,
--- and an example implementation
--- derived from appendix A.1
---
--- /OBSOLETE/! this is only used in module "ChartParser"
------------------------------------------------------------------------------
-
-module GF.Data.OrdSet (OrdSet(..), Set) where
-
-import Data.List (intersperse)
-
-
---------------------------------------------------
--- the class of ordered sets
-
-class OrdSet m where
- emptySet :: Ord a => m a
- unitSet :: Ord a => a -> m a
- isEmpty :: Ord a => m a -> Bool
- elemSet :: Ord a => a -> m a -> Bool
- (<++>) :: Ord a => m a -> m a -> m a
- (<\\>) :: Ord a => m a -> m a -> m a
- plusMinus :: Ord a => m a -> m a -> (m a, m a)
- union :: Ord a => [m a] -> m a
- makeSet :: Ord a => [a] -> m a
- elems :: Ord a => m a -> [a]
- ordSet :: Ord a => [a] -> m a
- limit :: Ord a => (a -> m a) -> m a -> m a
-
- xs <++> ys = fst (plusMinus xs ys)
- xs <\\> ys = snd (plusMinus xs ys)
- plusMinus xs ys = (xs <++> ys, xs <\\> ys)
-
- union [] = emptySet
- union [xs] = xs
- union xyss = union xss <++> union yss
- where (xss, yss) = split xyss
- split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys)
- split xs = (xs, [])
-
- makeSet xs = union (map unitSet xs)
-
- limit more start = limit' (start, start)
- where limit' (old, new)
- | isEmpty new' = old
- | otherwise = limit' (plusMinus new' old)
- where new' = union (map more (elems new))
-
-
---------------------------------------------------
--- sets as ordered lists,
--- paired with a binary tree
-
-data Set a = Set [a] (TreeSet a)
-
-instance Eq a => Eq (Set a) where
- Set xs _ == Set ys _ = xs == ys
-
-instance Ord a => Ord (Set a) where
- compare (Set xs _) (Set ys _) = compare xs ys
-
-instance Show a => Show (Set a) where
- show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}"
-
-instance OrdSet Set where
- emptySet = Set [] (makeTree [])
- unitSet a = Set [a] (makeTree [a])
-
- isEmpty (Set xs _) = null xs
- elemSet a (Set _ xt) = elemTree a xt
-
- plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms))
- where (ps, ms) = plm xs ys
- plm [] ys = (ys, [])
- plm xs [] = (xs, xs)
- plm xs@(x:xs') ys@(y:ys') = case compare x y of
- LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms)
- GT -> let (ps, ms) = plm xs ys' in (y:ps, ms)
- EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms)
-
- elems (Set xs _) = xs
- ordSet xs = Set xs (makeTree xs)
-
-
---------------------------------------------------
--- binary search trees
--- for logarithmic lookup time
-
-data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a)
-
-makeTree xs = tree
- where (tree,[]) = sl2bst (length xs) xs
- sl2bst 0 xs = (Nil, xs)
- sl2bst 1 (a:xs) = (Node Nil a Nil, xs)
- sl2bst n xs = (Node ltree a rtree, zs)
- where llen = (n-1) `div` 2
- rlen = n - 1 - llen
- (ltree, a:ys) = sl2bst llen xs
- (rtree, zs) = sl2bst rlen ys
-
-elemTree a Nil = False
-elemTree a (Node ltree x rtree)
- = case compare a x of
- LT -> elemTree a ltree
- GT -> elemTree a rtree
- EQ -> True
-
-
diff --git a/src/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs
deleted file mode 100644
index f9bf02598..000000000
--- a/src/GF/Data/Parsers.hs
+++ /dev/null
@@ -1,196 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Parsers
--- Maintainer : Aarne Ranta
--- Stability : Almost Obsolete
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/04/21 16:22:06 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- some parser combinators a la Wadler and Hutton.
--- no longer used in many places in GF
--- (only used in module "EBNF")
------------------------------------------------------------------------------
-
-module GF.Data.Parsers (-- * Main types and functions
- Parser, parseResults, parseResultErr,
- -- * Basic combinators (on any token type)
- (...), (.>.), (|||), (+||), literal, (***),
- succeed, fails, (+..), (..+), (<<<), (|>),
- many, some, longestOfMany, longestOfSome,
- closure,
- -- * Specific combinators (for @Char@ token type)
- pJunk, pJ, jL, pTList, pTJList, pElem,
- (....), item, satisfy, literals, lits,
- pParenth, pCommaList, pOptCommaList,
- pArgList, pArgList2,
- pIdent, pLetter, pDigit, pLetters,
- pAlphanum, pAlphaPlusChar,
- pQuotedString, pIntc
- ) where
-
-import GF.Data.Operations
-import Data.Char
-import Data.List
-
-
-infixr 2 |||, +||
-infixr 3 ***
-infixr 5 .>.
-infixr 5 ...
-infixr 5 ....
-infixr 5 +..
-infixr 5 ..+
-infixr 6 |>
-infixr 3 <<<
-
-
-type Parser a b = [a] -> [(b,[a])]
-
-parseResults :: Parser a b -> [a] -> [b]
-parseResults p s = [x | (x,r) <- p s, null r]
-
-parseResultErr :: Show a => Parser a b -> [a] -> Err b
-parseResultErr p s = case parseResults p s of
- [x] -> return x
- [] -> case
- maximumBy (\x y -> compare (length y) (length x)) (s:[r | (_,r) <- p s]) of
- r -> Bad $ "\nno parse; reached" ++++ take 300 (show r)
- _ -> Bad "ambiguous"
-
-(...) :: Parser a b -> Parser a c -> Parser a (b,c)
-(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t]
-
-(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c
-(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t]
-
-(|||) :: Parser a b -> Parser a b -> Parser a b
-(p ||| q) s = p s ++ q s
-
-(+||) :: Parser a b -> Parser a b -> Parser a b
-p1 +|| p2 = take 1 . (p1 ||| p2)
-
-literal :: (Eq a) => a -> Parser a a
-literal x (c:cs) = [(x,cs) | x == c]
-literal _ _ = []
-
-(***) :: Parser a b -> (b -> c) -> Parser a c
-(p *** f) s = [(f x,r) | (x,r) <- p s]
-
-succeed :: b -> Parser a b
-succeed v s = [(v,s)]
-
-fails :: Parser a b
-fails s = []
-
-(+..) :: Parser a b -> Parser a c -> Parser a c
-p1 +.. p2 = p1 ... p2 *** snd
-
-(..+) :: Parser a b -> Parser a c -> Parser a b
-p1 ..+ p2 = p1 ... p2 *** fst
-
-(<<<) :: Parser a b -> c -> Parser a c -- return
-p <<< v = p *** (\x -> v)
-
-(|>) :: Parser a b -> (b -> Bool) -> Parser a b
-p |> b = p .>. (\x -> if b x then succeed x else fails)
-
-many :: Parser a b -> Parser a [b]
-many p = (p ... many p *** uncurry (:)) +|| succeed []
-
-some :: Parser a b -> Parser a [b]
-some p = (p ... many p) *** uncurry (:)
-
-longestOfMany :: Parser a b -> Parser a [b]
-longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed []
-
-closure :: (b -> Parser a b) -> (b -> Parser a b)
-closure p v = p v .>. closure p ||| succeed v
-
-pJunk :: Parser Char String
-pJunk = longestOfMany (satisfy (\x -> elem x "\n\t "))
-
-pJ :: Parser Char a -> Parser Char a
-pJ p = pJunk +.. p ..+ pJunk
-
-pTList :: String -> Parser Char a -> Parser Char [a]
-pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999
-
-pTJList :: String -> String -> Parser Char a -> Parser Char [a]
-pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:))
-
-pElem :: [String] -> Parser Char String
-pElem l = foldr (+||) fails (map literals l)
-
-(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c)
-p1 .... p2 = p1 ... pJunk +.. p2
-
-item :: Parser a a
-item (c:cs) = [(c,cs)]
-item [] = []
-
-satisfy :: (a -> Bool) -> Parser a a
-satisfy b = item |> b
-
-literals :: (Eq a,Show a) => [a] -> Parser a [a]
-literals l = case l of
- [] -> succeed []
- a:l -> literal a ... literals l *** (\ (x,y) -> x:y)
-
-lits :: (Eq a,Show a) => [a] -> Parser a [a]
-lits ts = literals ts
-
-jL :: String -> Parser Char String
-jL = pJ . lits
-
-pParenth :: Parser Char a -> Parser Char a
-pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')'
-
--- | p,...,p
-pCommaList :: Parser Char a -> Parser Char [a]
-pCommaList p = pTList "," (pJ p)
-
--- | the same or nothing
-pOptCommaList :: Parser Char a -> Parser Char [a]
-pOptCommaList p = pCommaList p ||| succeed []
-
--- | (p,...,p), poss. empty
-pArgList :: Parser Char a -> Parser Char [a]
-pArgList p = pParenth (pCommaList p) ||| succeed []
-
--- | min. 2 args
-pArgList2 :: Parser Char a -> Parser Char [a]
-pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:)
-
-longestOfSome :: Parser a b -> Parser a [b]
-longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y)
-
-pIdent :: Parser Char String
-pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:)
- where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\''
-
-pLetter, pDigit :: Parser Char Char
-pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++
- ['\192' .. '\255'])) -- no such in Char
-pDigit = satisfy isDigit
-
-pLetters :: Parser Char String
-pLetters = longestOfSome pLetter
-
-pAlphanum, pAlphaPlusChar :: Parser Char Char
-pAlphanum = pDigit ||| pLetter
-pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'")
-
-pQuotedString :: Parser Char String
-pQuotedString = literal '"' +.. pEndQuoted where
- pEndQuoted =
- literal '"' *** (const [])
- +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:))
- +|| item .>. \ c -> pEndQuoted *** (c:)
-
-pIntc :: Parser Char Int
-pIntc = some (satisfy numb) *** read
- where numb x = elem x ['0'..'9']
-
diff --git a/src/GF/Data/RedBlack.hs b/src/GF/Data/RedBlack.hs
deleted file mode 100644
index fd70dba63..000000000
--- a/src/GF/Data/RedBlack.hs
+++ /dev/null
@@ -1,64 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : RedBlack
--- Maintainer : Markus Forsberg
--- Stability : Stable
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/04/21 16:22:07 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- Modified version of Osanaki's implementation.
------------------------------------------------------------------------------
-
-module GF.Data.RedBlack (
- emptyTree,
- isEmpty,
- Tree,
- lookupTree,
- insertTree,
- flatten
- ) where
-
-data Color = R | B
- deriving (Show,Read)
-
-data Tree key el = E | T Color (Tree key el) (key,el) (Tree key el)
- deriving (Show,Read)
-
-balance :: Color -> Tree a b -> (a,b) -> Tree a b -> Tree a b
-balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
-balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
-balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
-balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
-balance color a x b = T color a x b
-
-emptyTree :: Tree key el
-emptyTree = E
-
-isEmpty :: Tree key el -> Bool
-isEmpty (E) = True
-isEmpty _ = False
-
-lookupTree :: Ord a => a -> Tree a b -> Maybe b
-lookupTree _ E = Nothing
-lookupTree x (T _ a (y,z) b)
- | x < y = lookupTree x a
- | x > y = lookupTree x b
- | otherwise = return z
-
-insertTree :: Ord a => (a,b) -> Tree a b -> Tree a b
-insertTree (key,el) tree = T B a y b
- where
- T _ a y b = ins tree
- ins E = T R E (key,el) E
- ins (T color a y@(key',el') b)
- | key < key' = balance color (ins a) y b
- | key > key' = balance color a y (ins b)
- | otherwise = T color a (key',el) b
-
-flatten :: Tree a b -> [(a,b)]
-flatten E = []
-flatten (T _ left (key,e) right)
- = (flatten left) ++ ((key,e):(flatten right))
diff --git a/src/GF/Data/RedBlackSet.hs b/src/GF/Data/RedBlackSet.hs
deleted file mode 100644
index 8a1b8a743..000000000
--- a/src/GF/Data/RedBlackSet.hs
+++ /dev/null
@@ -1,150 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : RedBlackSet
--- Maintainer : Peter Ljunglöf
--- Stability : Stable
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/03/21 14:17:39 $
--- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
---
--- Modified version of Okasaki's red-black trees
--- incorporating sets and set-valued maps
-----------------------------------------------------------------------
-
-module GF.Data.RedBlackSet ( -- * Red-black sets
- RedBlackSet,
- rbEmpty,
- rbList,
- rbElem,
- rbLookup,
- rbInsert,
- rbMap,
- rbOrdMap,
- -- * Red-black finite maps
- RedBlackMap,
- rbmEmpty,
- rbmList,
- rbmElem,
- rbmLookup,
- rbmInsert,
- rbmOrdMap
- ) where
-
---------------------------------------------------------------------------------
--- sets
-
-data Color = R | B deriving (Eq, Show)
-data RedBlackSet a = E | T Color (RedBlackSet a) a (RedBlackSet a)
- deriving (Eq, Show)
-
-rbBalance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d)
-rbBalance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d)
-rbBalance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d)
-rbBalance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d)
-rbBalance color a x b = T color a x b
-
-rbBlack (T _ a x b) = T B a x b
-
--- | the empty set
-rbEmpty :: RedBlackSet a
-rbEmpty = E
-
--- | the elements of a set as a sorted list
-rbList :: RedBlackSet a -> [a]
-rbList tree = rbl tree []
- where rbl E = id
- rbl (T _ left a right) = rbl right . (a:) . rbl left
-
--- | checking for containment
-rbElem :: Ord a => a -> RedBlackSet a -> Bool
-rbElem _ E = False
-rbElem a (T _ left a' right)
- = case compare a a' of
- LT -> rbElem a left
- GT -> rbElem a right
- EQ -> True
-
--- | looking up a key in a set of keys and values
-rbLookup :: Ord k => k -> RedBlackSet (k, a) -> Maybe a
-rbLookup _ E = Nothing
-rbLookup a (T _ left (a',b) right)
- = case compare a a' of
- LT -> rbLookup a left
- GT -> rbLookup a right
- EQ -> Just b
-
--- | inserting a new element.
--- returns 'Nothing' if the element is already contained
-rbInsert :: Ord a => a -> RedBlackSet a -> Maybe (RedBlackSet a)
-rbInsert value tree = fmap rbBlack (rbins tree)
- where rbins E = Just (T R E value E)
- rbins (T color left value' right)
- = case compare value value' of
- LT -> do left' <- rbins left
- return (rbBalance color left' value' right)
- GT -> do right' <- rbins right
- return (rbBalance color left value' right')
- EQ -> Nothing
-
--- | mapping each value of a key-value set
-rbMap :: (a -> b) -> RedBlackSet (k, a) -> RedBlackSet (k, b)
-rbMap f E = E
-rbMap f (T color left (key, value) right)
- = T color (rbMap f left) (key, f value) (rbMap f right)
-
--- | mapping each element to another type.
--- /observe/ that the mapping function needs to preserve
--- the order between objects
-rbOrdMap :: (a -> b) -> RedBlackSet a -> RedBlackSet b
-rbOrdMap f E = E
-rbOrdMap f (T color left value right)
- = T color (rbOrdMap f left) (f value) (rbOrdMap f right)
-
-----------------------------------------------------------------------
--- finite maps
-
-type RedBlackMap k a = RedBlackSet (k, RedBlackSet a)
-
--- | the empty map
-rbmEmpty :: RedBlackMap k a
-rbmEmpty = E
-
--- | converting a map to a key-value list, sorted on the keys,
--- and for each key, a sorted list of values
-rbmList :: RedBlackMap k a -> [(k, [a])]
-rbmList tree = [ (k, rbList sub) | (k, sub) <- rbList tree ]
-
--- | checking whether a key-value pair is contained in the map
-rbmElem :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Bool
-rbmElem key value = maybe False (rbElem value) . rbLookup key
-
--- | looking up a key, returning a (sorted) list of all matching values
-rbmLookup :: Ord k => k -> RedBlackMap k a -> [a]
-rbmLookup key = maybe [] rbList . rbLookup key
-
--- | inserting a key-value pair.
--- returns 'Nothing' if the pair is already contained in the map
-rbmInsert :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Maybe (RedBlackMap k a)
-rbmInsert key value tree = fmap rbBlack (rbins tree)
- where rbins E = Just (T R E (key, T B E value E) E)
- rbins (T color left item@(key', vtree) right)
- = case compare key key' of
- LT -> do left' <- rbins left
- return (rbBalance color left' item right)
- GT -> do right' <- rbins right
- return (rbBalance color left item right')
- EQ -> do vtree' <- rbInsert value vtree
- return (T color left (key', vtree') right)
-
--- | mapping each value to another type.
--- /observe/ that the mapping function needs to preserve
--- order between objects
-rbmOrdMap :: (a -> b) -> RedBlackMap k a -> RedBlackMap k b
-rbmOrdMap f E = E
-rbmOrdMap f (T color left (key, tree) right)
- = T color (rbmOrdMap f left) (key, rbOrdMap f tree) (rbmOrdMap f right)
-
-
-
diff --git a/src/GF/Data/SharedString.hs b/src/GF/Data/SharedString.hs
deleted file mode 100644
index 9d037b512..000000000
--- a/src/GF/Data/SharedString.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-
-module GF.Data.SharedString (shareString) where
-
-import Data.HashTable as H
-import System.IO.Unsafe (unsafePerformIO)
-
-{-# NOINLINE stringPool #-}
-stringPool :: HashTable String String
-stringPool = unsafePerformIO $ new (==) hashString
-
-{-# NOINLINE shareString #-}
-shareString :: String -> String
-shareString s = unsafePerformIO $ do
- mv <- H.lookup stringPool s
- case mv of
- Just s' -> return s'
- Nothing -> do
- H.insert stringPool s s
- return s
diff --git a/src/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs
deleted file mode 100644
index d77ff68d4..000000000
--- a/src/GF/Data/SortedList.hs
+++ /dev/null
@@ -1,127 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
-
-
-
-
-
diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs
deleted file mode 100644
index 6f65764c7..000000000
--- a/src/GF/Data/Str.hs
+++ /dev/null
@@ -1,134 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
diff --git a/src/GF/Data/Trie.hs b/src/GF/Data/Trie.hs
deleted file mode 100644
index 9fb5daa27..000000000
--- a/src/GF/Data/Trie.hs
+++ /dev/null
@@ -1,129 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Trie
--- Maintainer : Markus Forsberg
--- Stability : Obsolete
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/04/21 16:22:09 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.6 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Data.Trie (
- tcompile,
- collapse,
- Trie,
- trieLookup,
- decompose,
- Attr,
- atW, atP, atWP
- ) where
-
-import GF.Data.Map
-
---- data Attr = W | P | WP deriving Eq
-type Attr = Int
-
-atW, atP, atWP :: Attr
-(atW,atP,atWP) = (0,1,2)
-
-newtype TrieT = TrieT ([(Char,TrieT)],[(Attr,String)])
-
-newtype Trie = Trie (Map Char Trie, [(Attr,String)])
-
-emptyTrie = TrieT ([],[])
-
-optimize :: TrieT -> Trie
-optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty,
- res)
-
-collapse :: Trie -> [(String,[(Attr,String)])]
-collapse trie = collapse' trie []
- where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))]
- else (reverse s,(x:xs)):
- concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
- collapse' (Trie (map,[])) s
- = concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
-
-tcompile :: [(String,[(Attr,String)])] -> Trie
-tcompile xs = optimize $ build xs emptyTrie
-
-build :: [(String,[(Attr,String)])] -> TrieT -> TrieT
-build [] trie = trie
-build (x:xs) trie = build xs (insert x trie)
- where
- insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res)
- insert ((s:ss),ys) (TrieT (xs,res))
- = case (span (\(s',_) -> s' /= s) xs) of
- (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrie)):xs),res)
- (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res)
-
-trieLookup :: Trie -> String -> (String,[(Attr,String)])
-trieLookup trie s = apply trie s s
-
-apply :: Trie -> String -> String -> (String,[(Attr,String)])
-apply (Trie (_,res)) [] inp = (inp,res)
-apply (Trie (map,_)) (s:ss) inp
- = case map ! s of
- Just trie -> apply trie ss inp
- Nothing -> (inp,[])
-
--- Composite analysis (Huet's unglue algorithm)
--- only legaldecompositions are accepted.
--- With legal means that the composite forms are ordered correctly
--- with respect to the attributes W,P and WP.
-
--- Composite analysis
-
-testTrie = tcompile [("flick",[(atP,"P")]),("knopp",[(atW,"W")]),("flaggstångs",[(atWP,"WP")])]
-
-decompose :: Trie -> String -> [String]
-decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie
-
--- The function legal checks if the decomposition is in fact a possible one.
-
-legal :: Trie -> [String] -> [String]
-legal _ [] = []
-legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else []
- where
- test [] = False
- test [xs] = elem atW xs || elem atWP xs
- test (xs:xss) = (elem atP xs || elem atWP xs) && test xss
-
-react :: String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String]
-react input output back occ (Trie (arcs,res)) init =
- case res of -- Accept = non-empty res.
- [] -> continue back
- _ -> let pushout = (occ:output)
- in case input of
- [] -> reverse $ map reverse pushout
- _ -> let pushback = ((input,pushout):back)
- in continue pushback
- where continue cont = case input of
- [] -> backtrack cont init
- (l:rest) -> case arcs ! l of
- Just trie ->
- react rest output cont (l:occ) trie init
- Nothing -> backtrack cont init
-
-backtrack :: [(String,[String])] -> Trie -> [String]
-backtrack [] _ = []
-backtrack ((input,output):back) trie
- = react input output back [] trie trie
-
-{-
--- The function legal checks if the decomposition is in fact a possible one.
-legal :: Trie -> [String] -> [String]
-legal _ [] = []
-legal trie input
- | test $
- map ((map fst).snd.(trieLookup trie)) input = input
- | otherwise = []
- where -- test checks that the Attrs are in the correct order.
- test [] = False -- This case should never happen.
- test [xs] = elem W xs || elem WP xs
- test (xs:xss) = (elem P xs || elem WP xs) && test xss
--}
diff --git a/src/GF/Data/Trie2.hs b/src/GF/Data/Trie2.hs
deleted file mode 100644
index 36fcc3221..000000000
--- a/src/GF/Data/Trie2.hs
+++ /dev/null
@@ -1,120 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : Trie2
--- Maintainer : Markus Forsberg
--- Stability : Stable
--- Portability : Haskell 98
---
--- > CVS $Date: 2005/04/21 16:22:10 $
--- > CVS $Author: bringert $
--- > CVS $Revision: 1.7 $
---
--- (Description of the module)
------------------------------------------------------------------------------
-
-module GF.Data.Trie2 (
- tcompile,
- collapse,
- Trie,
- trieLookup,
- decompose,
- --- Attr, atW, atP, atWP,
- emptyTrie
- ) where
-
-import GF.Data.Map
-import Data.List
-
-newtype TrieT a b = TrieT ([(a,TrieT a b)],[b])
-
-newtype Trie a b = Trie (Map a (Trie a b), [b])
-
-emptyTrieT = TrieT ([],[])
-
-emptyTrie :: Trie a b
-emptyTrie = Trie (empty,[])
-
-optimize :: (Ord a,Eq b) => TrieT a b -> Trie a b
-optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty,
- nub res) --- nub by AR
-
-collapse :: Ord a => Trie a b -> [([a],[b])]
-collapse trie = collapse' trie []
- where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))]
- else (reverse s,(x:xs)):
- concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
- collapse' (Trie (map,[])) s
- = concat [ collapse' trie (c:s) | (c,trie) <- flatten map]
-
-tcompile :: (Ord a,Eq b) => [([a],[b])] -> Trie a b
-tcompile xs = optimize $ build xs emptyTrieT
-
-build :: Ord a => [([a],[b])] -> TrieT a b -> TrieT a b
-build [] trie = trie
-build (x:xs) trie = build xs (insert x trie)
- where
- insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res)
- insert ((s:ss),ys) (TrieT (xs,res))
- = case (span (\(s',_) -> s' /= s) xs) of
- (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrieT)):xs),res)
- (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res)
-
-trieLookup :: Ord a => Trie a b -> [a] -> ([a],[b])
-trieLookup trie s = apply trie s s
-
-apply :: Ord a => Trie a b -> [a] -> [a] -> ([a],[b])
-apply (Trie (_,res)) [] inp = (inp,res)
-apply (Trie (map,_)) (s:ss) inp
- = case map ! s of
- Just trie -> apply trie ss inp
- Nothing -> (inp,[])
-
------------------------------
--- from Trie for strings; simplified for GF by making binding always possible (AR)
-
-decompose :: Ord a => Trie a b -> [a] -> [[a]]
-decompose trie sentence = backtrack [(sentence,[])] trie
-
-react :: Ord a => [a] -> [[a]] -> [([a],[[a]])] ->
- [a] -> Trie a b -> Trie a b -> [[a]]
--- String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String]
-react input output back occ (Trie (arcs,res)) init =
- case res of -- Accept = non-empty res.
- [] -> continue back
- _ -> let pushout = (occ:output)
- in case input of
- [] -> reverse $ map reverse pushout
- _ -> let pushback = ((input,pushout):back)
- in continue pushback
- where continue cont = case input of
- [] -> backtrack cont init
- (l:rest) -> case arcs ! l of
- Just trie ->
- react rest output cont (l:occ) trie init
- Nothing -> backtrack cont init
-
-backtrack :: Ord a => [([a],[[a]])] -> Trie a b -> [[a]]
-backtrack [] _ = []
-backtrack ((input,output):back) trie
- = react input output back [] trie trie
-
-
-{- so this is not needed from the original
-type Attr = Int
-
-atW, atP, atWP :: Attr
-(atW,atP,atWP) = (0,1,2)
-
-decompose :: Ord a => Trie a (Int,b) -> [a] -> [[a]]
-decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie
-
--- The function legal checks if the decomposition is in fact a possible one.
-
-legal :: Ord a => Trie a (Int,b) -> [[a]] -> [[a]]
-legal _ [] = []
-legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else []
- where
- test [] = False
- test [xs] = elem atW xs || elem atWP xs
- test (xs:xss) = (elem atP xs || elem atWP xs) && test xss
--}
diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs
deleted file mode 100644
index 74d3ef81e..000000000
--- a/src/GF/Data/Utilities.hs
+++ /dev/null
@@ -1,190 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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)
-
-
-
diff --git a/src/GF/Data/XML.hs b/src/GF/Data/XML.hs
deleted file mode 100644
index a1807adcc..000000000
--- a/src/GF/Data/XML.hs
+++ /dev/null
@@ -1,57 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module : XML
--- Maintainer : BB
--- Stability : (stable)
--- Portability : (portable)
---
--- 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 '<' = "&lt;"
- escChar '>' = "&gt;"
- escChar '&' = "&amp;"
- escChar '"' = "&quot;"
- 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
diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs
deleted file mode 100644
index a4491f76e..000000000
--- a/src/GF/Data/Zipper.hs
+++ /dev/null
@@ -1,257 +0,0 @@
-----------------------------------------------------------------------
--- |
--- 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
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 06:29:16 +0000