now the linearization is completely based on PMCFG

8 files changed, 200 insertions, 305 deletions

diff --git a/src/runtime/haskell/PGF/Binary.hs b/src/runtime/haskell/PGF/Binary.hs
index 7d5db73af..a9a6a78dc 100644
--- a/src/runtime/haskell/PGF/Binary.hs
+++ b/src/runtime/haskell/PGF/Binary.hs
@@ -2,6 +2,7 @@ module PGF.Binary where
 

 import PGF.CId

 import PGF.Data

+import PGF.Macros

 import Data.Binary

 import Data.Binary.Put

 import Data.Binary.Get

@@ -28,10 +29,11 @@ instance Binary PGF where
            gflags <- get

            abstract <- get

            concretes <- get

-           return (PGF{ absname=absname, cncnames=cncnames

-                      , gflags=gflags

-                      , abstract=abstract, concretes=concretes

-                      })

+           return $ updateProductionIndices $

+                      (PGF{ absname=absname, cncnames=cncnames

+                          , gflags=gflags

+                          , abstract=abstract, concretes=concretes

+                          })

 

 instance Binary CId where

   put (CId bs) = put bs

@@ -185,15 +187,16 @@ instance Binary Production where
              _ -> decodingError

 

 instance Binary ParserInfo where

-  put p = put (functions p, sequences p, productions0 p, totalCats p, startCats p)

+  put p = put (functions p, sequences p, productions p, totalCats p, startCats p)

   get = do functions   <- get

            sequences   <- get

-           productions0<- get

+           productions <- get

            totalCats   <- get

            startCats   <- get

            return (ParserInfo{functions=functions,sequences=sequences

-                             ,productions0=productions0

-                             ,productions =filterProductions productions0

+                             ,productions = productions

+                             ,pproductions = IntMap.empty

+                             ,lproductions = Map.empty

                              ,totalCats=totalCats,startCats=startCats})

 

 decodingError = fail "This PGF file was compiled with different version of GF"

