mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 03:09:33 -06:00
remove all files that aren't used in GF-3.0
This commit is contained in:
kr.angelov
@@ -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)
|
||||
@@ -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"
|
||||
|
||||
@@ -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)
|
||||
|
||||
@@ -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
|
||||
@@ -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)
|
||||
|
||||
|
||||
|
||||
|
||||
@@ -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
|
||||
|
||||
|
||||
@@ -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']
|
||||
|
||||
@@ -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))
|
||||
@@ -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
|
||||
@@ -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
|
||||
-}
|
||||
@@ -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
|
||||
-}
|
||||
@@ -1,57 +0,0 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : XML
|
||||
-- Maintainer : BB
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- Utilities for creating XML documents.
|
||||
-----------------------------------------------------------------------------
|
||||
|
||||
module GF.Data.XML (XML(..), Attr, comments, showXMLDoc, showsXMLDoc, showsXML, bottomUpXML) where
|
||||
|
||||
import GF.Data.Utilities
|
||||
|
||||
data XML = Data String | CData String | Tag String [Attr] [XML] | ETag String [Attr] | Comment String | Empty
|
||||
deriving (Ord,Eq,Show)
|
||||
|
||||
type Attr = (String,String)
|
||||
|
||||
comments :: [String] -> [XML]
|
||||
comments = map Comment
|
||||
|
||||
showXMLDoc :: XML -> String
|
||||
showXMLDoc xml = showsXMLDoc xml ""
|
||||
|
||||
showsXMLDoc :: XML -> ShowS
|
||||
showsXMLDoc xml = showString header . showsXML xml
|
||||
where header = "<?xml version=\"1.0\" encoding=\"UTF-8\" ?>"
|
||||
|
||||
showsXML :: XML -> ShowS
|
||||
showsXML (Data s) = showString s
|
||||
showsXML (CData s) = showString "<![CDATA[" . showString s .showString "]]>"
|
||||
showsXML (ETag t as) = showChar '<' . showString t . showsAttrs as . showString "/>"
|
||||
showsXML (Tag t as cs) =
|
||||
showChar '<' . showString t . showsAttrs as . showChar '>'
|
||||
. concatS (map showsXML cs) . showString "</" . showString t . showChar '>'
|
||||
showsXML (Comment c) = showString "<!-- " . showString c . showString " -->"
|
||||
showsXML (Empty) = id
|
||||
|
||||
showsAttrs :: [Attr] -> ShowS
|
||||
showsAttrs = concatS . map (showChar ' ' .) . map showsAttr
|
||||
|
||||
showsAttr :: Attr -> ShowS
|
||||
showsAttr (n,v) = showString n . showString "=\"" . showString (escape v) . showString "\""
|
||||
|
||||
escape :: String -> String
|
||||
escape = concatMap escChar
|
||||
where
|
||||
escChar '<' = "<"
|
||||
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
|
||||
Reference in New Issue
Block a user