Glue modules.

5 files changed, 251 insertions, 0 deletions

diff --git a/src/GF/Data/Glue.hs b/src/GF/Data/Glue.hs
new file mode 100644
index 000000000..247224075
--- /dev/null
+++ b/src/GF/Data/Glue.hs
@@ -0,0 +1,19 @@
+module Glue where
+
+import Trie
+import Operations
+import List
+
+-------- AR 8/11/2003, using Markus Forsberg's implementation of Huet's unglue
+
+tcompileSimple :: [String] -> Trie
+tcompileSimple ss = tcompile [(s,[(atWP,s)]) | s <- ss]
+
+decomposeSimple :: Trie -> String -> Err [String]
+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 = tcompileSimple $ words "ett två tre tjugo trettio hundra tusen"
diff --git a/src/GF/Data/Map.hs b/src/GF/Data/Map.hs
new file mode 100644
index 000000000..1adc0523a
--- /dev/null
+++ b/src/GF/Data/Map.hs
@@ -0,0 +1,52 @@
+{- 
+   **************************************************************
+   * Filename      : Map.hs                                     *
+   * Author        : Markus Forsberg                            *
+   *                 markus@cs.chalmers.se                      *
+   * Last Modified : 15 December, 2001                          *
+   * Lines         : 53                                         *
+   ************************************************************** 
+-}
+
+module Map 
+           (
+           Map,
+           empty,
+	   (!),     -- lookup operator.
+	   (!+),    -- lookupMany operator.
+	   (|->),   -- insert operator.
+	   (|->+),  -- insertMany operator.
+	   (<+>),   -- union operator.
+	   flatten  -- 
+	   ) where
+
+import RedBlack
+
+type Map key el = Tree key el
+
+infixl 6 |->
+infixl 6 |->+
+infixl 5 !
+infixl 5 !+
+infixl 4 <+>
+
+empty :: Map key el
+empty = emptyTree
+
+(!) :: Ord key => Map key el -> key -> Maybe el
+fm ! e = lookupTree e fm
+
+(!+) :: Ord key => Map key el -> [key] -> [Maybe el]
+fm !+    []  = []
+fm !+ (e:es) = (lookupTree e fm): (fm !+ es)
+
+(|->) :: Ord key => (key,el) -> Map key el -> Map key el
+(x,y) |-> fm = insertTree (x,y) fm
+
+(|->+) :: Ord key => [(key,el)] -> Map key el -> Map key el
+[]         |->+ fm = fm
+((x,y):xs) |->+ fm = xs |->+ (insertTree (x,y) fm)
+
+(<+>) :: 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/RedBlack.hs b/src/GF/Data/RedBlack.hs
new file mode 100644
index 000000000..8a24c07a3
--- /dev/null
+++ b/src/GF/Data/RedBlack.hs
@@ -0,0 +1,55 @@
+{- 
+   **************************************************************
+   * Filename      : RedBlack.hs                                *
+   * Author        : Markus Forsberg                            *
+   *                 markus@cs.chalmers.se                      *
+   * Last Modified : 15 December, 2001                          *
+   * Lines         : 57                                         *
+   ************************************************************** 
+-} -- Modified version of Osanaki's implementation.
+
+module RedBlack (
+                emptyTree,
+		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
+
+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/Trie.hs b/src/GF/Data/Trie.hs
new file mode 100644
index 000000000..0a0a4472b
--- /dev/null
+++ b/src/GF/Data/Trie.hs
@@ -0,0 +1,116 @@
+{- 
+   **************************************************************
+   * Filename      : Trie.hs                                    *
+   * Author        : Markus Forsberg                            *
+   *                 markus@cs.chalmers.se                      *
+   * Last Modified : 17 December, 2001                          *
+   * Lines         : 51                                         *
+   ************************************************************** 
+-}
+
+module Trie (
+             tcompile,
+             Trie,
+	     trieLookup,
+	     decompose,
+             Attr,
+             atW, atP, atWP
+	    ) where
+
+import 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)
+
+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/Infra/Modules.hs b/src/GF/Infra/Modules.hs
index 569806e60..4b642fd72 100644
--- a/src/GF/Infra/Modules.hs
+++ b/src/GF/Infra/Modules.hs
@@ -114,9 +114,18 @@ depPathModule m = fors m ++ exts m ++ opens m where
   fors m = case mtype m of
     MTTransfer i j -> [i,j]
     MTConcrete i   -> [oSimple i]
+    MTInstance i   -> [oSimple i]
     _              -> []
   exts m = map oSimple $ maybe [] return $ extends m
 
+-- all dependencies
+allDepsModule :: Ord i => MGrammar i f a -> Module i f a -> [OpenSpec i]
+allDepsModule gr m = iterFix add os0 where
+  os0 = depPathModule m
+  add os = [m | o <- os, Just (ModMod n) <- [lookup (openedModule o) mods], 
+                m <- depPathModule n]
+  mods = modules gr
+
 -- all modules that a module extends, directly or indirectly
 allExtends :: (Show i,Ord i) => MGrammar i f a -> i -> [i]
 allExtends gr i = case lookupModule gr i of