mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-28 22:12:51 -06:00
Founding the newly structured GF2.0 cvs archive.
This commit is contained in:
aarne
7
src/GF/Data/ErrM.hs
Normal file
7
src/GF/Data/ErrM.hs
Normal file
@@ -0,0 +1,7 @@
|
||||
module ErrM (
|
||||
module Operations
|
||||
) where
|
||||
|
||||
import Operations
|
||||
|
||||
-- hack for BNFC generated files. AR 21/9/2003
|
||||
559
src/GF/Data/Operations.hs
Normal file
559
src/GF/Data/Operations.hs
Normal file
@@ -0,0 +1,559 @@
|
||||
module Operations where
|
||||
|
||||
import Char (isSpace, toUpper, isSpace, isDigit)
|
||||
import List (nub, sortBy, sort, deleteBy, nubBy)
|
||||
import Monad (liftM2)
|
||||
|
||||
infixr 5 +++
|
||||
infixr 5 ++-
|
||||
infixr 5 ++++
|
||||
infixr 5 +++++
|
||||
infixl 9 !?
|
||||
|
||||
-- some auxiliary GF operations. AR 19/6/1998 -- 6/2/2001
|
||||
-- Copyright (c) Aarne Ranta 1998-2000, under GNU General Public License (see GPL)
|
||||
|
||||
ifNull :: b -> ([a] -> b) -> [a] -> b
|
||||
ifNull b f xs = if null xs then b else f xs
|
||||
|
||||
-- the Error monad
|
||||
|
||||
data Err a = Ok a | Bad String -- like Maybe type with error msgs
|
||||
deriving (Read, Show, Eq)
|
||||
|
||||
instance Monad Err where
|
||||
return = Ok
|
||||
Ok a >>= f = f a
|
||||
Bad s >>= f = Bad s
|
||||
|
||||
-- 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
|
||||
|
||||
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 =
|
||||
do yy' <- mapM f xys
|
||||
return (zip (map fst xys) yy')
|
||||
|
||||
mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
|
||||
mapPairsM f xys =
|
||||
do let (xx,yy) = unzip xys
|
||||
yy' <- mapM f yy
|
||||
return (zip xx yy')
|
||||
|
||||
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
|
||||
|
||||
-- !! 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 = Yes
|
||||
may = May
|
||||
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 :: Perhaps a b -> Perhaps a b -> Err (Perhaps a b)
|
||||
unifPerhaps p1 p2 = case (p1,p2) of
|
||||
(Nope, _) -> return p2
|
||||
(_, Nope) -> return p1
|
||||
_ -> Bad "update conflict"
|
||||
|
||||
-- this is what happens when updating a module extension
|
||||
updatePerhaps :: 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
|
||||
|
||||
-- binary search trees
|
||||
|
||||
data BinTree a = NT | BT a (BinTree a) (BinTree a) deriving (Show,Read)
|
||||
|
||||
isInBinTree :: (Ord a) => a -> BinTree a -> Bool
|
||||
isInBinTree x tree = case tree of
|
||||
NT -> False
|
||||
BT a left right
|
||||
| x < a -> isInBinTree x left
|
||||
| x > a -> isInBinTree x right
|
||||
| x == a -> True
|
||||
|
||||
-- quick method to see if two trees have common elements
|
||||
-- the complexity is O(log |old|, |new|) so the heuristic is that new is smaller
|
||||
|
||||
commonsInTree :: (Ord a) => BinTree (a,b) -> BinTree (a,b) -> [(a,(b,b))]
|
||||
commonsInTree old new = foldr inOld [] new' where
|
||||
new' = tree2list new
|
||||
inOld (x,v) xs = case justLookupTree x old of
|
||||
Ok v' -> (x,(v',v)) : xs
|
||||
_ -> xs
|
||||
|
||||
justLookupTree :: (Ord a) => a -> BinTree (a,b) -> Err b
|
||||
justLookupTree = lookupTree (const [])
|
||||
|
||||
lookupTree :: (Ord a) => (a -> String) -> a -> BinTree (a,b) -> Err b
|
||||
lookupTree pr x tree = case tree of
|
||||
NT -> Bad ("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
|
||||
|
||||
lookupTreeEq :: (Ord a) =>
|
||||
(a -> String) -> (a -> a -> Bool) -> a -> BinTree (a,b) -> Err b
|
||||
lookupTreeEq pr eq x tree = case tree of
|
||||
NT -> Bad ("no occurrence of element equal to" +++ pr x)
|
||||
BT (a,b) left right
|
||||
| eq x a -> return b -- a weaker equality relation than ==
|
||||
| x < a -> lookupTreeEq pr eq x left
|
||||
| x > a -> lookupTreeEq pr eq x right
|
||||
|
||||
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
|
||||
|
||||
-- destructive update
|
||||
|
||||
updateTree :: (Ord a) => (a,b) -> BinTree (a,b) -> BinTree (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
|
||||
|
||||
updateTreeEq ::
|
||||
(Ord a) => (a -> a -> Bool) -> (a,b) -> BinTree (a,b) -> BinTree (a,b)
|
||||
updateTreeEq eq z@(x,y) tree = case tree of
|
||||
NT -> BT z NT NT
|
||||
BT c@(a,b) left right
|
||||
| eq x a -> BT (a,y) left right -- removing the old value of a
|
||||
| x < a -> let left' = updateTree z left in BT c left' right
|
||||
| x > a -> let right' = updateTree z right in BT c left right'
|
||||
|
||||
updatesTree :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b)
|
||||
updatesTree (z:zs) tr = updateTree z t where t = updatesTree zs tr
|
||||
updatesTree [] tr = tr
|
||||
|
||||
updatesTreeNondestr :: (Ord a) => [(a,b)] -> BinTree (a,b) -> BinTree (a,b)
|
||||
updatesTreeNondestr xs tr = case xs of
|
||||
(z:zs) -> updateTreeGen False z t where t = updatesTreeNondestr zs tr
|
||||
_ -> tr
|
||||
|
||||
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 zz = updatesTree zz NT
|
||||
|
||||
sorted2tree :: [(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
|
||||
|
||||
mapTree :: (a -> b) -> BinTree a -> BinTree b
|
||||
mapTree f NT = NT
|
||||
mapTree f (BT a left right) = BT (f a) (mapTree f left) (mapTree f right)
|
||||
|
||||
mapMTree :: Monad m => (a -> m b) -> BinTree a -> m (BinTree b)
|
||||
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'
|
||||
|
||||
tree2list :: BinTree a -> [a] -- inorder
|
||||
tree2list NT = []
|
||||
tree2list (BT z left right) = tree2list left ++ [z] ++ tree2list right
|
||||
|
||||
depthTree :: BinTree a -> Int
|
||||
depthTree NT = 0
|
||||
depthTree (BT _ left right) = 1 + max (depthTree left) (depthTree right)
|
||||
|
||||
mergeTrees :: Ord a => BinTree (a,b) -> BinTree (a,b) -> BinTree (a,[b])
|
||||
mergeTrees old new = foldr upd new' (tree2list old) where
|
||||
upd xy@(x,y) tree = case tree of
|
||||
NT -> BT (x,[y]) NT NT
|
||||
BT (a,bs) left right
|
||||
| x < a -> let left' = upd xy left in BT (a,bs) left' right
|
||||
| x > a -> let right' = upd xy right in BT (a,bs) left right'
|
||||
| otherwise -> BT (a, y:bs) left right -- adding the new value
|
||||
new' = mapTree (\ (i,d) -> (i,[d])) new
|
||||
|
||||
|
||||
-- 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]
|
||||
|
||||
-- printing
|
||||
|
||||
indent :: Int -> String -> String
|
||||
indent i s = replicate i ' ' ++ s
|
||||
|
||||
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 n s = concat (replicate n s)
|
||||
|
||||
prTList t ss = case ss of
|
||||
[] -> ""
|
||||
[s] -> s
|
||||
s:ss -> s ++ t ++ prTList t ss
|
||||
|
||||
prQuotedString x = "\"" ++ restoreEscapes x ++ "\""
|
||||
|
||||
prParenth s = if s == "" then "" else "(" ++ s ++ ")"
|
||||
|
||||
prCurly s = "{" ++ s ++ "}"
|
||||
prBracket s = "[" ++ s ++ "]"
|
||||
|
||||
prArgList xx = prParenth (prTList "," xx)
|
||||
|
||||
prSemicList = prTList " ; "
|
||||
|
||||
prCurlyList = prCurly . prSemicList
|
||||
|
||||
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
|
||||
--- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
|
||||
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!!
|
||||
|
||||
-- LaTeX code producing functions
|
||||
|
||||
dollar s = '$' : s ++ "$"
|
||||
mbox s = "\\mbox{" ++ s ++ "}"
|
||||
ital s = "{\\em" +++ s ++ "}"
|
||||
boldf s = "{\\bf" +++ s ++ "}"
|
||||
verbat s = "\\verbat!" ++ s ++ "!"
|
||||
|
||||
mkLatexFile s = begindocument +++++ s +++++ enddocument
|
||||
|
||||
begindocument =
|
||||
"\\documentclass[a4paper,11pt]{article}" ++++ -- M.F. 25/01-02
|
||||
"\\setlength{\\parskip}{2mm}" ++++
|
||||
"\\setlength{\\parindent}{0mm}" ++++
|
||||
"\\setlength{\\oddsidemargin}{0mm}" ++++
|
||||
"\\setlength{\\evensidemargin}{-2mm}" ++++
|
||||
"\\setlength{\\topmargin}{-8mm}" ++++
|
||||
"\\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 :: [[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 [] = []
|
||||
|
||||
|
||||
|
||||
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 :: String -> [String] -> [[String]]
|
||||
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 []
|
||||
|
||||
118
src/GF/Data/OrdMap2.hs
Normal file
118
src/GF/Data/OrdMap2.hs
Normal file
@@ -0,0 +1,118 @@
|
||||
|
||||
|
||||
--------------------------------------------------
|
||||
-- The class of ordered finite maps
|
||||
-- as described in section 2.2.2
|
||||
|
||||
-- and an example implementation,
|
||||
-- derived from the implementation in appendix A.2
|
||||
|
||||
|
||||
module OrdMap2 (OrdMap(..), Map) where
|
||||
|
||||
import 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)
|
||||
|
||||
|
||||
|
||||
|
||||
111
src/GF/Data/OrdSet.hs
Normal file
111
src/GF/Data/OrdSet.hs
Normal file
@@ -0,0 +1,111 @@
|
||||
|
||||
|
||||
--------------------------------------------------
|
||||
-- The class of ordered sets
|
||||
-- as described in section 2.2.1
|
||||
|
||||
-- and an example implementation,
|
||||
-- derived from the implementation in appendix A.1
|
||||
|
||||
|
||||
module OrdSet (OrdSet(..), Set) where
|
||||
|
||||
import 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
|
||||
|
||||
|
||||
143
src/GF/Data/Parsers.hs
Normal file
143
src/GF/Data/Parsers.hs
Normal file
@@ -0,0 +1,143 @@
|
||||
module Parsers where
|
||||
|
||||
import Operations
|
||||
import Char
|
||||
|
||||
|
||||
infixr 2 |||, +||
|
||||
infixr 3 ***
|
||||
infixr 5 .>.
|
||||
infixr 5 ...
|
||||
infixr 5 ....
|
||||
infixr 5 +..
|
||||
infixr 5 ..+
|
||||
infixr 6 |>
|
||||
infixr 3 <<<
|
||||
|
||||
-- some parser combinators a` la Wadler and Hutton
|
||||
-- no longer used in many places in GF
|
||||
|
||||
type Parser a b = [a] -> [(b,[a])]
|
||||
|
||||
parseResults :: Parser a b -> [a] -> [b]
|
||||
parseResults p s = [x | (x,r) <- p s, null r]
|
||||
|
||||
parseResultErr :: Parser a b -> [a] -> Err b
|
||||
parseResultErr p s = case parseResults p s of
|
||||
[x] -> return x
|
||||
[] -> Bad "no parse"
|
||||
_ -> 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 p = literal '(' +.. pJunk +.. p ..+ pJunk ..+ literal ')'
|
||||
pCommaList p = pTList "," (pJ p) -- p,...,p
|
||||
pOptCommaList p = pCommaList p ||| succeed [] -- the same or nothing
|
||||
pArgList p = pParenth (pCommaList p) ||| succeed [] -- (p,...,p), poss. empty
|
||||
pArgList2 p = pParenth (p ... jL "," +.. pCommaList p) *** uncurry (:) -- min.2 args
|
||||
|
||||
longestOfSome p = (p ... longestOfMany p) *** (\ (x,y) -> x:y)
|
||||
|
||||
pIdent = pLetter ... longestOfMany pAlphaPlusChar *** uncurry (:)
|
||||
where alphaPlusChar c = isAlphaNum c || c=='_' || c=='\''
|
||||
|
||||
pLetter = satisfy (`elem` (['A'..'Z'] ++ ['a'..'z'] ++
|
||||
['À' .. 'Û'] ++ ['à' .. 'û'])) -- no such in Char
|
||||
pDigit = satisfy isDigit
|
||||
pLetters = longestOfSome pLetter
|
||||
pAlphanum = pDigit ||| pLetter
|
||||
pAlphaPlusChar = pAlphanum ||| satisfy (`elem` "_'")
|
||||
|
||||
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']
|
||||
|
||||
106
src/GF/Data/Str.hs
Normal file
106
src/GF/Data/Str.hs
Normal file
@@ -0,0 +1,106 @@
|
||||
module Str (
|
||||
Str (..), Tok (..), --- constructors needed in PrGrammar
|
||||
str2strings, str2allStrings, str, sstr, sstrV,
|
||||
isZeroTok, prStr, plusStr, glueStr,
|
||||
strTok,
|
||||
allItems
|
||||
) where
|
||||
|
||||
import Operations
|
||||
import 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)
|
||||
|
||||
data Tok =
|
||||
TK String
|
||||
| TN Ss [(Ss, [String])] -- variants depending on next string
|
||||
deriving (Eq, Ord, Show, Read)
|
||||
|
||||
-- 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
|
||||
|
||||
-- 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 t)) as] ++ [s])
|
||||
|
||||
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
|
||||
[] -> []
|
||||
|
||||
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 = 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
|
||||
172
src/GF/Data/Zipper.hs
Normal file
172
src/GF/Data/Zipper.hs
Normal file
@@ -0,0 +1,172 @@
|
||||
module Zipper where
|
||||
|
||||
import Operations
|
||||
|
||||
-- Gérard Huet's zipper (JFP 7 (1997)). AR 10/8/2001
|
||||
|
||||
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,[])
|
||||
|
||||
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 (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 t = Loc (t,Top)
|
||||
|
||||
goRoot = tree2loc . loc2tree
|
||||
|
||||
goLast :: Loc a -> Err (Loc a)
|
||||
goLast = rep goAhead where
|
||||
rep f s = err (const (return s)) (rep f) (f s)
|
||||
|
||||
-- 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)
|
||||
Reference in New Issue
Block a user