GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/Data/Assoc.hs

@@ -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 
+
+
+
+
+
+
+

src-3.0/GF/Data/BacktrackM.hs

@@ -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)

src-3.0/GF/Data/Compos.hs

@@ -0,0 +1,37 @@
+{-# 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)

src-3.0/GF/Data/ErrM.hs

@@ -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

src-3.0/GF/Data/GeneralDeduction.hs

@@ -0,0 +1,121 @@
+----------------------------------------------------------------------
+-- |
+-- 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
+--------------------------------------------------------------------------------}
+

src-3.0/GF/Data/Glue.hs

@@ -0,0 +1,30 @@
+----------------------------------------------------------------------
+-- |
+-- 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"
+

src-3.0/GF/Data/IncrementalDeduction.hs

@@ -0,0 +1,67 @@
+----------------------------------------------------------------------
+-- |
+-- 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)
+

src-3.0/GF/Data/Map.hs

@@ -0,0 +1,61 @@
+----------------------------------------------------------------------
+-- |
+-- 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

src-3.0/GF/Data/Operations.hs

@@ -0,0 +1,658 @@
+----------------------------------------------------------------------
+-- |
+-- 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

src-3.0/GF/Data/OrdMap2.hs

@@ -0,0 +1,127 @@
+----------------------------------------------------------------------
+-- |
+-- 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)
+
+
+
+

src-3.0/GF/Data/OrdSet.hs

@@ -0,0 +1,120 @@
+----------------------------------------------------------------------
+-- |
+-- 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
+
+

src-3.0/GF/Data/Parsers.hs

@@ -0,0 +1,196 @@
+----------------------------------------------------------------------
+-- |
+-- 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']
+

src-3.0/GF/Data/RedBlack.hs

@@ -0,0 +1,64 @@
+----------------------------------------------------------------------
+-- |
+-- 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))

src-3.0/GF/Data/RedBlackSet.hs

@@ -0,0 +1,150 @@
+----------------------------------------------------------------------
+-- |
+-- 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)
+
+
+

src-3.0/GF/Data/SharedString.hs

@@ -0,0 +1,19 @@
+
+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

src-3.0/GF/Data/SortedList.hs

@@ -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
+
+
+
+
+

src-3.0/GF/Data/Str.hs

@@ -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

src-3.0/GF/Data/Trie.hs

@@ -0,0 +1,129 @@
+----------------------------------------------------------------------
+-- |
+-- 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
+-}

src-3.0/GF/Data/Trie2.hs

@@ -0,0 +1,120 @@
+----------------------------------------------------------------------
+-- |
+-- 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
+-}

src-3.0/GF/Data/Utilities.hs

@@ -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)
+
+
+

src-3.0/GF/Data/XML.hs

@@ -0,0 +1,57 @@
+----------------------------------------------------------------------
+-- |
+-- 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

src-3.0/GF/Data/Zipper.hs

@@ -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