diff --git a/src/runtime/haskell/PGF/Linearize.hs b/src/runtime/haskell/PGF/Linearize.hs
index de3daf11d..9058cba61 100644
--- a/src/runtime/haskell/PGF/Linearize.hs
+++ b/src/runtime/haskell/PGF/Linearize.hs
@@ -1,38 +1,81 @@
-{-# LANGUAGE ParallelListComp #-}
-module PGF.Linearize 
-  (linearizes,showPrintName,realize,realizes,linTree, linTreeMark,linearizesMark) where
+module PGF.Linearize(linearizes,markLinearizes,tabularLinearizes) where
 
 import PGF.CId
 import PGF.Data
 import PGF.Macros
-import PGF.Tree
-
+import Data.Maybe (fromJust)
+import Data.Array.IArray
+import Data.List
 import Control.Monad
 import qualified Data.Map as Map
-import Data.List
-
-import Debug.Trace
+import qualified Data.IntMap as IntMap
+import qualified Data.Set as Set
 
 -- linearization and computation of concrete PGF Terms
 
-linearizes :: PGF -> CId -> Expr -> [String]
-linearizes pgf lang = realizes . linTree pgf lang
-
-realize :: Term -> String
-realize = concat . take 1 . realizes
+type LinTable = Array FIndex [Tokn]
 
-realizes :: Term -> [String]
-realizes = map (unwords . untokn) . realizest
+linearizes :: PGF -> CId -> Expr -> [String]
+linearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang (\_ _ lint -> lint)
 
-realizest :: Term -> [[Tokn]]
-realizest trm = case trm of
-  R ts     -> realizest (ts !! 0)
-  S ss     -> map concat $ combinations $ map realizest ss
-  K t      -> [[t]]
-  W s t    -> [[KS (s ++ r)] | [KS r] <- realizest t]
-  FV ts    -> concatMap realizest ts
-  TM s     -> [[KS s]]
-  _ -> [[KS $ "REALIZE_ERROR " ++ show trm]] ---- debug
+linTree :: PGF -> Language -> (Maybe CId -> [Int] -> LinTable -> LinTable) -> Expr -> [LinTable]
+linTree pgf lang mark e = lin0 [] [] [] Nothing e
+  where
+    cnc   = lookMap (error "no lang") lang (concretes pgf)
+    pinfo = fromJust (parser cnc)
+    lp    = lproductions pinfo
+
+    lin0 path xs ys mb_fid (EAbs _ x e)  = lin0 path (showCId x:xs) ys mb_fid e
+    lin0 path xs ys mb_fid (ETyped e _)  = lin0 path xs ys mb_fid e
+    lin0 path xs ys mb_fid e | null xs   = lin path ys mb_fid e []
+                             | otherwise = apply path (xs ++ ys) mb_fid _B (e:[ELit (LStr x) | x <- xs])
+
+    lin path xs mb_fid (EApp e1 e2) es = lin path xs mb_fid e1 (e2:es)
+    lin path xs mb_fid (ELit l)     [] = case l of
+                                           LStr s -> return (mark Nothing path (ss s))
+                                           LInt n -> return (mark Nothing path (ss (show n)))
+                                           LFlt f -> return (mark Nothing path (ss (show f)))
+    lin path xs mb_fid (EMeta i)    es = apply path xs mb_fid _V (ELit (LStr ('?':show i)):es)
+    lin path xs mb_fid (EFun f)     es = map (mark (Just f) path) (apply path xs mb_fid f  es)
+    lin path xs mb_fid (EVar  i)    es = apply path xs mb_fid _V (ELit (LStr (xs !! i))   :es)
+    lin path xs mb_fid (ETyped e _) es = lin path xs mb_fid e es
+    lin path xs mb_fid (EImplArg e) es = lin path xs mb_fid e es
+
+    ss s = listArray (0,0) [[KS s]]
+
+    apply path xs mb_fid f es =
+      case Map.lookup f lp of
+        Just prods -> case lookupProds mb_fid prods of
+                        Just set -> do prod <- Set.toList set
+                                       case prod of
+                                         FApply funid fids -> do guard (length fids == length es)
+                                                                 args <- sequence (zipWith3 (\i fid e -> lin0 (sub i path) [] xs (Just fid) e) [0..] fids es)
+                                                                 let (FFun _ lins) = functions pinfo ! funid
+                                                                 return (listArray (bounds lins) [computeSeq seqid args | seqid <- elems lins])
+                                         FCoerce fid       -> apply path xs (Just fid) f es
+                        Nothing  -> mzero
+        Nothing    -> apply path xs mb_fid _V [ELit (LStr "?")]              -- function without linearization
+      where
+        lookupProds (Just fid) prods = IntMap.lookup fid prods
+        lookupProds Nothing    prods
+            | f == _B || f == _V     = Nothing
+            | otherwise              = Just (Set.filter isApp (Set.unions (IntMap.elems prods)))
+
+        sub i path
+          | f == _B || f == _V =   path
+          | otherwise          = i:path
+
+        isApp (FApply _ _) = True
+        isApp _            = False
+
+        computeSeq seqid args = concatMap compute (elems seq)
+          where
+            seq = sequences pinfo ! seqid
+
+            compute (FSymCat d r)    = (args !! d) ! r
+            compute (FSymLit d r)    = (args !! d) ! r
+            compute (FSymKS ts)      = map KS ts
+            compute (FSymKP ts alts) = [KP ts alts]
 
 untokn :: [Tokn] -> [String]
 untokn ts = case ts of
@@ -45,126 +88,23 @@ untokn ts = case ts of
      v:_ -> v
      _   -> d
 
--- Lifts all variants to the top level (except those in macros).
-liftVariants :: Term -> [Term]
-liftVariants = f
-  where
-    f (R ts)    = liftM R $ mapM f ts
-    f (P t1 t2) = liftM2 P (f t1) (f t2)
-    f (S ts)    = liftM S $ mapM f ts
-    f (FV ts)   = ts >>= f
-    f (W s t)   = liftM (W s) $ f t
-    f t         = return t
-
-linTree :: PGF -> CId -> Expr -> Term
-linTree pgf lang e = lin (expr2tree e) Nothing
+-- create a table from labels+params to variants
+tabularLinearizes :: PGF -> CId -> Expr -> [[(String,String)]]
+tabularLinearizes pgf lang e = map (zip lbls . map (unwords . untokn) . elems) (linTree pgf lang (\_ _ lint -> lint) e)
   where
-    cnc = lookMap (error "no lang") lang (concretes pgf)
-
-    lin (Abs xs  e )   mty = case lin e Nothing of
-                               R ts -> R $ ts     ++ (Data.List.map (kks . showCId . snd) xs)
-                               TM s -> R $ (TM s)  : (Data.List.map (kks . showCId . snd) xs)
-    lin (Fun fun es)   mty = case Map.lookup fun (funs (abstract pgf)) of
-                               Just (DTyp hyps _ _,_,_) -> let argVariants = sequence [liftVariants (lin e (Just ty)) | e <- es | (_,_,ty) <- hyps]
-                                                           in variants [compute pgf lang args $ lookMap tm0 fun (lins cnc) | args <- argVariants]
-                               Nothing                  -> tm0
-    lin (Lit (LStr s)) mty = R [kks (show s)] -- quoted
-    lin (Lit (LInt i)) mty = R [kks (show i)] 
-    lin (Lit (LFlt d)) mty = R [kks (show d)]
-    lin (Var x)        mty = case mty of
-                               Just (DTyp _ cat _) -> compute pgf lang [K (KS (showCId x))] (lookMap tm0 cat (lindefs cnc))
-                               Nothing             -> TM (showCId x)
-    lin (Meta i)       mty = case mty of
-                               Just (DTyp _ cat _) -> compute pgf lang [K (KS ("?" ++ show    i))] (lookMap tm0 cat (lindefs cnc))
-                               Nothing             -> TM (show    i)
-
-variants :: [Term] -> Term
-variants ts = case ts of
-  [t] -> t
-  _   -> FV ts
-
-unvariants :: Term -> [Term]
-unvariants t = case t of
-  FV ts -> ts
-  _     -> [t]
-
-compute :: PGF -> CId -> [Term] -> Term -> Term
-compute pgf lang args = comp where
-  comp trm = case trm of
-    P r p  -> proj (comp r) (comp p) 
-    W s t  -> W s (comp t)
-    R ts   -> R $ map comp ts
-    V i    -> idx args i          -- already computed
-    F c    -> comp $ look c       -- not computed (if contains argvar)
-    FV ts  -> FV $ map comp ts
-    S ts   -> S $ filter (/= S []) $ map comp ts
-    _ -> trm
-
-  look = lookOper pgf lang
-
-  idx xs i = if i > length xs - 1 
-    then trace 
-         ("too large " ++ show i ++ " for\n" ++ unlines (map show xs) ++ "\n") tm0 
-    else xs !! i 
-
-  proj r p = case (r,p) of
-    (_,     FV ts) -> FV $ map (proj r) ts
-    (FV ts, _    ) -> FV $ map (\t -> proj t p) ts
-    (W s t, _)     -> kks (s ++ getString (proj t p))
-    _              -> comp $ getField r (getIndex p)
-
-  getString t = case t of
-    K (KS s) -> s
-    _ -> error ("ERROR in grammar compiler: string from "++ show t) "ERR"
-
-  getIndex t =  case t of
-    C i    -> i
-    TM _   -> 0  -- default value for parameter
-    _ -> trace ("ERROR in grammar compiler: index from " ++ show t) 666
-
-  getField t i = case t of
-    R rs   -> idx rs i
-    TM s   -> TM s
-    _ -> error ("ERROR in grammar compiler: field from " ++ show t) t
-
----------
--- markup with tree positions
-
-linearizesMark :: PGF -> CId -> Expr -> [String]
-linearizesMark pgf lang = realizes . linTreeMark pgf lang
-
-linTreeMark :: PGF -> CId -> Expr -> Term
-linTreeMark pgf lang = lin [] . expr2tree
+    lbls = case unApp e of
+             Just (f,_) -> let cat = valCat (lookType pgf f)
+                           in case parser (lookConcr pgf lang) >>= Map.lookup cat . startCats of
+                                Just (_,_,lbls) -> elems lbls
+                                Nothing         -> error "No labels"
+             Nothing    -> error "Not function application"
+
+
+-- show bracketed markup with references to tree structure
+markLinearizes :: PGF -> CId -> Expr -> [String]
+markLinearizes pgf lang = map (unwords . untokn . (! 0)) . linTree pgf lang mark
   where
-    lin p (Abs xs  e ) = case lin p e of
-      R ts -> R $ ts     ++ (Data.List.map (kks . showCId . snd) xs)
-      TM s -> R $ (TM s)  : (Data.List.map (kks . showCId . snd) xs)
-    lin p (Fun fun es) = 
-      let argVariants = 
-            mapM (\ (i,e) -> liftVariants $ lin (sub p i) e) (zip [0..] es)
-      in variants [mark (fun,p) $ compute pgf lang args $ look fun | 
-                                                         args <- argVariants]
-    lin p (Lit (LStr s)) = mark p $ R [kks (show s)] -- quoted
-    lin p (Lit (LInt i)) = mark p $ R [kks (show i)] 
-    lin p (Lit (LFlt d)) = mark p $ R [kks (show d)]
-    lin p (Var x)        = mark p $ TM (showCId x)
-    lin p (Meta i)       = mark p $ TM (show i)
- 
-    look = lookLin pgf lang
-
-    mark :: Show a => a -> Term -> Term
-    mark p t = case t of
-      R  ts -> R $ map (mark p) ts
-      FV ts -> R $ map (mark p) ts
-      S  ts -> S $ bracket p ts
-      K  s  -> S $ bracket p [t]
-      W s (R ts) -> R [mark p $ kks (s ++ u) | K (KS u) <- ts]
-      _     -> t
-      -- otherwise in normal form
-
-    bracket  p ts = [kks ("("++show p)] ++ ts ++ [kks ")"]
-    sub p i = p ++ [i]
-
--- | Show the printname of function or category
-showPrintName :: PGF -> Language -> CId -> String
-showPrintName pgf lang id = lookMap "?" id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
+    mark mb_f path lint = amap (bracket mb_f path) lint
+
+    bracket Nothing  path ts = [KS ("("++show (reverse path))] ++ ts ++ [KS ")"]
+    bracket (Just f) path ts = [KS ("(("++showCId f++","++show (reverse path)++")")] ++ ts ++ [KS ")"]
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs
index 81f946211..bf6252f2a 100644
--- a/src/runtime/haskell/PGF/Macros.hs
+++ b/src/runtime/haskell/PGF/Macros.hs
@@ -3,10 +3,14 @@ module PGF.Macros where
 import PGF.CId
 import PGF.Data
 import Control.Monad
-import qualified Data.Map   as Map
-import qualified Data.Array as Array
+import qualified Data.Map    as Map
+import qualified Data.Set    as Set
+import qualified Data.IntMap as IntMap
+import qualified Data.IntSet as IntSet
+import qualified Data.Array  as Array
 import Data.Maybe
 import Data.List
+import GF.Data.Utilities(sortNub)
 
 -- operations for manipulating PGF grammars and objects
 
@@ -122,6 +126,10 @@ contextLength :: Type -> Int
 contextLength ty = case ty of
   DTyp hyps _ _ -> length hyps
 
+-- | Show the printname of function or category
+showPrintName :: PGF -> Language -> CId -> String
+showPrintName pgf lang id = lookMap "?" id $ printnames $ lookMap (error "no lang") lang $ concretes pgf
+
 term0 :: CId -> Term
 term0 = TM . showCId
 
@@ -151,3 +159,63 @@ cidVar    = mkCId "__gfVar"
 
 _B = mkCId "__gfB"
 _V = mkCId "__gfV"
+
+updateProductionIndices :: PGF -> PGF
+updateProductionIndices pgf = pgf{concretes = fmap updateConcrete (concretes pgf)}
+  where
+    updateConcrete cnc = 
+      case parser cnc of
+        Nothing    -> cnc
+        Just pinfo -> let prods0    = filterProductions (productions pinfo)
+                          p_prods   = parseIndex pinfo prods0
+                          l_prods   = linIndex   pinfo prods0
+                      in cnc{parser = Just pinfo{pproductions = p_prods, lproductions = l_prods}}
+    
+    filterProductions prods0
+      | IntMap.size prods == IntMap.size prods0 = prods
+      | otherwise                               = filterProductions prods
+      where
+        prods = IntMap.mapMaybe (filterProdSet prods0) prods0
+
+        filterProdSet prods set0
+          | Set.null set = Nothing
+          | otherwise    = Just set
+          where
+            set = Set.filter (filterRule prods) set0
+
+        filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args
+        filterRule prods (FCoerce fcat)      = isLiteralFCat fcat || IntMap.member fcat prods
+        filterRule prods _                   = True
+
+    parseIndex pinfo = IntMap.mapMaybeWithKey filterProdSet
+      where
+        filterProdSet fid prods
+          | fid `IntSet.member` ho_fids = Just prods
+          | otherwise                   = let prods' = Set.filter (not . is_ho_prod) prods
+                                          in if Set.null prods'
+                                               then Nothing
+                                               else Just prods'
+
+        is_ho_prod (FApply _ [fid]) | fid == fcatVar = True
+        is_ho_prod _                                 = False
+
+        ho_fids :: IntSet.IntSet
+        ho_fids = IntSet.fromList [fid | cat <- ho_cats
+                                       , fid <- maybe [] (\(s,e,_) -> [s..e]) (Map.lookup cat (startCats pinfo))]
+
+        ho_cats :: [CId]
+        ho_cats = sortNub [c | (ty,_,_) <- Map.elems (funs (abstract pgf))
+                             , h <- case ty of {DTyp hyps val _ -> hyps}
+                             , let ty = typeOfHypo h
+                             , c <- fst (catSkeleton ty)]
+
+    linIndex pinfo productions = 
+      Map.fromListWith (IntMap.unionWith Set.union)
+                       [(fun,IntMap.singleton res (Set.singleton prod)) | (res,prods) <- IntMap.toList productions
+                                                                        , prod <- Set.toList prods
+                                                                        , fun <- getFunctions prod]
+      where
+        getFunctions (FApply funid args) = let FFun fun _ = functions pinfo Array.! funid in [fun]
+        getFunctions (FCoerce fid)       = case IntMap.lookup fid productions of
+                                             Nothing    -> []
+                                             Just prods -> [fun | prod <- Set.toList prods, fun <- getFunctions prod]
\ No newline at end of file
diff --git a/src/runtime/haskell/PGF/Morphology.hs b/src/runtime/haskell/PGF/Morphology.hs
index 9eee71a97..be786ebbb 100644
--- a/src/runtime/haskell/PGF/Morphology.hs
+++ b/src/runtime/haskell/PGF/Morphology.hs
@@ -2,11 +2,13 @@ module PGF.Morphology(Lemma,Analysis,Morpho,
                       buildMorpho,
                       lookupMorpho,fullFormLexicon) where
 
-import PGF.ShowLinearize (collectWords)
-import PGF.Data
 import PGF.CId
+import PGF.Data
 
 import qualified Data.Map as Map
+import qualified Data.Set as Set
+import qualified Data.IntMap as IntMap
+import Data.Array.IArray
 import Data.List (intersperse)
 
 -- these 4 definitions depend on the datastructure used
@@ -17,7 +19,23 @@ type Analysis = String
 newtype Morpho = Morpho (Map.Map String [(Lemma,Analysis)])
 
 buildMorpho :: PGF -> Language -> Morpho
-buildMorpho pgf lang = Morpho (Map.fromListWith (++) (collectWords pgf lang))
+buildMorpho pgf lang = Morpho $
+  case Map.lookup lang (concretes pgf) >>= parser of
+    Just pinfo -> collectWords pinfo
+    Nothing    -> Map.empty
+
+collectWords pinfo = Map.fromListWith (++)
+  [(t, [(fun,lbls ! l)]) | (s,e,lbls) <- Map.elems (startCats pinfo)
+                         , fid <- [s..e]
+                         , FApply funid _ <- maybe [] Set.toList (IntMap.lookup fid (pproductions pinfo))
+                         , let FFun fun lins = functions pinfo ! funid
+                         , (l,seqid) <- assocs lins
+                         , sym <- elems (sequences pinfo ! seqid)
+                         , t <- sym2tokns sym]
+  where
+    sym2tokns (FSymKS ts)      = ts
+    sym2tokns (FSymKP ts alts) = ts ++ [t | Alt ts ps <- alts, t <- ts]
+    sym2tokns _                = []
 
 lookupMorpho :: Morpho -> String -> [(Lemma,Analysis)]
 lookupMorpho (Morpho mo) s = maybe [] id $ Map.lookup s mo
diff --git a/src/runtime/haskell/PGF/PMCFG.hs b/src/runtime/haskell/PGF/PMCFG.hs
index abf7e4380..0ef0e3295 100644
--- a/src/runtime/haskell/PGF/PMCFG.hs
+++ b/src/runtime/haskell/PGF/PMCFG.hs
@@ -34,12 +34,13 @@ data Alternative =
   deriving (Eq,Ord,Show)

 

 data ParserInfo

-    = ParserInfo { functions   :: Array FunId FFun

-                 , sequences   :: Array SeqId FSeq

-                 , productions0:: IntMap.IntMap (Set.Set Production)    -- this are the original productions as they are loaded from the PGF file

-                 , productions :: IntMap.IntMap (Set.Set Production)    -- this are the productions after the filtering for useless productions

-                 , startCats   :: Map.Map CId (FCat,FCat,Array FIndex String)  -- for every category - start/end FCat and a list of label names

-                 , totalCats   :: {-# UNPACK #-} !FCat

+    = ParserInfo { functions    :: Array FunId FFun

+                 , sequences    :: Array SeqId FSeq

+                 , productions  :: IntMap.IntMap (Set.Set Production)                 -- the original productions loaded from the PGF file

+                 , pproductions :: IntMap.IntMap (Set.Set Production)                 -- productions needed for parsing

+                 , lproductions :: Map.Map CId (IntMap.IntMap (Set.Set Production))   -- productions needed for linearization

+                 , startCats    :: Map.Map CId (FCat,FCat,Array FIndex String)        -- for every category - start/end FCat and a list of label names

+                 , totalCats    :: {-# UNPACK #-} !FCat

                  }

 

 

@@ -98,22 +99,3 @@ ppFCat  fcat
 

 ppFunId funid = char 'F' <> int funid

 ppSeqId seqid = char 'S' <> int seqid

-

-

-filterProductions = closure

-  where

-    closure prods0

-      | IntMap.size prods == IntMap.size prods0 = prods

-      | otherwise                               = closure prods

-      where

-        prods = IntMap.mapMaybe (filterProdSet prods0) prods0

-

-    filterProdSet prods set0

-      | Set.null set = Nothing

-      | otherwise    = Just set

-      where

-        set = Set.filter (filterRule prods) set0

-                             

-    filterRule prods (FApply funid args) = all (\fcat -> isLiteralFCat fcat || IntMap.member fcat prods) args

-    filterRule prods (FCoerce fcat)      = isLiteralFCat fcat || IntMap.member fcat prods

-    filterRule prods _                   = True

diff --git a/src/runtime/haskell/PGF/Parse.hs b/src/runtime/haskell/PGF/Parse.hs
index e9936233c..5a4ccc719 100644
--- a/src/runtime/haskell/PGF/Parse.hs
+++ b/src/runtime/haskell/PGF/Parse.hs
@@ -59,7 +59,7 @@ initState pgf lang (DTyp _ start _) =
   let items = case Map.lookup start (startCats pinfo) of

                 Just (s,e,labels) -> do cat <- range (s,e)

                                         (funid,args) <- foldForest (\funid args -> (:) (funid,args)) (\_ _ args -> args)

-                                                                   [] cat (productions pinfo)

+                                                                   [] cat (pproductions pinfo)

                                         let FFun fn lins = functions pinfo ! funid

                                         (lbl,seqid) <- assocs lins

                                         return (Active 0 0 funid seqid args (AK cat lbl))

@@ -72,7 +72,7 @@ initState pgf lang (DTyp _ start _) =
 

   in PState pgf

             pinfo

-            (Chart emptyAC [] emptyPC (productions pinfo) (totalCats pinfo) 0)

+            (Chart emptyAC [] emptyPC (pproductions pinfo) (totalCats pinfo) 0)

             (TMap.singleton [] (Set.fromList items))

 

 -- | From the current state and the next token

diff --git a/src/runtime/haskell/PGF/ShowLinearize.hs b/src/runtime/haskell/PGF/ShowLinearize.hs
deleted file mode 100644
index fa4de86c8..000000000
--- a/src/runtime/haskell/PGF/ShowLinearize.hs
+++ /dev/null
@@ -1,114 +0,0 @@
-module PGF.ShowLinearize (
-  collectWords,
-  tableLinearize,
-  recordLinearize,
-  termLinearize,
-  tabularLinearize,
-  allLinearize,
-  markLinearize
-  ) where
-
-import PGF.CId
-import PGF.Data
-import PGF.Tree
-import PGF.Macros
-import PGF.Linearize
-
-import GF.Data.Operations
-import Data.List
-import qualified Data.Map as Map
-
--- printing linearizations in different ways with source parameters
-
--- internal representation, only used internally in this module
-data Record = 
-   RR   [(String,Record)]
- | RT   [(String,Record)]
- | RFV  [Record]
- | RS   String
- | RCon String
-
-prRecord :: Record -> String
-prRecord = prr where
-  prr t = case t of
-    RR fs -> concat $ 
-      "{" : 
-      (intersperse ";" (map (\ (l,v) -> unwords [l,"=", prr v]) fs)) ++ ["}"]
-    RT fs -> concat $
-      "table {" : 
-      (intersperse ";" (map (\ (l,v) -> unwords [l,"=>",prr v]) fs)) ++ ["}"]
-    RFV ts -> concat $
-      "variants {" : (intersperse ";" (map prr ts)) ++ ["}"]
-    RS s -> prQuotedString s
-    RCon s -> s
-
--- uses the encoding of record types in PGF.paramlincat
-mkRecord :: Term -> Term -> Record
-mkRecord typ trm = case (typ,trm) of
-  (_,         FV ts)  -> RFV $ map (mkRecord typ) ts
-  (R rs,      R ts)   -> RR [(str lab, mkRecord ty t) | (P lab ty, t) <- zip rs ts]
-  (S [FV ps,ty],R ts) -> RT [(str par, mkRecord ty t) | (par,    t) <- zip ps ts]
-  (_,W s (R ts))      -> mkRecord typ (R [K (KS (s ++ u)) | K (KS u) <- ts])
-  (FV ps,       C i)  -> RCon $ str $ ps !! i
-  (S [],        _)    -> case realizes trm of
-                           [s] -> RS s
-                           ss  -> RFV $ map RS ss
-  _                   -> RS $ show trm ---- printTree trm
- where
-   str = realize
-
--- show all branches, without labels and params
-allLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
-allLinearize unlex pgf lang = concat . map (unlex . pr) . tabularLinearize pgf lang where
-  pr (p,vs) = unlines vs
-
--- show all branches, with labels and params
-tableLinearize :: (String -> String) -> PGF -> CId -> Expr -> String
-tableLinearize unlex pgf lang = unlines . map pr . tabularLinearize pgf lang where
-  pr (p,vs) = p +++ ":" +++ unwords (intersperse "|" (map unlex vs))
-
--- create a table from labels+params to variants
-tabularLinearize :: PGF -> CId -> Expr -> [(String,[String])]
-tabularLinearize pgf lang = branches . recLinearize pgf lang where
-  branches r = case r of
-    RR  fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
-    RT  fs -> [(lab +++ b,s) | (lab,t) <- fs, (b,s) <- branches t]
-    RFV rs -> concatMap branches rs
-    RS  s  -> [([], [s])]
-    RCon _ -> []
-
--- show record in GF-source-like syntax
-recordLinearize :: PGF -> CId -> Expr -> String
-recordLinearize pgf lang = prRecord . recLinearize pgf lang
-
--- create a GF-like record, forming the basis of all functions above
-recLinearize :: PGF -> CId -> Expr -> Record
-recLinearize pgf lang tree = mkRecord typ $ linTree pgf lang tree where
-  typ = case expr2tree tree of
-          Fun f _ -> lookParamLincat pgf lang $ valCat $ lookType pgf f
-
--- show PGF term
-termLinearize :: PGF -> CId -> Expr -> String
-termLinearize pgf lang = show . linTree pgf lang
-
--- show bracketed markup with references to tree structure
-markLinearize :: PGF -> CId -> Expr -> String
-markLinearize pgf lang = concat . take 1 . linearizesMark pgf lang
-
-
--- for Morphology: word, lemma, tags
-collectWords :: PGF -> Language -> [(String, [(CId,String)])]
-collectWords pgf lang = 
-    concatMap collOne 
-      [(f,c,length xs) | (f,(DTyp xs c _,_,_)) <- Map.toList $ funs $ abstract pgf] 
-  where
-    collOne (f,c,i) = 
-      fromRec f [showCId c] (recLinearize pgf lang (foldl EApp (EFun f) (replicate i (EMeta 888))))
-    fromRec f v r = case r of
-      RR  rs -> concat [fromRec f v t | (_,t) <- rs] 
-      RT  rs -> concat [fromRec f (p:v) t | (p,t) <- rs]
-      RFV rs -> concatMap (fromRec f v) rs
-      RS  s  -> [(w,[(f,unwords (reverse v))]) | w <- words s, w /= "?888"] ---
---      RS  s  -> [(s,[(f,unwords (reverse v))])]
-      RCon c -> [] ---- inherent
-
diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs
index 429551f54..8e9b28740 100644
--- a/src/runtime/haskell/PGF/VisualizeTree.hs
+++ b/src/runtime/haskell/PGF/VisualizeTree.hs
@@ -102,7 +102,7 @@ graphvizDependencyTree format debug mlab ms pgf lang exp = case format of
 
   ifd s = if debug then s else []
 
-  pot = readPosText $ head $ linearizesMark pgf lang exp
+  pot = readPosText $ concat $ take 1 $ markLinearizes pgf lang exp
   ---- use Just str if you have str to match against
 
   prelude = ["rankdir=LR ;", "node [shape = plaintext] ;"]
@@ -188,9 +188,7 @@ getDepLabels ss = Map.fromList [(mkCId f,ls) | f:ls <- map words ss]
 ---- nubrec and domins are quadratic, but could be (n log n)
 
 graphvizParseTree :: PGF -> CId -> Expr -> String
-graphvizParseTree pgf lang = prGraph False . lin2tree pgf . linMark where
-  linMark = head . linearizesMark pgf lang
-  ---- use Just str if you have str to match against
+graphvizParseTree pgf lang = prGraph False . lin2tree pgf . concat . take 1 . markLinearizes pgf lang where
 
 lin2tree pgf s = trace s $ prelude ++ nodes ++ links where
 
@@ -235,12 +233,12 @@ tag s = "<" ++ s ++ ">"
 showp = init . tail . show
 mtag = tag . ('n':) . uncommas
 
--- word alignments from Linearize.linearizesMark
+-- word alignments from Linearize.markLinearize
 -- words are chunks like {[0,1,1,0] old}
 
 graphvizAlignment :: PGF -> Expr -> String
 graphvizAlignment pgf = prGraph True . lin2graph . linsMark  where
-  linsMark t = [s | la <- cncnames pgf, s <- take 1 (linearizesMark pgf la t)]
+  linsMark t = [concat (take 1 (markLinearizes pgf la t)) | la <- cncnames pgf]
 
 lin2graph :: [String] -> [String]
 lin2graph ss = trace (show ss) $ prelude ++ nodes ++ links