Founding the newly structured GF2.0 cvs archive.

src/GF/UseGrammar/Linear.hs

@@ -0,0 +1,195 @@
+module Linear where
+
+import GFC
+import AbsGFC
+import qualified Abstract as A
+import MkGFC (rtQIdent) ----
+import Ident
+import PrGrammar
+import CMacros
+import Look
+import Str
+import Unlex
+----import TypeCheck -- to annotate
+
+import Operations
+import Zipper
+
+import Monad
+
+-- Linearization for canonical GF. AR 7/6/2003
+
+-- The worker function: linearize a Tree, return
+-- a record. Possibly mark subtrees.
+
+-- NB. Constants in trees are annotated by the name of the abstract module.
+-- A concrete module name must be given to find (and choose) linearization rules.
+
+linearizeToRecord :: CanonGrammar -> Marker -> Ident -> A.Tree -> Err Term
+linearizeToRecord gr mk m = lin [] where
+
+  lin ts t = errIn ("lint" +++ prt t) $ ---- 
+    if A.isFocusNode (A.nodeTree t) 
+      then liftM markFocus $ lint ts t
+      else lint ts t
+
+  lint ts t@(Tr (n,xs)) = do
+
+    let binds = A.bindsNode n
+        at    = A.atomNode n
+    c   <- A.val2cat $ A.valNode n
+    xs' <- mapM (\ (i,x) -> lin (i:ts) x) $ zip [0..] xs
+
+    r <- case at of
+      A.AtC f -> look f >>= comp xs'
+      A.AtL s -> return $ recS $ tK $ prt at
+      A.AtI i -> return $ recS $ tK $ prt at
+      A.AtV x -> lookCat c >>= comp [tK (prt at)]
+      A.AtM m -> lookCat c >>= comp [tK (prt at)] 
+
+    return $ mk ts $ mkBinds binds r
+
+  look = lookupLin gr . redirectIdent m . rtQIdent
+  comp = ccompute gr
+  mkBinds bs bdy = case bdy of
+    R fs -> R $ [Ass (LV i) (tK (prt t)) | (i,(t,_)) <- zip [0..] bs] ++ fs
+
+  recS t = R [Ass (L (identC "s")) t] ----
+
+  lookCat = return . errVal defLindef . look 
+         ---- should always be given in the module
+
+type Marker = [Int] -> Term -> Term
+
+-- if no marking is wanted, use the following
+
+noMark :: [Int] -> Term -> Term
+noMark = const id
+
+-- thus the special case:
+
+linearizeNoMark :: CanonGrammar -> Ident -> A.Tree -> Err Term
+linearizeNoMark gr = linearizeToRecord gr noMark
+
+-- expand tables in linearized term to full, normal-order tables
+-- NB expand from inside-out so that values are not looked up in copies of branches
+
+expandLinTables :: CanonGrammar -> Term -> Err Term
+expandLinTables gr t = case t of
+  R rs -> liftM (R . map (uncurry Ass)) $ mapPairsM exp [(l,r) | Ass l r <- rs]
+  T ty rs -> do
+    rs' <- mapPairsM exp [(l,r) | Cas l r <- rs] -- expand from inside-out
+    let t' = T ty $ map (uncurry Cas) rs'
+    vs  <- alls ty
+    ps  <- mapM term2patt vs
+    ts' <- mapM (comp . S t') $ vs
+    return $ T ty [Cas [p] t | (p,t) <- zip ps ts']
+  FV ts -> liftM FV $ mapM exp ts
+  _ -> return t
+ where
+   alls = allParamValues gr
+   exp  = expandLinTables gr
+   comp = ccompute gr []
+
+-- from records, one can get to records of tables of strings
+
+rec2strTables :: Term -> Err [[(Label,[([Patt],[Str])])]]
+rec2strTables r = do
+  vs <- allLinValues r
+  mapM (mapPairsM (mapPairsM strsFromTerm)) vs
+
+-- from these tables, one may want to extract the ones for the "s" label
+
+strTables2sTables :: [[(Label,[([Patt],[Str])])]] -> [[([Patt],[Str])]]
+strTables2sTables ts = [t | r <- ts, (l,t) <- r, l == linLab0]
+
+linLab0 :: Label
+linLab0 = L (identC "s")
+
+-- to get lists of token lists is easy
+sTables2strs :: [[([Patt],[Str])]] -> [[Str]]
+sTables2strs = map snd . concat
+
+-- from this, to get a list of strings --- customize unlexer
+strs2strings :: [[Str]] -> [String]
+strs2strings = map unlex
+
+-- finally, a top-level function to get a string from an expression
+linTree2string :: CanonGrammar -> Ident -> A.Tree -> String
+linTree2string gr m e = err id id $ do
+  t  <- linearizeNoMark gr m e
+  r  <- expandLinTables gr t
+  ts <- rec2strTables r
+  let ss = strs2strings $ sTables2strs $ strTables2sTables ts
+  ifNull (prtBad "empty linearization of" e) (return . head) ss
+
+
+-- argument is a Tree, value is a list of strs; needed in Parsing
+
+allLinsOfTree :: CanonGrammar -> Ident -> A.Tree -> [Str]
+allLinsOfTree gr a e = err (singleton . str) id $ do
+  e' <- return e ---- annotateExp gr e
+  r  <- linearizeNoMark gr a e'
+  r' <- expandLinTables gr r
+  ts <- rec2strTables r'
+  return $ concat $ sTables2strs $ strTables2sTables ts
+
+{-
+-- the value is a list of strs
+allLinStrings :: CanonGrammar -> Tree -> [Str]
+allLinStrings gr ft = case allLinsAsStrs gr ft of
+  Ok ts -> map snd $ concat $ map snd $ concat ts
+  Bad s -> [str s]
+
+-- the value is a list of strs, not forgetting their arguments
+allLinsAsStrs :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Str)])]]
+allLinsAsStrs gr ft = do
+  lpts <- allLinearizations gr ft
+  return $ concat $ mapM (mapPairsM (mapPairsM strsFromTerm)) lpts
+
+-- the value is a list of terms of type Str, not forgetting their arguments
+allLinearizations :: CanonGrammar -> Tree -> Err [[(Label,[([Patt],Term)])]]
+allLinearizations gr ft = linearizeTree gr ft >>= allLinValues
+
+-- to a list of strings
+linearizeToStrings :: CanonGrammar -> ([Int] ->Term -> Term) -> Tree -> Err [String]
+linearizeToStrings gr mk = liftM (map unlex) . linearizeToStrss gr mk
+
+-- to a list of token lists
+linearizeToStrss :: CanonGrammar -> ([Int] -> Term -> Term) -> Tree -> Err [[Str]]
+linearizeToStrss gr mk e = do
+  R rs <- linearizeToRecord gr mk e ----
+  t <- lookupErr linLab0 [(r,s) | Ass r s <- rs]
+  return $ map strsFromTerm $ allInTable t 
+  
+
+-- the value is a list of strings, not forgetting their arguments
+allLinsOfFun :: CanonGrammar -> CIdent -> Err [[(Label,[([Patt],Term)])]]
+allLinsOfFun gr f = do
+  t <- lookupLin gr f 
+  allLinValues t
+
+
+
+-}
+
+
+
+
+{- ----
+-- returns printname if one exists; otherwise linearizes with metas
+printOrLinearize :: CanonGrammar -> Fun -> String
+printOrLinearize gr f = 
+{- ----
+ errVal (prtt f) $ case lookupPrintname cnc f of
+  Ok s -> return s
+  _ -> -} 
+ 
+          unlines $ take 1 $ err singleton id $ 
+       do
+    t  <- lookupFunType gr f
+    f' <- ref2exp [] t (AC f) --- []
+    lin f'
+ where 
+   lin = linearizeToStrings gr (const id) ----
+-}