From b96b36f43de3e2f8b58d5f539daa6f6d47f25870 Mon Sep 17 00:00:00 2001 From: aarne Date: Wed, 25 Jun 2008 16:43:48 +0000 Subject: removed src for 2.9 --- src/GF/Data/Assoc.hs | 143 -------- src/GF/Data/BacktrackM.hs | 93 ----- src/GF/Data/Compos.hs | 37 -- src/GF/Data/ErrM.hs | 38 --- src/GF/Data/GeneralDeduction.hs | 121 ------- src/GF/Data/Glue.hs | 30 -- src/GF/Data/IncrementalDeduction.hs | 67 ---- src/GF/Data/Map.hs | 61 ---- src/GF/Data/Operations.hs | 658 ------------------------------------ src/GF/Data/OrdMap2.hs | 127 ------- src/GF/Data/OrdSet.hs | 120 ------- src/GF/Data/Parsers.hs | 196 ----------- src/GF/Data/RedBlack.hs | 64 ---- src/GF/Data/RedBlackSet.hs | 150 -------- src/GF/Data/SharedString.hs | 19 -- src/GF/Data/SortedList.hs | 127 ------- src/GF/Data/Str.hs | 134 -------- src/GF/Data/Trie.hs | 129 ------- src/GF/Data/Trie2.hs | 120 ------- src/GF/Data/Utilities.hs | 190 ----------- src/GF/Data/XML.hs | 57 ---- src/GF/Data/Zipper.hs | 257 -------------- 22 files changed, 2938 deletions(-) delete mode 100644 src/GF/Data/Assoc.hs delete mode 100644 src/GF/Data/BacktrackM.hs delete mode 100644 src/GF/Data/Compos.hs delete mode 100644 src/GF/Data/ErrM.hs delete mode 100644 src/GF/Data/GeneralDeduction.hs delete mode 100644 src/GF/Data/Glue.hs delete mode 100644 src/GF/Data/IncrementalDeduction.hs delete mode 100644 src/GF/Data/Map.hs delete mode 100644 src/GF/Data/Operations.hs delete mode 100644 src/GF/Data/OrdMap2.hs delete mode 100644 src/GF/Data/OrdSet.hs delete mode 100644 src/GF/Data/Parsers.hs delete mode 100644 src/GF/Data/RedBlack.hs delete mode 100644 src/GF/Data/RedBlackSet.hs delete mode 100644 src/GF/Data/SharedString.hs delete mode 100644 src/GF/Data/SortedList.hs delete mode 100644 src/GF/Data/Str.hs delete mode 100644 src/GF/Data/Trie.hs delete mode 100644 src/GF/Data/Trie2.hs delete mode 100644 src/GF/Data/Utilities.hs delete mode 100644 src/GF/Data/XML.hs delete mode 100644 src/GF/Data/Zipper.hs (limited to 'src/GF/Data') diff --git a/src/GF/Data/Assoc.hs b/src/GF/Data/Assoc.hs deleted file mode 100644 index f775319ea..000000000 --- a/src/GF/Data/Assoc.hs +++ /dev/null @@ -1,143 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Assoc --- Maintainer : Peter Ljunglöf --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.4 $ --- --- Association lists, or finite maps, --- including sets as maps with result type @()@. --- function names stolen from module @Array@. --- /O(log n)/ key lookup ------------------------------------------------------------------------------ - -module GF.Data.Assoc ( Assoc, - Set, - emptyAssoc, - emptySet, - listAssoc, - listSet, - accumAssoc, - aAssocs, - aElems, - assocMap, - assocFilter, - lookupAssoc, - lookupWith, - (?), - (?=) - ) where - -import GF.Data.SortedList - -infixl 9 ?, ?= - --- | a set is a finite map with empty values -type Set a = Assoc a () - -emptyAssoc :: Ord a => Assoc a b -emptySet :: Ord a => Set a - --- | creating a finite map from a sorted key-value list -listAssoc :: Ord a => SList (a, b) -> Assoc a b - --- | creating a set from a sorted list -listSet :: Ord a => SList a -> Set a - --- | building a finite map from a list of keys and 'b's, --- and a function that combines a sorted list of 'b's into a value -accumAssoc :: (Ord a, Ord c) => (SList c -> b) -> [(a, c)] -> Assoc a b - --- | all key-value pairs from an association list -aAssocs :: Ord a => Assoc a b -> SList (a, b) - --- | all keys from an association list -aElems :: Ord a => Assoc a b -> SList a - --- fmap :: Ord a => (b -> b') -> Assoc a b -> Assoc a b' - --- | mapping values to other values. --- the mapping function can take the key as information -assocMap :: Ord a => (a -> b -> b') -> Assoc a b -> Assoc a b' - -assocFilter :: Ord a => (b -> Bool) -> Assoc a b -> Assoc a b -assocFilter pred = listAssoc . filter (pred . snd) . aAssocs - --- | monadic lookup function, --- returning failure if the key does not exist -lookupAssoc :: (Ord a, Monad m) => Assoc a b -> a -> m b - --- | if the key does not exist, --- the first argument is returned -lookupWith :: Ord a => b -> Assoc a b -> a -> b - --- | if the values are monadic, we can return the value type -(?) :: (Ord a, Monad m) => Assoc a (m b) -> a -> m b - --- | checking wheter the map contains a given key -(?=) :: Ord a => Assoc a b -> a -> Bool - - ------------------------------------------------------------- - -data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b) - deriving (Eq, Ord, Show) - -emptyAssoc = ANil -emptySet = emptyAssoc - -listAssoc as = assoc - where (assoc, []) = sl2bst (length as) as - sl2bst 0 xs = (ANil, xs) - sl2bst 1 (x:xs) = (ANode ANil (fst x) (snd x) ANil, xs) - sl2bst n xs = (ANode left (fst x) (snd x) right, zs) - where llen = (n-1) `div` 2 - rlen = n - 1 - llen - (left, x:ys) = sl2bst llen xs - (right, zs) = sl2bst rlen ys - -listSet as = listAssoc (zip as (repeat ())) - -accumAssoc join = listAssoc . map (mapSnd join) . groupPairs . nubsort - where mapSnd f (a, b) = (a, f b) - -aAssocs as = prs as [] - where prs ANil = id - prs (ANode left a b right) = prs left . ((a,b) :) . prs right - -aElems = map fst . aAssocs - - -instance Ord a => Functor (Assoc a) where - fmap f = assocMap (const f) - -assocMap f ANil = ANil -assocMap f (ANode left a b right) = ANode (assocMap f left) a (f a b) (assocMap f right) - - -lookupAssoc ANil _ = fail "key not found" -lookupAssoc (ANode left a b right) a' = case compare a a' of - GT -> lookupAssoc left a' - LT -> lookupAssoc right a' - EQ -> return b - -lookupWith z ANil _ = z -lookupWith z (ANode left a b right) a' = case compare a a' of - GT -> lookupWith z left a' - LT -> lookupWith z right a' - EQ -> b - -(?) = lookupWith (fail "key not found") - -(?=) = \assoc -> maybe False (const True) . lookupAssoc assoc - - - - - - - diff --git a/src/GF/Data/BacktrackM.hs b/src/GF/Data/BacktrackM.hs deleted file mode 100644 index 790d11a83..000000000 --- a/src/GF/Data/BacktrackM.hs +++ /dev/null @@ -1,93 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : BacktrackM --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.4 $ --- --- Backtracking state monad, with r\/o environment ------------------------------------------------------------------------------ - -{-# OPTIONS_GHC -fglasgow-exts #-} -module GF.Data.BacktrackM ( -- * the backtracking state monad - BacktrackM, - -- * controlling the monad - failure, - (|||), - -- * handling the state & environment - readState, - writeState, - -- * monad specific utilities - member, - -- * running the monad - foldBM, runBM, - foldSolutions, solutions, - foldFinalStates, finalStates - ) where - -import Data.List -import Control.Monad - ----------------------------------------------------------------------- --- Combining endomorphisms and continuations --- a la Ralf Hinze - --- BacktrackM = state monad transformer over the backtracking monad - -newtype BacktrackM s a = BM (forall b . (a -> s -> b -> b) -> s -> b -> b) - --- * running the monad - -runBM :: BacktrackM s a -> s -> [(s,a)] -runBM (BM m) s = m (\x s xs -> (s,x) : xs) s [] - -foldBM :: (a -> s -> b -> b) -> b -> BacktrackM s a -> s -> b -foldBM f b (BM m) s = m f s b - -foldSolutions :: (a -> b -> b) -> b -> BacktrackM s a -> s -> b -foldSolutions f b (BM m) s = m (\x s b -> f x b) s b - -solutions :: BacktrackM s a -> s -> [a] -solutions = foldSolutions (:) [] - -foldFinalStates :: (s -> b -> b) -> b -> BacktrackM s () -> s -> b -foldFinalStates f b (BM m) s = m (\x s b -> f s b) s b - -finalStates :: BacktrackM s () -> s -> [s] -finalStates bm = map fst . runBM bm - - --- * handling the state & environment - -readState :: BacktrackM s s -readState = BM (\c s b -> c s s b) - -writeState :: s -> BacktrackM s () -writeState s = BM (\c _ b -> c () s b) - -instance Monad (BacktrackM s) where - return a = BM (\c s b -> c a s b) - BM m >>= k = BM (\c s b -> m (\a s b -> unBM (k a) c s b) s b) - where unBM (BM m) = m - fail _ = failure - --- * controlling the monad - -failure :: BacktrackM s a -failure = BM (\c s b -> b) - -(|||) :: BacktrackM s a -> BacktrackM s a -> BacktrackM s a -(BM f) ||| (BM g) = BM (\c s b -> g c s $! f c s b) - -instance MonadPlus (BacktrackM s) where - mzero = failure - mplus = (|||) - --- * specific functions on the backtracking monad - -member :: [a] -> BacktrackM s a -member xs = BM (\c s b -> foldl' (\b x -> c x s b) b xs) diff --git a/src/GF/Data/Compos.hs b/src/GF/Data/Compos.hs deleted file mode 100644 index 7d46fc5a2..000000000 --- a/src/GF/Data/Compos.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# OPTIONS_GHC -fglasgow-exts #-} -module GF.Data.Compos (Compos(..),composOp,composM,composM_,composFold) where - -import Control.Applicative (Applicative(..), Const(..), WrappedMonad(..)) -import Data.Monoid (Monoid(..)) - -class Compos t where - compos :: Applicative f => (forall a. t a -> f (t a)) -> t c -> f (t c) - -composOp :: Compos t => (forall a. t a -> t a) -> t c -> t c -composOp f = runIdentity . compos (Identity . f) - -composFold :: (Monoid o, Compos t) => (forall a. t a -> o) -> t c -> o -composFold f = getConst . compos (Const . f) - -composM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t c -> m (t c) -composM f = unwrapMonad . compos (WrapMonad . f) - -composM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t c -> m () -composM_ f = unwrapMonad_ . composFold (WrapMonad_ . f) - - -newtype Identity a = Identity { runIdentity :: a } - -instance Functor Identity where - fmap f (Identity x) = Identity (f x) - -instance Applicative Identity where - pure = Identity - Identity f <*> Identity x = Identity (f x) - - -newtype WrappedMonad_ m = WrapMonad_ { unwrapMonad_ :: m () } - -instance Monad m => Monoid (WrappedMonad_ m) where - mempty = WrapMonad_ (return ()) - WrapMonad_ x `mappend` WrapMonad_ y = WrapMonad_ (x >> y) diff --git a/src/GF/Data/ErrM.hs b/src/GF/Data/ErrM.hs deleted file mode 100644 index e8cea12d4..000000000 --- a/src/GF/Data/ErrM.hs +++ /dev/null @@ -1,38 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : ErrM --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:00 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.5 $ --- --- hack for BNFC generated files. AR 21/9/2003 ------------------------------------------------------------------------------ - -module GF.Data.ErrM (Err(..)) where - -import Control.Monad (MonadPlus(..)) - --- | like @Maybe@ type with error msgs -data Err a = Ok a | Bad String - deriving (Read, Show, Eq) - -instance Monad Err where - return = Ok - fail = Bad - Ok a >>= f = f a - Bad s >>= f = Bad s - --- | added 2\/10\/2003 by PEB -instance Functor Err where - fmap f (Ok a) = Ok (f a) - fmap f (Bad s) = Bad s - --- | added by KJ -instance MonadPlus Err where - mzero = Bad "error (no reason given)" - mplus (Ok a) _ = Ok a - mplus (Bad s) b = b diff --git a/src/GF/Data/GeneralDeduction.hs b/src/GF/Data/GeneralDeduction.hs deleted file mode 100644 index 137212e5c..000000000 --- a/src/GF/Data/GeneralDeduction.hs +++ /dev/null @@ -1,121 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Peter Ljunglöf --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:01 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Simple implementation of deductive chart parsing ------------------------------------------------------------------------------ - -module GF.Data.GeneralDeduction - (-- * Type definition - ParseChart, - -- * Main functions - chartLookup, - buildChart, buildChartM, - -- * Probably not needed - emptyChart, - chartMember, - chartInsert, chartInsertM, - chartList, chartKeys, chartAssocs, - addToChart, addToChartM - ) where - --- import Trace - -import GF.Data.RedBlackSet -import Control.Monad (foldM) - ----------------------------------------------------------------------- --- main functions - -chartLookup :: (Ord item, Ord key) => ParseChart item key -> key -> [item] -chartList :: (Ord item, Ord key) => ParseChart item key -> [item] -chartKeys :: (Ord item, Ord key) => ParseChart item key -> [key] -chartAssocs :: (Ord item, Ord key) => ParseChart item key -> [(key,item)] -buildChart :: (Ord item, Ord key) => - (item -> key) -- ^ key lookup function - -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions - -- from triggering items to lists of items - -> [item] -- ^ initial chart - -> ParseChart item key -- ^ final chart -buildChartM :: (Ord item, Ord key) => - (item -> [key]) -- ^ many-valued key lookup function - -> [ParseChart item key -> item -> [item]] -- ^ list of inference rules as functions - -- from triggering items to lists of items - -> [item] -- ^ initial chart - -> ParseChart item key -- ^ final chart - -buildChart keyof rules axioms = addItems axioms emptyChart - where addItems [] = id - addItems (item:items) = addItems items . addItem item - -- addItem item | trace ("+ "++show item++"\n") False = undefined - addItem item = addToChart item (keyof item) - (\chart -> foldr (consequence item) chart rules) - consequence item rule chart = addItems (rule chart item) chart - -buildChartM keysof rules axioms = addItems axioms emptyChart - where addItems [] = id - addItems (item:items) = addItems items . addItem item - -- addItem item | trace ("+ "++show item++"\n") False = undefined - addItem item = addToChartM item (keysof item) - (\chart -> foldr (consequence item) chart rules) - consequence item rule chart = addItems (rule chart item) chart - --- probably not needed - -emptyChart :: (Ord item, Ord key) => ParseChart item key -chartMember :: (Ord item, Ord key) => ParseChart item key - -> item -> key -> Bool -chartInsert :: (Ord item, Ord key) => ParseChart item key - -> item -> key -> Maybe (ParseChart item key) -chartInsertM :: (Ord item, Ord key) => ParseChart item key - -> item -> [key] -> Maybe (ParseChart item key) - -addToChart :: (Ord item, Ord key) => item -> key - -> (ParseChart item key -> ParseChart item key) - -> ParseChart item key -> ParseChart item key -addToChart item keys after chart = maybe chart after (chartInsert chart item keys) - -addToChartM :: (Ord item, Ord key) => item -> [key] - -> (ParseChart item key -> ParseChart item key) - -> ParseChart item key -> ParseChart item key -addToChartM item keys after chart = maybe chart after (chartInsertM chart item keys) - - --------------------------------------------------------------------------------- --- key charts as red/black trees - -newtype ParseChart item key = KC (RedBlackMap key item) - deriving Show - -emptyChart = KC rbmEmpty -chartMember (KC tree) item key = rbmElem key item tree -chartLookup (KC tree) key = rbmLookup key tree -chartList (KC tree) = concatMap snd (rbmList tree) -chartKeys (KC tree) = map fst (rbmList tree) -chartAssocs (KC tree) = [(key,item) | (key,items) <- rbmList tree, item <- items] -chartInsert (KC tree) item key = fmap KC (rbmInsert key item tree) - -chartInsertM (KC tree) item keys = fmap KC (foldM insertItem tree keys) - where insertItem tree key = rbmInsert key item tree - ---------------------------------------------------------------------------------} - - -{-------------------------------------------------------------------------------- --- key charts as unsorted association lists -- OBSOLETE! - -newtype Chart item key = SC [(key, item)] - -emptyChart = SC [] -chartMember (SC chart) item key = (key,item) `elem` chart -chartInsert (SC chart) item key = if (key,item) `elem` chart then Nothing else Just (SC ((key,item):chart)) -chartLookup (SC chart) key = [ item | (key',item) <- chart, key == key' ] -chartList (SC chart) = map snd chart ---------------------------------------------------------------------------------} - diff --git a/src/GF/Data/Glue.hs b/src/GF/Data/Glue.hs deleted file mode 100644 index 4f276222b..000000000 --- a/src/GF/Data/Glue.hs +++ /dev/null @@ -1,30 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Glue --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:02 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- AR 8-11-2003, using Markus Forsberg's implementation of Huet's @unglue@ ------------------------------------------------------------------------------ - -module GF.Data.Glue (decomposeSimple) where - -import GF.Data.Trie2 -import GF.Data.Operations -import Data.List - -decomposeSimple :: Trie Char a -> [Char] -> Err [[Char]] -decomposeSimple t s = do - let ss = map (decompose t) $ words s - if any null ss - then Bad "unknown word in input" - else return $ concat [intersperse "&+" ws | ws <- ss] - -exTrie = tcompile (zip ws ws) where - ws = words "ett tv\229 tre tjugo trettio hundra tusen" - diff --git a/src/GF/Data/IncrementalDeduction.hs b/src/GF/Data/IncrementalDeduction.hs deleted file mode 100644 index d119610c1..000000000 --- a/src/GF/Data/IncrementalDeduction.hs +++ /dev/null @@ -1,67 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/05/09 09:28:44 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.3 $ --- --- Implementation of /incremental/ deductive parsing, --- i.e. parsing one word at the time. ------------------------------------------------------------------------------ - -module GF.Data.IncrementalDeduction - (-- * Type definitions - IncrementalChart, - -- * Functions - chartLookup, - buildChart, - chartList, chartKeys - ) where - -import Data.Array -import GF.Data.SortedList -import GF.Data.Assoc - ----------------------------------------------------------------------- --- main functions - -chartLookup :: (Ord item, Ord key) => - IncrementalChart item key - -> Int -> key -> SList item - -buildChart :: (Ord item, Ord key) => - (item -> key) -- ^ key lookup function - -> (Int -> item -> SList item) -- ^ all inference rules for position k, collected - -> (Int -> SList item) -- ^ all axioms for position k, collected - -> (Int, Int) -- ^ input bounds - -> IncrementalChart item key - -chartList :: (Ord item, Ord key) => - IncrementalChart item key -- ^ the final chart - -> (Int -> item -> edge) -- ^ function building an edge from - -- the position and the item - -> [edge] - -chartKeys :: (Ord item, Ord key) => IncrementalChart item key -> Int -> [key] - -type IncrementalChart item key = Array Int (Assoc key (SList item)) - ----------- - -chartLookup chart k key = (chart ! k) ? key - -buildChart keyof rules axioms bounds = finalChartArray - where buildState k = limit (rules k) $ axioms k - finalChartList = map buildState [fst bounds .. snd bounds] - finalChartArray = listArray bounds $ map stateAssoc finalChartList - stateAssoc state = accumAssoc id [ (keyof item, item) | item <- state ] - -chartList chart combine = [ combine k item | - (k, state) <- assocs chart, - item <- concatMap snd $ aAssocs state ] - -chartKeys chart k = aElems (chart ! k) - diff --git a/src/GF/Data/Map.hs b/src/GF/Data/Map.hs deleted file mode 100644 index c86c9ab55..000000000 --- a/src/GF/Data/Map.hs +++ /dev/null @@ -1,61 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Map --- Maintainer : Markus Forsberg --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:04 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Map ( - Map, - empty, - isEmpty, - (!), - (!+), - (|->), - (|->+), - (<+>), - flatten - ) where - -import GF.Data.RedBlack - -type Map key el = Tree key el - -infixl 6 |-> -infixl 6 |->+ -infixl 5 ! -infixl 5 !+ -infixl 4 <+> - -empty :: Map key el -empty = emptyTree - --- | lookup operator. -(!) :: Ord key => Map key el -> key -> Maybe el -(!) fm e = lookupTree e fm - --- | lookupMany operator. -(!+) :: Ord key => Map key el -> [key] -> [Maybe el] -fm !+ [] = [] -fm !+ (e:es) = (lookupTree e fm): (fm !+ es) - --- | insert operator. -(|->) :: Ord key => (key,el) -> Map key el -> Map key el -(x,y) |-> fm = insertTree (x,y) fm - --- | insertMany operator. -(|->+) :: Ord key => [(key,el)] -> Map key el -> Map key el -[] |->+ fm = fm -((x,y):xs) |->+ fm = xs |->+ (insertTree (x,y) fm) - --- | union operator. -(<+>) :: Ord key => Map key el -> Map key el -> Map key el -(<+>) fm1 fm2 = xs |->+ fm2 - where xs = flatten fm1 diff --git a/src/GF/Data/Operations.hs b/src/GF/Data/Operations.hs deleted file mode 100644 index 1b2033d69..000000000 --- a/src/GF/Data/Operations.hs +++ /dev/null @@ -1,658 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Operations --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/11/11 16:12:41 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.22 $ --- --- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001 --- --- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL) ------------------------------------------------------------------------------ - -module GF.Data.Operations (-- * misc functions - ifNull, onSnd, - - -- * the Error monad - Err(..), err, maybeErr, testErr, errVal, errIn, derrIn, - performOps, repeatUntilErr, repeatUntil, okError, isNotError, - showBad, lookupErr, lookupErrMsg, lookupDefault, updateLookupList, - mapPairListM, mapPairsM, pairM, mapErr, mapErrN, foldErr, - (!?), errList, singleton, - - -- ** checking - checkUnique, titleIfNeeded, errMsg, errAndMsg, - - -- * a three-valued maybe type to express indirections - Perhaps(..), yes, may, nope, - mapP, - unifPerhaps, updatePerhaps, updatePerhapsHard, - - -- * binary search trees; now with FiniteMap - BinTree, emptyBinTree, isInBinTree, justLookupTree, - lookupTree, lookupTreeMany, lookupTreeManyAll, updateTree, - buildTree, filterBinTree, - sorted2tree, mapTree, mapMTree, tree2list, - - - -- * parsing - WParser, wParseResults, paragraphs, - - -- * printing - indent, (+++), (++-), (++++), (+++++), - prUpper, prReplicate, prTList, prQuotedString, prParenth, prCurly, - prBracket, prArgList, prSemicList, prCurlyList, restoreEscapes, - numberedParagraphs, prConjList, prIfEmpty, wrapLines, - - -- ** LaTeX code producing functions - dollar, mbox, ital, boldf, verbat, mkLatexFile, - begindocument, enddocument, - - -- * extra - sortByLongest, combinations, mkTextFile, initFilePath, - - -- * topological sorting with test of cyclicity - topoTest, topoSort, cyclesIn, - - -- * the generic fix point iterator - iterFix, - - -- * association lists - updateAssoc, removeAssoc, - - -- * chop into separator-separated parts - chunks, readIntArg, subSequences, - - -- * state monad with error; from Agda 6\/11\/2001 - STM(..), appSTM, stm, stmr, readSTM, updateSTM, writeSTM, done, - - -- * error monad class - ErrorMonad(..), checkAgain, checks, allChecks, doUntil - - ) where - -import Data.Char (isSpace, toUpper, isSpace, isDigit) -import Data.List (nub, sortBy, sort, deleteBy, nubBy) ---import Data.FiniteMap -import Control.Monad (liftM,liftM2, MonadPlus, mzero, mplus) - -import GF.Data.ErrM - -infixr 5 +++ -infixr 5 ++- -infixr 5 ++++ -infixr 5 +++++ -infixl 9 !? - -ifNull :: b -> ([a] -> b) -> [a] -> b -ifNull b f xs = if null xs then b else f xs - -onSnd :: (a -> b) -> (c,a) -> (c,b) -onSnd f (x, y) = (x, f y) - --- the Error monad - --- | analogue of @maybe@ -err :: (String -> b) -> (a -> b) -> Err a -> b -err d f e = case e of - Ok a -> f a - Bad s -> d s - --- | add msg s to @Maybe@ failures -maybeErr :: String -> Maybe a -> Err a -maybeErr s = maybe (Bad s) Ok - -testErr :: Bool -> String -> Err () -testErr cond msg = if cond then return () else Bad msg - -errVal :: a -> Err a -> a -errVal a = err (const a) id - -errIn :: String -> Err a -> Err a -errIn msg = err (\s -> Bad (s ++++ "OCCURRED IN" ++++ msg)) return - --- | used for extra error reports when developing GF -derrIn :: String -> Err a -> Err a -derrIn m = errIn m -- id - -performOps :: [a -> Err a] -> a -> Err a -performOps ops a = case ops of - f:fs -> f a >>= performOps fs - [] -> return a - -repeatUntilErr :: (a -> Bool) -> (a -> Err a) -> a -> Err a -repeatUntilErr cond f a = if cond a then return a else f a >>= repeatUntilErr cond f - -repeatUntil :: (a -> Bool) -> (a -> a) -> a -> a -repeatUntil cond f a = if cond a then a else repeatUntil cond f (f a) - -okError :: Err a -> a --- okError = err (error "no result Ok") id -okError = err (error . ("Bad result occurred" ++++)) id - -isNotError :: Err a -> Bool -isNotError = err (const False) (const True) - -showBad :: Show a => String -> a -> Err b -showBad s a = Bad (s +++ show a) - -lookupErr :: (Eq a,Show a) => a -> [(a,b)] -> Err b -lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs) - -lookupErrMsg :: (Eq a,Show a) => String -> a -> [(a,b)] -> Err b -lookupErrMsg m a abs = maybeErr (m +++ "gave unknown" +++ show a) (lookup a abs) - -lookupDefault :: Eq a => b -> a -> [(a,b)] -> b -lookupDefault d x l = maybe d id $ lookup x l - -updateLookupList :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] -updateLookupList ab abs = insert ab [] abs where - insert c cc [] = cc ++ [c] - insert (a,b) cc ((a',b'):cc') = if a == a' - then cc ++ [(a,b)] ++ cc' - else insert (a,b) (cc ++ [(a',b')]) cc' - -mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)] -mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys - -mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)] -mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys - -pairM :: Monad a => (b -> a c) -> (b,b) -> a (c,c) -pairM op (t1,t2) = liftM2 (,) (op t1) (op t2) - --- | like @mapM@, but continue instead of halting with 'Err' -mapErr :: (a -> Err b) -> [a] -> Err ([b], String) -mapErr f xs = Ok (ys, unlines ss) - where - (ys,ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) - fxs = map f xs - --- | alternative variant, peb 9\/6-04 -mapErrN :: Int -> (a -> Err b) -> [a] -> Err ([b], String) -mapErrN maxN f xs = Ok (ys, unlines (errHdr : ss2)) - where - (ys, ss) = ([y | Ok y <- fxs], [s | Bad s <- fxs]) - errHdr = show nss ++ " errors occured" ++ - if nss > maxN then ", showing the first " ++ show maxN else "" - ss2 = map ("* "++) $ take maxN ss - nss = length ss - fxs = map f xs - --- | like @foldM@, but also return the latest value if fails -foldErr :: (a -> b -> Err a) -> a -> [b] -> Err (a, Maybe String) -foldErr f s xs = case xs of - [] -> return (s,Nothing) - x:xx -> case f s x of - Ok v -> foldErr f v xx - Bad m -> return $ (s, Just m) - --- @!!@ with the error monad -(!?) :: [a] -> Int -> Err a -xs !? i = foldr (const . return) (Bad "too few elements in list") $ drop i xs - -errList :: Err [a] -> [a] -errList = errVal [] - -singleton :: a -> [a] -singleton = (:[]) - --- checking - -checkUnique :: (Show a, Eq a) => [a] -> [String] -checkUnique ss = ["overloaded" +++ show s | s <- nub overloads] where - overloads = filter overloaded ss - overloaded s = length (filter (==s) ss) > 1 - -titleIfNeeded :: a -> [a] -> [a] -titleIfNeeded a [] = [] -titleIfNeeded a as = a:as - -errMsg :: Err a -> [String] -errMsg (Bad m) = [m] -errMsg _ = [] - -errAndMsg :: Err a -> Err (a,[String]) -errAndMsg (Bad m) = Bad m -errAndMsg (Ok a) = return (a,[]) - --- | a three-valued maybe type to express indirections -data Perhaps a b = Yes a | May b | Nope deriving (Show,Read,Eq,Ord) - -yes :: a -> Perhaps a b -yes = Yes - -may :: b -> Perhaps a b -may = May - -nope :: Perhaps a b -nope = Nope - -mapP :: (a -> c) -> Perhaps a b -> Perhaps c b -mapP f p = case p of - Yes a -> Yes (f a) - May b -> May b - Nope -> Nope - --- | this is what happens when matching two values in the same module -unifPerhaps :: (Eq a, Eq b, Show a, Show b) => - Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -unifPerhaps p1 p2 = case (p1,p2) of - (Nope, _) -> return p2 - (_, Nope) -> return p1 - _ -> if p1==p2 then return p1 - else Bad ("update conflict between" ++++ show p1 ++++ show p2) - --- | this is what happens when updating a module extension -updatePerhaps :: (Eq a,Eq b, Show a, Show b) => - b -> Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -updatePerhaps old p1 p2 = case (p1,p2) of - (Yes a, Nope) -> return $ may old - (May older,Nope) -> return $ may older - (_, May a) -> Bad "strange indirection" - _ -> unifPerhaps p1 p2 - --- | here the value is copied instead of referred to; used for oper types -updatePerhapsHard :: (Eq a, Eq b, Show a, Show b) => b -> - Perhaps a b -> Perhaps a b -> Err (Perhaps a b) -updatePerhapsHard old p1 p2 = case (p1,p2) of - (Yes a, Nope) -> return $ yes a - (May older,Nope) -> return $ may older - (_, May a) -> Bad "strange indirection" - _ -> unifPerhaps p1 p2 - --- binary search trees ---- FiniteMap implementation is slower in crucial tests - -data BinTree a b = NT | BT (a,b) !(BinTree a b) !(BinTree a b) deriving (Show) --- type BinTree a b = FiniteMap a b - -emptyBinTree :: BinTree a b -emptyBinTree = NT --- emptyBinTree = emptyFM - -isInBinTree :: (Ord a) => a -> BinTree a b -> Bool -isInBinTree x = err (const False) (const True) . justLookupTree x --- isInBinTree = elemFM - -justLookupTree :: (Monad m,Ord a) => a -> BinTree a b -> m b -justLookupTree = lookupTree (const []) - -lookupTree :: (Monad m,Ord a) => (a -> String) -> a -> BinTree a b -> m b -lookupTree pr x tree = case tree of - NT -> fail ("no occurrence of element" +++ pr x) - BT (a,b) left right - | x < a -> lookupTree pr x left - | x > a -> lookupTree pr x right - | x == a -> return b ---lookupTree pr x tree = case lookupFM tree x of --- Just y -> return y --- _ -> fail ("no occurrence of element" +++ pr x) - -lookupTreeMany :: Ord a => (a -> String) -> [BinTree a b] -> a -> Err b -lookupTreeMany pr (t:ts) x = case lookupTree pr x t of - Ok v -> return v - _ -> lookupTreeMany pr ts x -lookupTreeMany pr [] x = Bad $ "failed to find" +++ pr x - -lookupTreeManyAll :: Ord a => (a -> String) -> [BinTree a b] -> a -> [b] -lookupTreeManyAll pr (t:ts) x = case lookupTree pr x t of - Ok v -> v : lookupTreeManyAll pr ts x - _ -> lookupTreeManyAll pr ts x -lookupTreeManyAll pr [] x = [] - --- | destructive update -updateTree :: (Ord a) => (a,b) -> BinTree a b -> BinTree a b --- updateTree (a,b) tr = addToFM tr a b -updateTree = updateTreeGen True - --- | destructive or not -updateTreeGen :: (Ord a) => Bool -> (a,b) -> BinTree a b -> BinTree a b -updateTreeGen destr z@(x,y) tree = case tree of - NT -> BT z NT NT - BT c@(a,b) left right - | x < a -> let left' = updateTree z left in BT c left' right - | x > a -> let right' = updateTree z right in BT c left right' - | otherwise -> if destr - then BT z left right -- removing the old value of a - else tree -- retaining the old value if one exists - -buildTree :: (Ord a) => [(a,b)] -> BinTree a b -buildTree = sorted2tree . sortBy fs where - fs (x,_) (y,_) - | x < y = LT - | x > y = GT - | True = EQ --- buildTree = listToFM - -sorted2tree :: Ord a => [(a,b)] -> BinTree a b -sorted2tree [] = NT -sorted2tree xs = BT x (sorted2tree t1) (sorted2tree t2) where - (t1,(x:t2)) = splitAt (length xs `div` 2) xs ---sorted2tree = listToFM - ---- dm less general than orig -mapTree :: ((a,b) -> (a,c)) -> BinTree a b -> BinTree a c -mapTree f NT = NT -mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right) ---mapTree f = mapFM (\k v -> snd (f (k,v))) - ---- fm less efficient than orig? -mapMTree :: (Ord a,Monad m) => ((a,b) -> m (a,c)) -> BinTree a b -> m (BinTree a c) -mapMTree f NT = return NT -mapMTree f (BT a left right) = do - a' <- f a - left' <- mapMTree f left - right' <- mapMTree f right - return $ BT a' left' right' ---mapMTree f t = liftM listToFM $ mapM f $ fmToList t - -filterBinTree :: Ord a => (a -> b -> Bool) -> BinTree a b -> BinTree a b --- filterFM f t -filterBinTree f = sorted2tree . filter (uncurry f) . tree2list - -tree2list :: BinTree a b -> [(a,b)] -- inorder -tree2list NT = [] -tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right ---tree2list = fmToList - --- parsing - -type WParser a b = [a] -> [(b,[a])] -- old Wadler style parser - -wParseResults :: WParser a b -> [a] -> [b] -wParseResults p aa = [b | (b,[]) <- p aa] - -paragraphs :: String -> [String] -paragraphs = map unlines . chop . lines where - chop [] = [] - chop ss = let (ps,rest) = break empty ss in ps : chop (dropWhile empty rest) - empty = all isSpace - --- printing - -indent :: Int -> String -> String -indent i s = replicate i ' ' ++ s - -(+++), (++-), (++++), (+++++) :: String -> String -> String -a +++ b = a ++ " " ++ b -a ++- "" = a -a ++- b = a +++ b -a ++++ b = a ++ "\n" ++ b -a +++++ b = a ++ "\n\n" ++ b - -prUpper :: String -> String -prUpper s = s1 ++ s2' where - (s1,s2) = span isSpace s - s2' = case s2 of - c:t -> toUpper c : t - _ -> s2 - -prReplicate :: Int -> String -> String -prReplicate n s = concat (replicate n s) - -prTList :: String -> [String] -> String -prTList t ss = case ss of - [] -> "" - [s] -> s - s:ss -> s ++ t ++ prTList t ss - -prQuotedString :: String -> String -prQuotedString x = "\"" ++ restoreEscapes x ++ "\"" - -prParenth :: String -> String -prParenth s = if s == "" then "" else "(" ++ s ++ ")" - -prCurly, prBracket :: String -> String -prCurly s = "{" ++ s ++ "}" -prBracket s = "[" ++ s ++ "]" - -prArgList, prSemicList, prCurlyList :: [String] -> String -prArgList = prParenth . prTList "," -prSemicList = prTList " ; " -prCurlyList = prCurly . prSemicList - -restoreEscapes :: String -> String -restoreEscapes s = - case s of - [] -> [] - '"' : t -> '\\' : '"' : restoreEscapes t - '\\': t -> '\\' : '\\' : restoreEscapes t - c : t -> c : restoreEscapes t - -numberedParagraphs :: [[String]] -> [String] -numberedParagraphs t = case t of - [] -> [] - p:[] -> p - _ -> concat [(show n ++ ".") : s | (n,s) <- zip [1..] t] - -prConjList :: String -> [String] -> String -prConjList c [] = "" -prConjList c [s] = s -prConjList c [s,t] = s +++ c +++ t -prConjList c (s:tt) = s ++ "," +++ prConjList c tt - -prIfEmpty :: String -> String -> String -> String -> String -prIfEmpty em _ _ [] = em -prIfEmpty em nem1 nem2 s = nem1 ++ s ++ nem2 - --- | Thomas Hallgren's wrap lines -wrapLines :: Int -> String -> String -wrapLines n "" = "" -wrapLines n s@(c:cs) = - if isSpace c - then c:wrapLines (n+1) cs - else case lex s of - [(w,rest)] -> if n'>=76 - then '\n':w++wrapLines l rest - else w++wrapLines n' rest - where n' = n+l - l = length w - _ -> s -- give up!! - ---- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id - --- LaTeX code producing functions -dollar, mbox, ital, boldf, verbat :: String -> String -dollar s = '$' : s ++ "$" -mbox s = "\\mbox{" ++ s ++ "}" -ital s = "{\\em" +++ s ++ "}" -boldf s = "{\\bf" +++ s ++ "}" -verbat s = "\\verbat!" ++ s ++ "!" - -mkLatexFile :: String -> String -mkLatexFile s = begindocument +++++ s +++++ enddocument - -begindocument, enddocument :: String -begindocument = - "\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02 - "\\setlength{\\parskip}{2mm}" ++++ - "\\setlength{\\parindent}{0mm}" ++++ - "\\setlength{\\oddsidemargin}{0mm}" ++++ - ("\\setlength{\\evensidemargin}{"++"-2mm}") ++++ -- peb 27/5-04: to prevent hugs-mode - ("\\setlength{\\topmargin}{"++"-8mm}") ++++ -- from treating the rest as comments - "\\setlength{\\textheight}{240mm}" ++++ - "\\setlength{\\textwidth}{158mm}" ++++ - "\\begin{document}\n" -enddocument = - "\n\\end{document}\n" - - -sortByLongest :: [[a]] -> [[a]] -sortByLongest = sortBy longer where - longer x y - | x' > y' = LT - | x' < y' = GT - | True = EQ - where - x' = length x - y' = length y - --- | 'combinations' is the same as @sequence@!!! --- peb 30\/5-04 -combinations :: [[a]] -> [[a]] -combinations t = case t of - [] -> [[]] - aa:uu -> [a:u | a <- aa, u <- combinations uu] - - -mkTextFile :: String -> IO () -mkTextFile name = do - s <- readFile name - let s' = prelude name ++ "\n\n" ++ heading name ++ "\n" ++ object s - writeFile (name ++ ".hs") s' - where - prelude name = "module " ++ name ++ " where" - heading name = "txt" ++ name ++ " =" - object s = mk s ++ " \"\"" - mk s = unlines [" \"" ++ escs line ++ "\" ++ \"\\n\" ++" | line <- lines s] - escs s = case s of - c:cs | elem c "\"\\" -> '\\' : c : escs cs - c:cs -> c : escs cs - _ -> s - -initFilePath :: FilePath -> FilePath -initFilePath f = reverse (dropWhile (/='/') (reverse f)) - --- | topological sorting with test of cyclicity -topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]] -topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) - where - g' = topoSort g - -cyclesIn :: Eq a => [(a,[a])] -> [[a]] -cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where - immediate = [[y,x] | (x,xs) <- deps, y <- xs] - findDep chains = [y:x:chain | - x:chain <- chains, (x',xs) <- deps, x' == x, y <- xs, - notElem y (init chain)] - - clean = map remdup - nubb = nubBy (\x y -> y == reverse x) - filt = filter (\xs -> last xs == head xs) - remdup (x:xs) = x : remdup xs' where xs' = dropWhile (==x) xs - remdup [] = [] - - --- | topological sorting -topoSort :: Eq a => [(a,[a])] -> [a] -topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where - tsort _ [] r = r - tsort k (ffs@(f,fs) : cs) r - | elem f r = tsort k cs r - | k > lx = r - | otherwise = tsort (k+1) cs (f : tsort (k+1) (info fs) r) - info hs = [(f,fs) | (f,fs) <- g, elem f hs] - inDeg f = length [t | (h,hs) <- g, t <- hs, t == f] - lx = length g - --- | the generic fix point iterator -iterFix :: Eq a => ([a] -> [a]) -> [a] -> [a] -iterFix more start = iter start start - where - iter old new = if (null new') - then old - else iter (new' ++ old) new' - where - new' = filter (`notElem` old) (more new) - --- association lists - -updateAssoc :: Eq a => (a,b) -> [(a,b)] -> [(a,b)] -updateAssoc ab@(a,b) as = case as of - (x,y): xs | x == a -> (a,b):xs - xy : xs -> xy : updateAssoc ab xs - [] -> [ab] - -removeAssoc :: Eq a => a -> [(a,b)] -> [(a,b)] -removeAssoc a = filter ((/=a) . fst) - --- | chop into separator-separated parts -chunks :: Eq a => a -> [a] -> [[a]] -chunks sep ws = case span (/= sep) ws of - (a,_:b) -> a : bs where bs = chunks sep b - (a, []) -> if null a then [] else [a] - -readIntArg :: String -> Int -readIntArg n = if (not (null n) && all isDigit n) then read n else 0 - - --- state monad with error; from Agda 6/11/2001 - -newtype STM s a = STM (s -> Err (a,s)) - -appSTM :: STM s a -> s -> Err (a,s) -appSTM (STM f) s = f s - -stm :: (s -> Err (a,s)) -> STM s a -stm = STM - -stmr :: (s -> (a,s)) -> STM s a -stmr f = stm (\s -> return (f s)) - -instance Monad (STM s) where - return a = STM (\s -> return (a,s)) - STM c >>= f = STM (\s -> do - (x,s') <- c s - let STM f' = f x - f' s') - -readSTM :: STM s s -readSTM = stmr (\s -> (s,s)) - -updateSTM :: (s -> s) -> STM s () -updateSTM f = stmr (\s -> ((),f s)) - -writeSTM :: s -> STM s () -writeSTM s = stmr (const ((),s)) - -done :: Monad m => m () -done = return () - -class Monad m => ErrorMonad m where - raise :: String -> m a - handle :: m a -> (String -> m a) -> m a - handle_ :: m a -> m a -> m a - handle_ a b = a `handle` (\_ -> b) - -instance ErrorMonad Err where - raise = Bad - handle a@(Ok _) _ = a - handle (Bad i) f = f i - -instance ErrorMonad (STM s) where - raise msg = STM (\s -> raise msg) - handle (STM f) g = STM (\s -> (f s) - `handle` (\e -> let STM g' = (g e) in - g' s)) - --- | if the first check fails try another one -checkAgain :: ErrorMonad m => m a -> m a -> m a -checkAgain c1 c2 = handle_ c1 c2 - -checks :: ErrorMonad m => [m a] -> m a -checks [] = raise "no chance to pass" -checks cs = foldr1 checkAgain cs - -allChecks :: ErrorMonad m => [m a] -> m [a] -allChecks ms = case ms of - (m: ms) -> let rs = allChecks ms in handle_ (liftM2 (:) m rs) rs - _ -> return [] - -doUntil :: ErrorMonad m => (a -> Bool) -> [m a] -> m a -doUntil cond ms = case ms of - a:as -> do - v <- a - if cond v then return v else doUntil cond as - _ -> raise "no result" - --- subsequences sorted from longest to shortest ; their number is 2^n -subSequences :: [a] -> [[a]] -subSequences = sortBy (\x y -> compare (length y) (length x)) . subs where - subs xs = case xs of - [] -> [[]] - x:xs -> let xss = subs xs in [x:y | y <- xss] ++ xss diff --git a/src/GF/Data/OrdMap2.hs b/src/GF/Data/OrdMap2.hs deleted file mode 100644 index 3590f0584..000000000 --- a/src/GF/Data/OrdMap2.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : OrdMap2 --- Maintainer : Peter Ljunglöf --- Stability : Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:05 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- The class of finite maps, as described in --- \"Pure Functional Parsing\", section 2.2.2 --- and an example implementation, --- derived from appendix A.2 --- --- /OBSOLETE/! this is only used in module "ChartParser" ------------------------------------------------------------------------------ - -module GF.Data.OrdMap2 (OrdMap(..), Map) where - -import Data.List (intersperse) - - --------------------------------------------------- --- the class of ordered finite maps - -class OrdMap m where - emptyMap :: Ord s => m s a - (|->) :: Ord s => s -> a -> m s a - isEmptyMap :: Ord s => m s a -> Bool - (?) :: Ord s => m s a -> s -> Maybe a - lookupWith :: Ord s => a -> m s a -> s -> a - mergeWith :: Ord s => (a -> a -> a) -> m s a -> m s a -> m s a - unionMapWith :: Ord s => (a -> a -> a) -> [m s a] -> m s a - makeMapWith :: Ord s => (a -> a -> a) -> [(s,a)] -> m s a - assocs :: Ord s => m s a -> [(s,a)] - ordMap :: Ord s => [(s,a)] -> m s a - mapMap :: Ord s => (a -> b) -> m s a -> m s b - - lookupWith z m s = case m ? s of - Just a -> a - Nothing -> z - - unionMapWith join = union - where union [] = emptyMap - union [xs] = xs - union xyss = mergeWith join (union xss) (union yss) - where (xss, yss) = split xyss - split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) - split xs = (xs, []) - - --------------------------------------------------- --- finite maps as ordered associaiton lists, --- paired with binary search trees - -data Map s a = Map [(s,a)] (TreeMap s a) - -instance (Eq s, Eq a) => Eq (Map s a) where - Map xs _ == Map ys _ = xs == ys - -instance (Show s, Show a) => Show (Map s a) where - show (Map ass _) = "{" ++ concat (intersperse "," (map show' ass)) ++ "}" - where show' (s,a) = show s ++ "|->" ++ show a - -instance OrdMap Map where - emptyMap = Map [] (makeTree []) - s |-> a = Map [(s,a)] (makeTree [(s,a)]) - - isEmptyMap (Map ass _) = null ass - - Map _ tree ? s = lookupTree s tree - - mergeWith join (Map xss _) (Map yss _) = Map xyss (makeTree xyss) - where xyss = merge xss yss - merge [] yss = yss - merge xss [] = xss - merge xss@(x@(s,x'):xss') yss@(y@(t,y'):yss') - = case compare s t of - LT -> x : merge xss' yss - GT -> y : merge xss yss' - EQ -> (s, join x' y') : merge xss' yss' - - makeMapWith join [] = emptyMap - makeMapWith join [(s,a)] = s |-> a - makeMapWith join xyss = mergeWith join (makeMapWith join xss) (makeMapWith join yss) - where (xss, yss) = split xyss - split (x:y:xys) = let (xs, ys) = split xys in (x:xs, y:ys) - split xs = (xs, []) - - assocs (Map xss _) = xss - ordMap xss = Map xss (makeTree xss) - - mapMap f (Map ass atree) = Map [ (s,f a) | (s,a) <- ass ] (mapTree f atree) - - --------------------------------------------------- --- binary search trees --- for logarithmic lookup time - -data TreeMap s a = Nil | Node (TreeMap s a) s a (TreeMap s a) - -makeTree ass = tree - where - (tree,[]) = sl2bst (length ass) ass - sl2bst 0 ass = (Nil, ass) - sl2bst 1 ((s,a):ass) = (Node Nil s a Nil, ass) - sl2bst n ass = (Node ltree s a rtree, css) - where llen = (n-1) `div` 2 - rlen = n - 1 - llen - (ltree, (s,a):bss) = sl2bst llen ass - (rtree, css) = sl2bst rlen bss - -lookupTree s Nil = Nothing -lookupTree s (Node left s' a right) - = case compare s s' of - LT -> lookupTree s left - GT -> lookupTree s right - EQ -> Just a - -mapTree f Nil = Nil -mapTree f (Node left s a right) = Node (mapTree f left) s (f a) (mapTree f right) - - - - diff --git a/src/GF/Data/OrdSet.hs b/src/GF/Data/OrdSet.hs deleted file mode 100644 index 34eb0705d..000000000 --- a/src/GF/Data/OrdSet.hs +++ /dev/null @@ -1,120 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : OrdSet --- Maintainer : Peter Ljunglöf --- Stability : Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:06 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- The class of ordered sets, as described in --- \"Pure Functional Parsing\", section 2.2.1, --- and an example implementation --- derived from appendix A.1 --- --- /OBSOLETE/! this is only used in module "ChartParser" ------------------------------------------------------------------------------ - -module GF.Data.OrdSet (OrdSet(..), Set) where - -import Data.List (intersperse) - - --------------------------------------------------- --- the class of ordered sets - -class OrdSet m where - emptySet :: Ord a => m a - unitSet :: Ord a => a -> m a - isEmpty :: Ord a => m a -> Bool - elemSet :: Ord a => a -> m a -> Bool - (<++>) :: Ord a => m a -> m a -> m a - (<\\>) :: Ord a => m a -> m a -> m a - plusMinus :: Ord a => m a -> m a -> (m a, m a) - union :: Ord a => [m a] -> m a - makeSet :: Ord a => [a] -> m a - elems :: Ord a => m a -> [a] - ordSet :: Ord a => [a] -> m a - limit :: Ord a => (a -> m a) -> m a -> m a - - xs <++> ys = fst (plusMinus xs ys) - xs <\\> ys = snd (plusMinus xs ys) - plusMinus xs ys = (xs <++> ys, xs <\\> ys) - - union [] = emptySet - union [xs] = xs - union xyss = union xss <++> union yss - where (xss, yss) = split xyss - split (x:y:xyss) = let (xs, ys) = split xyss in (x:xs, y:ys) - split xs = (xs, []) - - makeSet xs = union (map unitSet xs) - - limit more start = limit' (start, start) - where limit' (old, new) - | isEmpty new' = old - | otherwise = limit' (plusMinus new' old) - where new' = union (map more (elems new)) - - --------------------------------------------------- --- sets as ordered lists, --- paired with a binary tree - -data Set a = Set [a] (TreeSet a) - -instance Eq a => Eq (Set a) where - Set xs _ == Set ys _ = xs == ys - -instance Ord a => Ord (Set a) where - compare (Set xs _) (Set ys _) = compare xs ys - -instance Show a => Show (Set a) where - show (Set xs _) = "{" ++ concat (intersperse "," (map show xs)) ++ "}" - -instance OrdSet Set where - emptySet = Set [] (makeTree []) - unitSet a = Set [a] (makeTree [a]) - - isEmpty (Set xs _) = null xs - elemSet a (Set _ xt) = elemTree a xt - - plusMinus (Set xs _) (Set ys _) = (Set ps (makeTree ps), Set ms (makeTree ms)) - where (ps, ms) = plm xs ys - plm [] ys = (ys, []) - plm xs [] = (xs, xs) - plm xs@(x:xs') ys@(y:ys') = case compare x y of - LT -> let (ps, ms) = plm xs' ys in (x:ps, x:ms) - GT -> let (ps, ms) = plm xs ys' in (y:ps, ms) - EQ -> let (ps, ms) = plm xs' ys' in (x:ps, ms) - - elems (Set xs _) = xs - ordSet xs = Set xs (makeTree xs) - - --------------------------------------------------- --- binary search trees --- for logarithmic lookup time - -data TreeSet a = Nil | Node (TreeSet a) a (TreeSet a) - -makeTree xs = tree - where (tree,[]) = sl2bst (length xs) xs - sl2bst 0 xs = (Nil, xs) - sl2bst 1 (a:xs) = (Node Nil a Nil, xs) - sl2bst n xs = (Node ltree a rtree, zs) - where llen = (n-1) `div` 2 - rlen = n - 1 - llen - (ltree, a:ys) = sl2bst llen xs - (rtree, zs) = sl2bst rlen ys - -elemTree a Nil = False -elemTree a (Node ltree x rtree) - = case compare a x of - LT -> elemTree a ltree - GT -> elemTree a rtree - EQ -> True - - diff --git a/src/GF/Data/Parsers.hs b/src/GF/Data/Parsers.hs deleted file mode 100644 index f9bf02598..000000000 --- a/src/GF/Data/Parsers.hs +++ /dev/null @@ -1,196 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Parsers --- Maintainer : Aarne Ranta --- Stability : Almost Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:06 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- some parser combinators a la Wadler and Hutton. --- no longer used in many places in GF --- (only used in module "EBNF") ------------------------------------------------------------------------------ - -module GF.Data.Parsers (-- * Main types and functions - Parser, parseResults, parseResultErr, - -- * Basic combinators (on any token type) - (...), (.>.), (|||), (+||), literal, (***), - succeed, fails, (+..), (..+), (<<<), (|>), - many, some, longestOfMany, longestOfSome, - closure, - -- * Specific combinators (for @Char@ token type) - pJunk, pJ, jL, pTList, pTJList, pElem, - (....), item, satisfy, literals, lits, - pParenth, pCommaList, pOptCommaList, - pArgList, pArgList2, - pIdent, pLetter, pDigit, pLetters, - pAlphanum, pAlphaPlusChar, - pQuotedString, pIntc - ) where - -import GF.Data.Operations -import Data.Char -import Data.List - - -infixr 2 |||, +|| -infixr 3 *** -infixr 5 .>. -infixr 5 ... -infixr 5 .... -infixr 5 +.. -infixr 5 ..+ -infixr 6 |> -infixr 3 <<< - - -type Parser a b = [a] -> [(b,[a])] - -parseResults :: Parser a b -> [a] -> [b] -parseResults p s = [x | (x,r) <- p s, null r] - -parseResultErr :: Show a => Parser a b -> [a] -> Err b -parseResultErr p s = case parseResults p s of - [x] -> return x - [] -> case - maximumBy (\x y -> compare (length y) (length x)) (s:[r | (_,r) <- p s]) of - r -> Bad $ "\nno parse; reached" ++++ take 300 (show r) - _ -> Bad "ambiguous" - -(...) :: Parser a b -> Parser a c -> Parser a (b,c) -(p ... q) s = [((x,y),r) | (x,t) <- p s, (y,r) <- q t] - -(.>.) :: Parser a b -> (b -> Parser a c) -> Parser a c -(p .>. f) s = [(c,r) | (x,t) <- p s, (c,r) <- f x t] - -(|||) :: Parser a b -> Parser a b -> Parser a b -(p ||| q) s = p s ++ q s - -(+||) :: Parser a b -> Parser a b -> Parser a b -p1 +|| p2 = take 1 . (p1 ||| p2) - -literal :: (Eq a) => a -> Parser a a -literal x (c:cs) = [(x,cs) | x == c] -literal _ _ = [] - -(***) :: Parser a b -> (b -> c) -> Parser a c -(p *** f) s = [(f x,r) | (x,r) <- p s] - -succeed :: b -> Parser a b -succeed v s = [(v,s)] - -fails :: Parser a b -fails s = [] - -(+..) :: Parser a b -> Parser a c -> Parser a c -p1 +.. p2 = p1 ... p2 *** snd - -(..+) :: Parser a b -> Parser a c -> Parser a b -p1 ..+ p2 = p1 ... p2 *** fst - -(<<<) :: Parser a b -> c -> Parser a c -- return -p <<< v = p *** (\x -> v) - -(|>) :: Parser a b -> (b -> Bool) -> Parser a b -p |> b = p .>. (\x -> if b x then succeed x else fails) - -many :: Parser a b -> Parser a [b] -many p = (p ... many p *** uncurry (:)) +|| succeed [] - -some :: Parser a b -> Parser a [b] -some p = (p ... many p) *** uncurry (:) - -longestOfMany :: Parser a b -> Parser a [b] -longestOfMany p = p .>. (\x -> longestOfMany p *** (x:)) +|| succeed [] - -closure :: (b -> Parser a b) -> (b -> Parser a b) -closure p v = p v .>. closure p ||| succeed v - -pJunk :: Parser Char String -pJunk = longestOfMany (satisfy (\x -> elem x "\n\t ")) - -pJ :: Parser Char a -> Parser Char a -pJ p = pJunk +.. p ..+ pJunk - -pTList :: String -> Parser Char a -> Parser Char [a] -pTList t p = p .... many (jL t +.. p) *** (\ (x,y) -> x:y) -- mod. AR 5/1/1999 - -pTJList :: String -> String -> Parser Char a -> Parser Char [a] -pTJList t1 t2 p = p .... many (literals t1 +.. jL t2 +.. p) *** (uncurry (:)) - -pElem :: [String] -> Parser Char String -pElem l = foldr (+||) fails (map literals l) - -(....) :: Parser Char b -> Parser Char c -> Parser Char (b,c) -p1 .... p2 = p1 ... pJunk +.. p2 - -item :: Parser a a -item (c:cs) = [(c,cs)] -item [] = [] - -satisfy :: (a -> Bool) -> Parser a a -satisfy b = item |> b - -literals :: (Eq a,Show a) => [a] -> Parser a [a] -literals l = case l of - [] -> succeed [] - a:l -> literal a ... literals l *** (\ (x,y) -> x:y) - -lits :: (Eq a,Show a) => [a] -> Parser a [a] -lits ts = literals ts - -jL :: String -> Parser Char String -jL = pJ . lits - -pParenth :: Parser Char a -> Parser Char a -pParenth p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')' - --- | p,...,p -pCommaList :: Parser Char a -> Parser Char [a] -pCommaList p = pTList "," (pJ p) - --- | the same or nothing -pOptCommaList :: Parser Char a -> Parser Char [a] -pOptCommaList p = pCommaList p ||| succeed [] - --- | (p,...,p), poss. empty -pArgList :: Parser Char a -> Parser Char [a] -pArgList p = pParenth (pCommaList p) ||| succeed [] - --- | min. 2 args -pArgList2 :: Parser Char a -> Parser Char [a] -pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) - -longestOfSome :: Parser a b -> Parser a [b] -longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y) - -pIdent :: Parser Char String -pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:) - where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\'' - -pLetter, pDigit :: Parser Char Char -pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++ - ['\192' .. '\255'])) -- no such in Char -pDigit = satisfy isDigit - -pLetters :: Parser Char String -pLetters = longestOfSome pLetter - -pAlphanum, pAlphaPlusChar :: Parser Char Char -pAlphanum = pDigit ||| pLetter -pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'") - -pQuotedString :: Parser Char String -pQuotedString = literal '"' +.. pEndQuoted where - pEndQuoted = - literal '"' *** (const []) - +|| (literal '\\' +.. item .>. \ c -> pEndQuoted *** (c:)) - +|| item .>. \ c -> pEndQuoted *** (c:) - -pIntc :: Parser Char Int -pIntc = some (satisfy numb) *** read - where numb x = elem x ['0'..'9'] - diff --git a/src/GF/Data/RedBlack.hs b/src/GF/Data/RedBlack.hs deleted file mode 100644 index fd70dba63..000000000 --- a/src/GF/Data/RedBlack.hs +++ /dev/null @@ -1,64 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : RedBlack --- Maintainer : Markus Forsberg --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:07 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Modified version of Osanaki's implementation. ------------------------------------------------------------------------------ - -module GF.Data.RedBlack ( - emptyTree, - isEmpty, - Tree, - lookupTree, - insertTree, - flatten - ) where - -data Color = R | B - deriving (Show,Read) - -data Tree key el = E | T Color (Tree key el) (key,el) (Tree key el) - deriving (Show,Read) - -balance :: Color -> Tree a b -> (a,b) -> Tree a b -> Tree a b -balance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d) -balance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) -balance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d) -balance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) -balance color a x b = T color a x b - -emptyTree :: Tree key el -emptyTree = E - -isEmpty :: Tree key el -> Bool -isEmpty (E) = True -isEmpty _ = False - -lookupTree :: Ord a => a -> Tree a b -> Maybe b -lookupTree _ E = Nothing -lookupTree x (T _ a (y,z) b) - | x < y = lookupTree x a - | x > y = lookupTree x b - | otherwise = return z - -insertTree :: Ord a => (a,b) -> Tree a b -> Tree a b -insertTree (key,el) tree = T B a y b - where - T _ a y b = ins tree - ins E = T R E (key,el) E - ins (T color a y@(key',el') b) - | key < key' = balance color (ins a) y b - | key > key' = balance color a y (ins b) - | otherwise = T color a (key',el) b - -flatten :: Tree a b -> [(a,b)] -flatten E = [] -flatten (T _ left (key,e) right) - = (flatten left) ++ ((key,e):(flatten right)) diff --git a/src/GF/Data/RedBlackSet.hs b/src/GF/Data/RedBlackSet.hs deleted file mode 100644 index 8a1b8a743..000000000 --- a/src/GF/Data/RedBlackSet.hs +++ /dev/null @@ -1,150 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : RedBlackSet --- Maintainer : Peter Ljunglöf --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/03/21 14:17:39 $ --- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ --- --- Modified version of Okasaki's red-black trees --- incorporating sets and set-valued maps ----------------------------------------------------------------------- - -module GF.Data.RedBlackSet ( -- * Red-black sets - RedBlackSet, - rbEmpty, - rbList, - rbElem, - rbLookup, - rbInsert, - rbMap, - rbOrdMap, - -- * Red-black finite maps - RedBlackMap, - rbmEmpty, - rbmList, - rbmElem, - rbmLookup, - rbmInsert, - rbmOrdMap - ) where - --------------------------------------------------------------------------------- --- sets - -data Color = R | B deriving (Eq, Show) -data RedBlackSet a = E | T Color (RedBlackSet a) a (RedBlackSet a) - deriving (Eq, Show) - -rbBalance B (T R (T R a x b) y c) z d = T R (T B a x b) y (T B c z d) -rbBalance B (T R a x (T R b y c)) z d = T R (T B a x b) y (T B c z d) -rbBalance B a x (T R (T R b y c) z d) = T R (T B a x b) y (T B c z d) -rbBalance B a x (T R b y (T R c z d)) = T R (T B a x b) y (T B c z d) -rbBalance color a x b = T color a x b - -rbBlack (T _ a x b) = T B a x b - --- | the empty set -rbEmpty :: RedBlackSet a -rbEmpty = E - --- | the elements of a set as a sorted list -rbList :: RedBlackSet a -> [a] -rbList tree = rbl tree [] - where rbl E = id - rbl (T _ left a right) = rbl right . (a:) . rbl left - --- | checking for containment -rbElem :: Ord a => a -> RedBlackSet a -> Bool -rbElem _ E = False -rbElem a (T _ left a' right) - = case compare a a' of - LT -> rbElem a left - GT -> rbElem a right - EQ -> True - --- | looking up a key in a set of keys and values -rbLookup :: Ord k => k -> RedBlackSet (k, a) -> Maybe a -rbLookup _ E = Nothing -rbLookup a (T _ left (a',b) right) - = case compare a a' of - LT -> rbLookup a left - GT -> rbLookup a right - EQ -> Just b - --- | inserting a new element. --- returns 'Nothing' if the element is already contained -rbInsert :: Ord a => a -> RedBlackSet a -> Maybe (RedBlackSet a) -rbInsert value tree = fmap rbBlack (rbins tree) - where rbins E = Just (T R E value E) - rbins (T color left value' right) - = case compare value value' of - LT -> do left' <- rbins left - return (rbBalance color left' value' right) - GT -> do right' <- rbins right - return (rbBalance color left value' right') - EQ -> Nothing - --- | mapping each value of a key-value set -rbMap :: (a -> b) -> RedBlackSet (k, a) -> RedBlackSet (k, b) -rbMap f E = E -rbMap f (T color left (key, value) right) - = T color (rbMap f left) (key, f value) (rbMap f right) - --- | mapping each element to another type. --- /observe/ that the mapping function needs to preserve --- the order between objects -rbOrdMap :: (a -> b) -> RedBlackSet a -> RedBlackSet b -rbOrdMap f E = E -rbOrdMap f (T color left value right) - = T color (rbOrdMap f left) (f value) (rbOrdMap f right) - ----------------------------------------------------------------------- --- finite maps - -type RedBlackMap k a = RedBlackSet (k, RedBlackSet a) - --- | the empty map -rbmEmpty :: RedBlackMap k a -rbmEmpty = E - --- | converting a map to a key-value list, sorted on the keys, --- and for each key, a sorted list of values -rbmList :: RedBlackMap k a -> [(k, [a])] -rbmList tree = [ (k, rbList sub) | (k, sub) <- rbList tree ] - --- | checking whether a key-value pair is contained in the map -rbmElem :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Bool -rbmElem key value = maybe False (rbElem value) . rbLookup key - --- | looking up a key, returning a (sorted) list of all matching values -rbmLookup :: Ord k => k -> RedBlackMap k a -> [a] -rbmLookup key = maybe [] rbList . rbLookup key - --- | inserting a key-value pair. --- returns 'Nothing' if the pair is already contained in the map -rbmInsert :: (Ord k, Ord a) => k -> a -> RedBlackMap k a -> Maybe (RedBlackMap k a) -rbmInsert key value tree = fmap rbBlack (rbins tree) - where rbins E = Just (T R E (key, T B E value E) E) - rbins (T color left item@(key', vtree) right) - = case compare key key' of - LT -> do left' <- rbins left - return (rbBalance color left' item right) - GT -> do right' <- rbins right - return (rbBalance color left item right') - EQ -> do vtree' <- rbInsert value vtree - return (T color left (key', vtree') right) - --- | mapping each value to another type. --- /observe/ that the mapping function needs to preserve --- order between objects -rbmOrdMap :: (a -> b) -> RedBlackMap k a -> RedBlackMap k b -rbmOrdMap f E = E -rbmOrdMap f (T color left (key, tree) right) - = T color (rbmOrdMap f left) (key, rbOrdMap f tree) (rbmOrdMap f right) - - - diff --git a/src/GF/Data/SharedString.hs b/src/GF/Data/SharedString.hs deleted file mode 100644 index 9d037b512..000000000 --- a/src/GF/Data/SharedString.hs +++ /dev/null @@ -1,19 +0,0 @@ - -module GF.Data.SharedString (shareString) where - -import Data.HashTable as H -import System.IO.Unsafe (unsafePerformIO) - -{-# NOINLINE stringPool #-} -stringPool :: HashTable String String -stringPool = unsafePerformIO $ new (==) hashString - -{-# NOINLINE shareString #-} -shareString :: String -> String -shareString s = unsafePerformIO $ do - mv <- H.lookup stringPool s - case mv of - Just s' -> return s' - Nothing -> do - H.insert stringPool s s - return s diff --git a/src/GF/Data/SortedList.hs b/src/GF/Data/SortedList.hs deleted file mode 100644 index d77ff68d4..000000000 --- a/src/GF/Data/SortedList.hs +++ /dev/null @@ -1,127 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : Peter Ljunglöf --- Stability : stable --- Portability : portable --- --- > CVS $Date: 2005/04/21 16:22:08 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.3 $ --- --- Sets as sorted lists --- --- * /O(n)/ union, difference and intersection --- --- * /O(n log n)/ creating a set from a list (=sorting) --- --- * /O(n^2)/ fixed point iteration ------------------------------------------------------------------------------ - -module GF.Data.SortedList - ( -- * type declarations - SList, SMap, - -- * set operations - nubsort, union, - (<++>), (<\\>), (<**>), - limit, - hasCommonElements, subset, - -- * map operations - groupPairs, groupUnion, - unionMap, mergeMap - ) where - -import Data.List (groupBy) -import GF.Data.Utilities (split, foldMerge) - --- | The list must be sorted and contain no duplicates. -type SList a = [a] - --- | A sorted map also has unique keys, --- i.e. 'map fst m :: SList a', if 'm :: SMap a b' -type SMap a b = SList (a, b) - --- | Group a set of key-value pairs into a sorted map -groupPairs :: Ord a => SList (a, b) -> SMap a (SList b) -groupPairs = map mapFst . groupBy eqFst - where mapFst as = (fst (head as), map snd as) - eqFst a b = fst a == fst b - --- | Group a set of key-(sets-of-values) pairs into a sorted map -groupUnion :: (Ord a, Ord b) => SList (a, SList b) -> SMap a (SList b) -groupUnion = map unionSnd . groupPairs - where unionSnd (a, bs) = (a, union bs) - --- | True is the two sets has common elements -hasCommonElements :: Ord a => SList a -> SList a -> Bool -hasCommonElements as bs = not (null (as <**> bs)) - --- | True if the first argument is a subset of the second argument -subset :: Ord a => SList a -> SList a -> Bool -xs `subset` ys = null (xs <\\> ys) - --- | Create a set from any list. --- This function can also be used as an alternative to @nub@ in @List.hs@ -nubsort :: Ord a => [a] -> SList a -nubsort = union . map return - --- | the union of a list of sorted maps -unionMap :: Ord a => (b -> b -> b) - -> [SMap a b] -> SMap a b -unionMap plus = foldMerge (mergeMap plus) [] - --- | merging two sorted maps -mergeMap :: Ord a => (b -> b -> b) - -> SMap a b -> SMap a b -> SMap a b -mergeMap plus [] abs = abs -mergeMap plus abs [] = abs -mergeMap plus abs@(ab@(a,bs):abs') cds@(cd@(c,ds):cds') - = case compare a c of - EQ -> (a, plus bs ds) : mergeMap plus abs' cds' - LT -> ab : mergeMap plus abs' cds - GT -> cd : mergeMap plus abs cds' - --- | The union of a list of sets -union :: Ord a => [SList a] -> SList a -union = foldMerge (<++>) [] - --- | The union of two sets -(<++>) :: Ord a => SList a -> SList a -> SList a -[] <++> bs = bs -as <++> [] = as -as@(a:as') <++> bs@(b:bs') = case compare a b of - LT -> a : (as' <++> bs) - GT -> b : (as <++> bs') - EQ -> a : (as' <++> bs') - --- | The difference of two sets -(<\\>) :: Ord a => SList a -> SList a -> SList a -[] <\\> bs = [] -as <\\> [] = as -as@(a:as') <\\> bs@(b:bs') = case compare a b of - LT -> a : (as' <\\> bs) - GT -> (as <\\> bs') - EQ -> (as' <\\> bs') - --- | The intersection of two sets -(<**>) :: Ord a => SList a -> SList a -> SList a -[] <**> bs = [] -as <**> [] = [] -as@(a:as') <**> bs@(b:bs') = case compare a b of - LT -> (as' <**> bs) - GT -> (as <**> bs') - EQ -> a : (as' <**> bs') - --- | A fixed point iteration -limit :: Ord a => (a -> SList a) -- ^ The iterator function - -> SList a -- ^ The initial set - -> SList a -- ^ The result of the iteration -limit more start = limit' start start - where limit' chart agenda | null new' = chart - | otherwise = limit' (chart <++> new') new' - where new = union (map more agenda) - new'= new <\\> chart - - - - - diff --git a/src/GF/Data/Str.hs b/src/GF/Data/Str.hs deleted file mode 100644 index 6f65764c7..000000000 --- a/src/GF/Data/Str.hs +++ /dev/null @@ -1,134 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Str --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/04/21 16:22:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.8 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Str ( - Str (..), Tok (..), --- constructors needed in PrGrammar - str2strings, str2allStrings, str, sstr, sstrV, - isZeroTok, prStr, plusStr, glueStr, - strTok, - allItems -) where - -import GF.Data.Operations -import Data.List (isPrefixOf, isSuffixOf, intersperse) - --- | abstract token list type. AR 2001, revised and simplified 20\/4\/2003 -newtype Str = Str [Tok] deriving (Read, Show, Eq, Ord) - --- | notice that having both pre and post would leave to inconsistent situations: --- --- > pre {"x" ; "y" / "a"} ++ post {"b" ; "a" / "x"} --- --- always violates a condition expressed by the one or the other -data Tok = - TK String - | TN Ss [(Ss, [String])] -- ^ variants depending on next string ---- | TP Ss [(Ss, [String])] -- variants depending on previous string - deriving (Eq, Ord, Show, Read) - - --- | a variant can itself be a token list, but for simplicity only a list of strings --- i.e. not itself containing variants -type Ss = [String] - --- matching functions in both ways - -matchPrefix :: Ss -> [(Ss,[String])] -> [String] -> Ss -matchPrefix s vs t = - head $ [u | - (u,as) <- vs, - any (\c -> isPrefixOf c (concat (unmarkup t))) as - ] ++ [s] - -matchSuffix :: String -> Ss -> [(Ss,[String])] -> Ss -matchSuffix t s vs = - head ([u | (u,as) <- vs, any (\c -> isSuffixOf c t) as] ++ [s]) - -unmarkup :: [String] -> [String] -unmarkup = filter (not . isXMLtag) where - isXMLtag s = case s of - '<':cs@(_:_) -> last cs == '>' - _ -> False - -str2strings :: Str -> Ss -str2strings (Str st) = alls st where - alls st = case st of - TK s : ts -> s : alls ts - TN ds vs : ts -> matchPrefix ds vs t ++ t where t = alls ts ----- u :TP ds vs: ts -> [u] ++ matchSuffix u ds vs ++ alls ts - [] -> [] - -str2allStrings :: Str -> [Ss] -str2allStrings (Str st) = alls st where - alls st = case st of - TK s : ts -> [s : t | t <- alls ts] - TN ds vs : [] -> [ds ++ v | v <- map fst vs] - TN ds vs : ts -> [matchPrefix ds vs t ++ t | t <- alls ts] - [] -> [[]] - -sstr :: Str -> String -sstr = unwords . str2strings - --- | to handle a list of variants -sstrV :: [Str] -> String -sstrV ss = case ss of - [] -> "*" - _ -> unwords $ intersperse "/" $ map (unwords . str2strings) ss - -str :: String -> Str -str s = if null s then Str [] else Str [itS s] - -itS :: String -> Tok -itS s = TK s - -isZeroTok :: Str -> Bool -isZeroTok t = case t of - Str [] -> True - Str [TK []] -> True - _ -> False - -strTok :: Ss -> [(Ss,[String])] -> Str -strTok ds vs = Str [TN ds vs] - -prStr :: Str -> String -prStr = prQuotedString . sstr - -plusStr :: Str -> Str -> Str -plusStr (Str ss) (Str tt) = Str (ss ++ tt) - -glueStr :: Str -> Str -> Str -glueStr (Str ss) (Str tt) = Str $ case (ss,tt) of - ([],_) -> tt - (_,[]) -> ss - _ -> init ss ++ glueIt (last ss) (head tt) ++ tail tt - where - glueIt t u = case (t,u) of - (TK s, TK s') -> return $ TK $ s ++ s' - (TN ds vs, TN es ws) -> return $ TN (glues (matchPrefix ds vs es) es) - [(glues (matchPrefix ds vs w) w,cs) | (w,cs) <- ws] - (TN ds vs, TK s) -> map TK $ glues (matchPrefix ds vs [s]) [s] - (TK s, TN es ws) -> return $ TN (glues [s] es) [(glues [s] w, c) | (w,c) <- ws] - -glues :: [[a]] -> [[a]] -> [[a]] -glues ss tt = case (ss,tt) of - ([],_) -> tt - (_,[]) -> ss - _ -> init ss ++ [last ss ++ head tt] ++ tail tt - --- | to create the list of all lexical items -allItems :: Str -> [String] -allItems (Str s) = concatMap allOne s where - allOne t = case t of - TK s -> [s] - TN ds vs -> ds ++ concatMap fst vs diff --git a/src/GF/Data/Trie.hs b/src/GF/Data/Trie.hs deleted file mode 100644 index 9fb5daa27..000000000 --- a/src/GF/Data/Trie.hs +++ /dev/null @@ -1,129 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Trie --- Maintainer : Markus Forsberg --- Stability : Obsolete --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:09 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Trie ( - tcompile, - collapse, - Trie, - trieLookup, - decompose, - Attr, - atW, atP, atWP - ) where - -import GF.Data.Map - ---- data Attr = W | P | WP deriving Eq -type Attr = Int - -atW, atP, atWP :: Attr -(atW,atP,atWP) = (0,1,2) - -newtype TrieT = TrieT ([(Char,TrieT)],[(Attr,String)]) - -newtype Trie = Trie (Map Char Trie, [(Attr,String)]) - -emptyTrie = TrieT ([],[]) - -optimize :: TrieT -> Trie -optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty, - res) - -collapse :: Trie -> [(String,[(Attr,String)])] -collapse trie = collapse' trie [] - where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))] - else (reverse s,(x:xs)): - concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - collapse' (Trie (map,[])) s - = concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - -tcompile :: [(String,[(Attr,String)])] -> Trie -tcompile xs = optimize $ build xs emptyTrie - -build :: [(String,[(Attr,String)])] -> TrieT -> TrieT -build [] trie = trie -build (x:xs) trie = build xs (insert x trie) - where - insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res) - insert ((s:ss),ys) (TrieT (xs,res)) - = case (span (\(s',_) -> s' /= s) xs) of - (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrie)):xs),res) - (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res) - -trieLookup :: Trie -> String -> (String,[(Attr,String)]) -trieLookup trie s = apply trie s s - -apply :: Trie -> String -> String -> (String,[(Attr,String)]) -apply (Trie (_,res)) [] inp = (inp,res) -apply (Trie (map,_)) (s:ss) inp - = case map ! s of - Just trie -> apply trie ss inp - Nothing -> (inp,[]) - --- Composite analysis (Huet's unglue algorithm) --- only legaldecompositions are accepted. --- With legal means that the composite forms are ordered correctly --- with respect to the attributes W,P and WP. - --- Composite analysis - -testTrie = tcompile [("flick",[(atP,"P")]),("knopp",[(atW,"W")]),("flaggstångs",[(atWP,"WP")])] - -decompose :: Trie -> String -> [String] -decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie - --- The function legal checks if the decomposition is in fact a possible one. - -legal :: Trie -> [String] -> [String] -legal _ [] = [] -legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else [] - where - test [] = False - test [xs] = elem atW xs || elem atWP xs - test (xs:xss) = (elem atP xs || elem atWP xs) && test xss - -react :: String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String] -react input output back occ (Trie (arcs,res)) init = - case res of -- Accept = non-empty res. - [] -> continue back - _ -> let pushout = (occ:output) - in case input of - [] -> reverse $ map reverse pushout - _ -> let pushback = ((input,pushout):back) - in continue pushback - where continue cont = case input of - [] -> backtrack cont init - (l:rest) -> case arcs ! l of - Just trie -> - react rest output cont (l:occ) trie init - Nothing -> backtrack cont init - -backtrack :: [(String,[String])] -> Trie -> [String] -backtrack [] _ = [] -backtrack ((input,output):back) trie - = react input output back [] trie trie - -{- --- The function legal checks if the decomposition is in fact a possible one. -legal :: Trie -> [String] -> [String] -legal _ [] = [] -legal trie input - | test $ - map ((map fst).snd.(trieLookup trie)) input = input - | otherwise = [] - where -- test checks that the Attrs are in the correct order. - test [] = False -- This case should never happen. - test [xs] = elem W xs || elem WP xs - test (xs:xss) = (elem P xs || elem WP xs) && test xss --} diff --git a/src/GF/Data/Trie2.hs b/src/GF/Data/Trie2.hs deleted file mode 100644 index 36fcc3221..000000000 --- a/src/GF/Data/Trie2.hs +++ /dev/null @@ -1,120 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Trie2 --- Maintainer : Markus Forsberg --- Stability : Stable --- Portability : Haskell 98 --- --- > CVS $Date: 2005/04/21 16:22:10 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.7 $ --- --- (Description of the module) ------------------------------------------------------------------------------ - -module GF.Data.Trie2 ( - tcompile, - collapse, - Trie, - trieLookup, - decompose, - --- Attr, atW, atP, atWP, - emptyTrie - ) where - -import GF.Data.Map -import Data.List - -newtype TrieT a b = TrieT ([(a,TrieT a b)],[b]) - -newtype Trie a b = Trie (Map a (Trie a b), [b]) - -emptyTrieT = TrieT ([],[]) - -emptyTrie :: Trie a b -emptyTrie = Trie (empty,[]) - -optimize :: (Ord a,Eq b) => TrieT a b -> Trie a b -optimize (TrieT (xs,res)) = Trie ([(c,optimize t) | (c,t) <- xs] |->+ empty, - nub res) --- nub by AR - -collapse :: Ord a => Trie a b -> [([a],[b])] -collapse trie = collapse' trie [] - where collapse' (Trie (map,(x:xs))) s = if (isEmpty map) then [(reverse s,(x:xs))] - else (reverse s,(x:xs)): - concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - collapse' (Trie (map,[])) s - = concat [ collapse' trie (c:s) | (c,trie) <- flatten map] - -tcompile :: (Ord a,Eq b) => [([a],[b])] -> Trie a b -tcompile xs = optimize $ build xs emptyTrieT - -build :: Ord a => [([a],[b])] -> TrieT a b -> TrieT a b -build [] trie = trie -build (x:xs) trie = build xs (insert x trie) - where - insert ([],ys) (TrieT (xs,res)) = TrieT (xs,ys ++ res) - insert ((s:ss),ys) (TrieT (xs,res)) - = case (span (\(s',_) -> s' /= s) xs) of - (xs,[]) -> TrieT (((s,(insert (ss,ys) emptyTrieT)):xs),res) - (xs,(y,trie):zs) -> TrieT (xs ++ ((y,insert (ss,ys) trie):zs),res) - -trieLookup :: Ord a => Trie a b -> [a] -> ([a],[b]) -trieLookup trie s = apply trie s s - -apply :: Ord a => Trie a b -> [a] -> [a] -> ([a],[b]) -apply (Trie (_,res)) [] inp = (inp,res) -apply (Trie (map,_)) (s:ss) inp - = case map ! s of - Just trie -> apply trie ss inp - Nothing -> (inp,[]) - ------------------------------ --- from Trie for strings; simplified for GF by making binding always possible (AR) - -decompose :: Ord a => Trie a b -> [a] -> [[a]] -decompose trie sentence = backtrack [(sentence,[])] trie - -react :: Ord a => [a] -> [[a]] -> [([a],[[a]])] -> - [a] -> Trie a b -> Trie a b -> [[a]] --- String -> [String] -> [(String,[String])] -> String -> Trie -> Trie -> [String] -react input output back occ (Trie (arcs,res)) init = - case res of -- Accept = non-empty res. - [] -> continue back - _ -> let pushout = (occ:output) - in case input of - [] -> reverse $ map reverse pushout - _ -> let pushback = ((input,pushout):back) - in continue pushback - where continue cont = case input of - [] -> backtrack cont init - (l:rest) -> case arcs ! l of - Just trie -> - react rest output cont (l:occ) trie init - Nothing -> backtrack cont init - -backtrack :: Ord a => [([a],[[a]])] -> Trie a b -> [[a]] -backtrack [] _ = [] -backtrack ((input,output):back) trie - = react input output back [] trie trie - - -{- so this is not needed from the original -type Attr = Int - -atW, atP, atWP :: Attr -(atW,atP,atWP) = (0,1,2) - -decompose :: Ord a => Trie a (Int,b) -> [a] -> [[a]] -decompose trie sentence = legal trie $ backtrack [(sentence,[])] trie - --- The function legal checks if the decomposition is in fact a possible one. - -legal :: Ord a => Trie a (Int,b) -> [[a]] -> [[a]] -legal _ [] = [] -legal trie input = if (test (map ((map fst).snd.(trieLookup trie)) input)) then input else [] - where - test [] = False - test [xs] = elem atW xs || elem atWP xs - test (xs:xss) = (elem atP xs || elem atWP xs) && test xss --} diff --git a/src/GF/Data/Utilities.hs b/src/GF/Data/Utilities.hs deleted file mode 100644 index 74d3ef81e..000000000 --- a/src/GF/Data/Utilities.hs +++ /dev/null @@ -1,190 +0,0 @@ ----------------------------------------------------------------------- --- | --- Maintainer : PL --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/26 18:47:16 $ --- > CVS $Author: bringert $ --- > CVS $Revision: 1.6 $ --- --- Basic functions not in the standard libraries ------------------------------------------------------------------------------ - - -module GF.Data.Utilities where - -import Data.Maybe -import Data.List -import Control.Monad (MonadPlus(..),liftM) - --- * functions on lists - -sameLength :: [a] -> [a] -> Bool -sameLength [] [] = True -sameLength (_:xs) (_:ys) = sameLength xs ys -sameLength _ _ = False - -notLongerThan, longerThan :: Int -> [a] -> Bool -notLongerThan n = null . snd . splitAt n -longerThan n = not . notLongerThan n - -lookupList :: Eq a => a -> [(a, b)] -> [b] -lookupList a [] = [] -lookupList a (p:ps) | a == fst p = snd p : lookupList a ps - | otherwise = lookupList a ps - -split :: [a] -> ([a], [a]) -split (x : y : as) = (x:xs, y:ys) - where (xs, ys) = split as -split as = (as, []) - -splitBy :: (a -> Bool) -> [a] -> ([a], [a]) -splitBy p [] = ([], []) -splitBy p (a : as) = if p a then (a:xs, ys) else (xs, a:ys) - where (xs, ys) = splitBy p as - -foldMerge :: (a -> a -> a) -> a -> [a] -> a -foldMerge merge zero = fm - where fm [] = zero - fm [a] = a - fm abs = let (as, bs) = split abs in fm as `merge` fm bs - -select :: [a] -> [(a, [a])] -select [] = [] -select (x:xs) = (x,xs) : [ (y,x:ys) | (y,ys) <- select xs ] - -updateNth :: (a -> a) -> Int -> [a] -> [a] -updateNth update 0 (a : as) = update a : as -updateNth update n (a : as) = a : updateNth update (n-1) as - -updateNthM :: Monad m => (a -> m a) -> Int -> [a] -> m [a] -updateNthM update 0 (a : as) = liftM (:as) (update a) -updateNthM update n (a : as) = liftM (a:) (updateNthM update (n-1) as) - --- | Like 'init', but returns the empty list when the input is empty. -safeInit :: [a] -> [a] -safeInit [] = [] -safeInit xs = init xs - --- | Like 'nub', but more efficient as it uses sorting internally. -sortNub :: Ord a => [a] -> [a] -sortNub = map head . group . sort - --- | Like 'nubBy', but more efficient as it uses sorting internally. -sortNubBy :: (a -> a -> Ordering) -> [a] -> [a] -sortNubBy f = map head . sortGroupBy f - --- | Sorts and then groups elements given and ordering of the --- elements. -sortGroupBy :: (a -> a -> Ordering) -> [a] -> [[a]] -sortGroupBy f = groupBy (compareEq f) . sortBy f - --- | Take the union of a list of lists. -unionAll :: Eq a => [[a]] -> [a] -unionAll = nub . concat - --- | Like 'lookup', but fails if the argument is not found, --- instead of returning Nothing. -lookup' :: (Show a, Eq a) => a -> [(a,b)] -> b -lookup' x = fromMaybe (error $ "Not found: " ++ show x) . lookup x - --- | Like 'find', but fails if nothing is found. -find' :: (a -> Bool) -> [a] -> a -find' p = fromJust . find p - --- | Set a value in a lookup table. -tableSet :: Eq a => a -> b -> [(a,b)] -> [(a,b)] -tableSet x y [] = [(x,y)] -tableSet x y (p@(x',_):xs) | x' == x = (x,y):xs - | otherwise = p:tableSet x y xs - --- | Group tuples by their first elements. -buildMultiMap :: Ord a => [(a,b)] -> [(a,[b])] -buildMultiMap = map (\g -> (fst (head g), map snd g) ) - . sortGroupBy (compareBy fst) - --- | Replace all occurences of an element by another element. -replace :: Eq a => a -> a -> [a] -> [a] -replace x y = map (\z -> if z == x then y else z) - --- * equality functions - --- | Use an ordering function as an equality predicate. -compareEq :: (a -> a -> Ordering) -> a -> a -> Bool -compareEq f x y = case f x y of - EQ -> True - _ -> False - --- * ordering functions - -compareBy :: Ord b => (a -> b) -> a -> a -> Ordering -compareBy f = both f compare - -both :: (a -> b) -> (b -> b -> c) -> a -> a -> c -both f g x y = g (f x) (f y) - --- * functions on pairs - -mapFst :: (a -> a') -> (a, b) -> (a', b) -mapFst f (a, b) = (f a, b) - -mapSnd :: (b -> b') -> (a, b) -> (a, b') -mapSnd f (a, b) = (a, f b) - --- * functions on monads - --- | Return the given value if the boolean is true, els return 'mzero'. -whenMP :: MonadPlus m => Bool -> a -> m a -whenMP b x = if b then return x else mzero - --- * functions on Maybes - --- | Returns true if the argument is Nothing or Just [] -nothingOrNull :: Maybe [a] -> Bool -nothingOrNull = maybe True null - --- * functions on functions - --- | Apply all the functions in the list to the argument. -foldFuns :: [a -> a] -> a -> a -foldFuns fs x = foldl (flip ($)) x fs - --- | Fixpoint iteration. -fix :: Eq a => (a -> a) -> a -> a -fix f x = let x' = f x in if x' == x then x else fix f x' - --- * functions on strings - --- | Join a number of lists by using the given glue --- between the lists. -join :: [a] -- ^ glue - -> [[a]] -- ^ lists to join - -> [a] -join g = concat . intersperse g - --- * ShowS-functions - -nl :: ShowS -nl = showChar '\n' - -sp :: ShowS -sp = showChar ' ' - -wrap :: String -> ShowS -> String -> ShowS -wrap o s c = showString o . s . showString c - -concatS :: [ShowS] -> ShowS -concatS = foldr (.) id - -unwordsS :: [ShowS] -> ShowS -unwordsS = joinS " " - -unlinesS :: [ShowS] -> ShowS -unlinesS = joinS "\n" - -joinS :: String -> [ShowS] -> ShowS -joinS glue = concatS . intersperse (showString glue) - - - diff --git a/src/GF/Data/XML.hs b/src/GF/Data/XML.hs deleted file mode 100644 index a1807adcc..000000000 --- a/src/GF/Data/XML.hs +++ /dev/null @@ -1,57 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : XML --- Maintainer : BB --- Stability : (stable) --- Portability : (portable) --- --- Utilities for creating XML documents. ------------------------------------------------------------------------------ - -module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where - -import GF.Data.Utilities - -data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty - deriving (Ord,Eq,Show) - -type Attr = (String,String) - -comments :: [String] -> [XML] -comments = map Comment - -showXMLDoc :: XML -> String -showXMLDoc xml = showsXMLDoc xml "" - -showsXMLDoc :: XML -> ShowS -showsXMLDoc xml = showString header . showsXML xml - where header = "" - -showsXML :: XML -> ShowS -showsXML (Data s) = showString s -showsXML (CData 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 "' -showsXML (Comment c) = showString "" -showsXML (Empty) = id - -showsAttrs :: [Attr] -> ShowS -showsAttrs = concatS . map (showChar ' ' .) . map showsAttr - -showsAttr :: Attr -> ShowS -showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\"" - -escape :: String -> String -escape = concatMap escChar - where - escChar '<' = "<" - escChar '>' = ">" - escChar '&' = "&" - escChar '"' = """ - escChar c = [c] - -bottomUpXML :: (XML -> XML) -> XML -> XML -bottomUpXML f (Tag n attrs cs) = f (Tag n attrs (map (bottomUpXML f) cs)) -bottomUpXML f x = f x diff --git a/src/GF/Data/Zipper.hs b/src/GF/Data/Zipper.hs deleted file mode 100644 index a4491f76e..000000000 --- a/src/GF/Data/Zipper.hs +++ /dev/null @@ -1,257 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : Zipper --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/06/11 20:27:05 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.9 $ --- --- Gérard Huet's zipper (JFP 7 (1997)). AR 10\/8\/2001 ------------------------------------------------------------------------------ - -module GF.Data.Zipper (-- * types - Tr(..), - Path(..), - Loc(..), - -- * basic (original) functions - leaf, - goLeft, goRight, goUp, goDown, - changeLoc, - changeNode, - forgetNode, - -- * added sequential representation - goAhead, - goBack, - -- ** n-ary versions - goAheadN, - goBackN, - -- * added mappings between locations and trees - loc2tree, - loc2treeMarked, - tree2loc, - goRoot, - goLast, - goPosition, - getPosition, - keepPosition, - -- * added some utilities - traverseCollect, - scanTree, - mapTr, - mapTrM, - mapPath, - mapPathM, - mapLoc, - mapLocM, - foldTr, - foldTrM, - mapSubtrees, - mapSubtreesM, - changeRoot, - nthSubtree, - arityTree - ) where - -import GF.Data.Operations - -newtype Tr a = Tr (a,[Tr a]) deriving (Show,Eq) - -data Path a = - Top - | Node ([Tr a], (Path a, a), [Tr a]) - deriving Show - -leaf :: a -> Tr a -leaf a = Tr (a,[]) - -newtype Loc a = Loc (Tr a, Path a) deriving Show - -goLeft, goRight, goUp, goDown :: Loc a -> Err (Loc a) -goLeft (Loc (t,p)) = case p of - Top -> Bad "left of top" - Node (l:left, upv, right) -> return $ Loc (l, Node (left,upv,t:right)) - Node _ -> Bad "left of first" -goRight (Loc (t,p)) = case p of - Top -> Bad "right of top" - Node (left, upv, r:right) -> return $ Loc (r, Node (t:left,upv,right)) - Node _ -> Bad "right of first" -goUp (Loc (t,p)) = case p of - Top -> Bad "up of top" - Node (left, (up,v), right) -> - return $ Loc (Tr (v, reverse left ++ (t:right)), up) -goDown (Loc (t,p)) = case t of - Tr (v,(t1:trees)) -> return $ Loc (t1,Node ([],(p,v),trees)) - _ -> Bad "down of empty" - -changeLoc :: Loc a -> Tr a -> Err (Loc a) -changeLoc (Loc (_,p)) t = return $ Loc (t,p) - -changeNode :: (a -> a) -> Loc a -> Loc a -changeNode f (Loc (Tr (n,ts),p)) = Loc (Tr (f n, ts),p) - -forgetNode :: Loc a -> Err (Loc a) -forgetNode (Loc (Tr (n,[t]),p)) = return $ Loc (t,p) -forgetNode _ = Bad $ "not a one-branch tree" - --- added sequential representation - --- | a successor function -goAhead :: Loc a -> Err (Loc a) -goAhead s@(Loc (t,p)) = case (t,p) of - (Tr (_,_:_),Node (_,_,_:_)) -> goDown s - (Tr (_,[]), _) -> upsRight s - (_, _) -> goDown s - where - upsRight t = case goRight t of - Ok t' -> return t' - Bad _ -> goUp t >>= upsRight - --- | a predecessor function -goBack :: Loc a -> Err (Loc a) -goBack s@(Loc (t,p)) = case goLeft s of - Ok s' -> downRight s' - _ -> goUp s - where - downRight s = case goDown s of - Ok s' -> case goRight s' of - Ok s'' -> downRight s'' - _ -> downRight s' - _ -> return s - --- n-ary versions - -goAheadN :: Int -> Loc a -> Err (Loc a) -goAheadN i st - | i < 1 = return st - | otherwise = goAhead st >>= goAheadN (i-1) - -goBackN :: Int -> Loc a -> Err (Loc a) -goBackN i st - | i < 1 = return st - | otherwise = goBack st >>= goBackN (i-1) - --- added mappings between locations and trees - -loc2tree :: Loc a -> Tr a -loc2tree (Loc (t,p)) = case p of - Top -> t - Node (left,(p',v),right) -> - loc2tree (Loc (Tr (v, reverse left ++ (t : right)),p')) - -loc2treeMarked :: Loc a -> Tr (a, Bool) -loc2treeMarked (Loc (Tr (a,ts),p)) = - loc2tree (Loc (Tr (mark a, map (mapTr nomark) ts), mapPath nomark p)) - where - (mark, nomark) = (\a -> (a,True), \a -> (a, False)) - -tree2loc :: Tr a -> Loc a -tree2loc t = Loc (t,Top) - -goRoot :: Loc a -> Loc a -goRoot = tree2loc . loc2tree - -goLast :: Loc a -> Err (Loc a) -goLast = rep goAhead where - rep f s = err (const (return s)) (rep f) (f s) - -goPosition :: [Int] -> Loc a -> Err (Loc a) -goPosition p = go p . goRoot where - go [] s = return s - go (p:ps) s = goDown s >>= apply p goRight >>= go ps - -getPosition :: Loc a -> [Int] -getPosition = reverse . getp where - getp (Loc (t,p)) = case p of - Top -> [] - Node (left,(p',v),_) -> length left : getp (Loc (Tr (v, []),p')) - -keepPosition :: (Loc a -> Err (Loc a)) -> (Loc a -> Err (Loc a)) -keepPosition f s = do - let p = getPosition s - s' <- f s - goPosition p s' - -apply :: Monad m => Int -> (a -> m a) -> a -> m a -apply n f a = case n of - 0 -> return a - _ -> f a >>= apply (n-1) f - --- added some utilities - -traverseCollect :: Path a -> [a] -traverseCollect p = reverse $ case p of - Top -> [] - Node (_, (p',v), _) -> v : traverseCollect p' - -scanTree :: Tr a -> [a] -scanTree (Tr (a,ts)) = a : concatMap scanTree ts - -mapTr :: (a -> b) -> Tr a -> Tr b -mapTr f (Tr (x,ts)) = Tr (f x, map (mapTr f) ts) - -mapTrM :: Monad m => (a -> m b) -> Tr a -> m (Tr b) -mapTrM f (Tr (x,ts)) = do - fx <- f x - fts <- mapM (mapTrM f) ts - return $ Tr (fx,fts) - -mapPath :: (a -> b) -> Path a -> Path b -mapPath f p = case p of - Node (ts1, (p,v), ts2) -> - Node (map (mapTr f) ts1, (mapPath f p, f v), map (mapTr f) ts2) - Top -> Top - -mapPathM :: Monad m => (a -> m b) -> Path a -> m (Path b) -mapPathM f p = case p of - Node (ts1, (p,v), ts2) -> do - ts1' <- mapM (mapTrM f) ts1 - p' <- mapPathM f p - v' <- f v - ts2' <- mapM (mapTrM f) ts2 - return $ Node (ts1', (p',v'), ts2') - Top -> return Top - -mapLoc :: (a -> b) -> Loc a -> Loc b -mapLoc f (Loc (t,p)) = Loc (mapTr f t, mapPath f p) - -mapLocM :: Monad m => (a -> m b) -> Loc a -> m (Loc b) -mapLocM f (Loc (t,p)) = do - t' <- mapTrM f t - p' <- mapPathM f p - return $ (Loc (t',p')) - -foldTr :: (a -> [b] -> b) -> Tr a -> b -foldTr f (Tr (x,ts)) = f x (map (foldTr f) ts) - -foldTrM :: Monad m => (a -> [b] -> m b) -> Tr a -> m b -foldTrM f (Tr (x,ts)) = do - fts <- mapM (foldTrM f) ts - f x fts - -mapSubtrees :: (Tr a -> Tr a) -> Tr a -> Tr a -mapSubtrees f t = let Tr (x,ts) = f t in Tr (x, map (mapSubtrees f) ts) - -mapSubtreesM :: Monad m => (Tr a -> m (Tr a)) -> Tr a -> m (Tr a) -mapSubtreesM f t = do - Tr (x,ts) <- f t - ts' <- mapM (mapSubtreesM f) ts - return $ Tr (x, ts') - --- | change the root without moving the pointer -changeRoot :: (a -> a) -> Loc a -> Loc a -changeRoot f loc = case loc of - Loc (Tr (a,ts),Top) -> Loc (Tr (f a,ts),Top) - Loc (t, Node (left,pv,right)) -> Loc (t, Node (left,chPath pv,right)) - where - chPath pv = case pv of - (Top,a) -> (Top, f a) - (Node (left,pv,right),v) -> (Node (left, chPath pv,right),v) - -nthSubtree :: Int -> Tr a -> Err (Tr a) -nthSubtree n (Tr (a,ts)) = ts !? n - -arityTree :: Tr a -> Int -arityTree (Tr (_,ts)) = length ts -- cgit v1.2.3