GF/src is now for 2.9, and the new sources are in src-3.0 - keep it this way until the release of GF 3

src-3.0/GF/CF/Profile.hs

@@ -0,0 +1,106 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Profile
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/04/21 16:21:14 $ 
+-- > CVS $Author: bringert $
+-- > CVS $Revision: 1.8 $
+--
+-- restoring parse trees for discontinuous constituents, bindings, etc. AR 25/1/2001
+-- revised 8/4/2002 for the new profile structure
+-----------------------------------------------------------------------------
+
+module GF.CF.Profile (postParse) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import qualified GF.Infra.Ident as I
+import GF.Canon.CMacros
+---import MMacros
+import GF.CF.CF
+import GF.CF.CFIdent
+import GF.CF.PPrCF -- for error msg
+import GF.Grammar.PrGrammar
+
+import GF.Data.Operations
+
+import Control.Monad
+import Data.List (nub)
+
+-- | the job is done in two passes: 
+-- 
+--   1. tree2term: restore constituent order from Profile 
+-- 
+--   2. term2trm:  restore Bindings from Binds
+postParse :: CFTree -> Err Exp
+postParse tree = do
+  iterm <- errIn ("postprocessing parse tree" +++ prCFTree tree) $ tree2term tree
+  return $ term2trm  iterm
+
+-- | an intermediate data structure
+data ITerm = ITerm (Atom, BindVs) [ITerm] | IMeta   deriving (Eq,Show)
+type BindVs = [[I.Ident]]
+
+-- | (1) restore constituent order from Profile 
+tree2term :: CFTree -> Err ITerm
+-- tree2term (CFTree (f,(_,[t]))) | f == dummyCFFun = tree2term t -- not used
+tree2term (CFTree (cff@(CFFun (fun,pro)), (_,trees))) = case fun of
+  AM _ -> return IMeta
+  _ -> do
+    args  <- mapM mkArg pro
+    binds <- mapM mkBinds pro
+    return $ ITerm (fun, binds) args
+ where
+   mkArg (_,arg) = case arg of
+     [x] -> do               -- one occurrence
+       trx <- trees !? x
+       tree2term trx
+     []  -> return IMeta     -- suppression
+     _   -> do               -- reduplication
+       trees' <- mapM (trees !?) arg
+       xs1    <- mapM tree2term trees' 
+       xs2    <- checkArity xs1
+       unif xs2
+
+   checkArity xs = if length (nub [length xx | ITerm _ xx <- xs']) > 1 
+                   then Bad "arity error" 
+                   else return xs'
+           where xs' = [t | t@(ITerm _ _) <- xs]
+   unif xs = case [t | t@(ITerm _ _) <- xs] of 
+    [] -> return $ IMeta
+    (ITerm fp@(f,_) xx : ts) -> do
+      let hs = [h | ITerm (h,_) _ <- ts, h /= f]
+      testErr (null hs)                 -- if fails, hs must be nonempty
+              ("unification expects" +++ prt f +++ "but found" +++ prt (head hs))
+      xx' <- mapM unifArg [0 .. length xx - 1]
+      return $ ITerm fp xx'
+    where
+      unifArg i = unif [zz !! i | ITerm _ zz <- xs]
+
+   mkBinds (xss,_) = mapM mkBind xss
+   mkBind xs = do
+     ts <- mapM (trees !?) xs
+     let vs = [x | CFTree (CFFun (AV x,_),(_,[])) <- ts]
+     testErr (length ts == length vs) "non-variable in bound position"
+     case vs of
+       [x]  -> return x
+       []   -> return $ I.identC "h_" ---- uBoundVar
+       y:ys -> do
+         testErr (all (==y) ys) ("fail to unify bindings of" +++ prt y)
+         return y
+
+-- | (2) restore Bindings from Binds
+term2trm :: ITerm -> Exp 
+term2trm IMeta = EAtom (AM 0) ---- mExp0
+term2trm (ITerm (fun, binds) terms) =
+  let bterms = zip binds terms
+  in mkAppAtom fun [mkAbsR xs (term2trm t) |  (xs,t) <- bterms]
+
+ --- these are deprecated
+ where
+   mkAbsR c e = foldr EAbs e c
+   mkAppAtom a = mkApp (EAtom a)
+   mkApp = foldl EApp