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

1 files changed, 225 insertions, 0 deletions

diff --git a/src-3.0/GF/Canon/Look.hs b/src-3.0/GF/Canon/Look.hs
new file mode 100644
index 000000000..a93d4c834
--- /dev/null
+++ b/src-3.0/GF/Canon/Look.hs
@@ -0,0 +1,225 @@
+----------------------------------------------------------------------
+-- |
+-- Module      : Look
+-- Maintainer  : AR
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/09/20 09:32:56 $ 
+-- > CVS $Author: aarne $
+-- > CVS $Revision: 1.17 $
+--
+-- lookup in GFC. AR 2003
+-----------------------------------------------------------------------------
+
+module GF.Canon.Look (lookupCncInfo,
+	     lookupLin,
+	     lookupLincat,
+	     lookupPrintname,
+	     lookupResInfo,
+	     lookupGlobal,
+	     lookupOptionsCan,
+	     lookupParamValues,
+	     allParamValues,
+	     ccompute
+	    ) where
+
+import GF.Canon.AbsGFC
+import GF.Canon.GFC
+import GF.Grammar.PrGrammar
+import GF.Canon.CMacros
+----import Values
+import GF.Grammar.MMacros
+import GF.Grammar.Macros (zIdent)
+import qualified GF.Infra.Modules as M
+import qualified GF.Canon.CanonToGrammar as CG
+
+import GF.Data.Operations
+import GF.Infra.Option
+
+import Control.Monad
+import Data.List
+
+-- linearization lookup
+
+lookupCncInfo :: CanonGrammar -> CIdent -> Err Info
+lookupCncInfo gr f@(CIQ m c) = do
+  mt <- M.lookupModule gr m
+  case mt of
+    M.ModMod a -> errIn ("module" +++ prt m) $ 
+                  lookupIdent c $ M.jments a 
+    _ -> prtBad "not concrete module" m
+
+lookupLin :: CanonGrammar -> CIdent -> Err Term
+lookupLin gr f = errIn "looking up linearization rule" $ do
+  info <- lookupCncInfo gr f
+  case info of
+    CncFun _ _ t _ -> return t
+    CncCat _ t _ -> return t
+    AnyInd _ n -> lookupLin gr $ redirectIdent n f
+
+lookupLincat :: CanonGrammar -> CIdent -> Err CType
+lookupLincat gr (CIQ _ c) | elem c [zIdent "String", zIdent "Int", zIdent "Float"] =
+  return defLinType --- ad hoc; not needed? cf. Grammar.Lookup.lookupLincat
+lookupLincat gr f = errIn "looking up linearization type" $ do
+  info <- lookupCncInfo gr f
+  case info of
+    CncCat t _ _ -> return t
+    AnyInd _ n -> lookupLincat gr $ redirectIdent n f
+    _ -> prtBad "no lincat found for" f
+
+lookupPrintname :: CanonGrammar -> CIdent -> Err Term
+lookupPrintname gr f = errIn "looking up printname" $ do
+  info <- lookupCncInfo gr f
+  case info of
+    CncFun _ _ _ t -> return t
+    CncCat _ _ t -> return t
+    AnyInd _ n -> lookupPrintname gr $ redirectIdent n f
+
+lookupResInfo :: CanonGrammar -> CIdent -> Err Info
+lookupResInfo gr f@(CIQ m c) = do
+  mt <- M.lookupModule gr m
+  case mt of
+    M.ModMod a -> lookupIdent c $ M.jments a 
+    _ -> prtBad "not resource module" m
+
+lookupGlobal :: CanonGrammar -> CIdent -> Err Term
+lookupGlobal gr f = do
+  info <- lookupResInfo gr f
+  case info of
+    ResOper _ t -> return t
+    AnyInd _ n -> lookupGlobal gr $ redirectIdent n f
+    _ -> prtBad "cannot find global" f
+
+lookupOptionsCan :: CanonGrammar -> Err Options
+lookupOptionsCan gr = do
+  let fs = M.allFlags gr
+  os <- mapM CG.redFlag fs
+  return $ options os
+
+lookupParamValues :: CanonGrammar -> CIdent -> Err [Term]
+lookupParamValues gr pt@(CIQ m _) = do
+  info <- lookupResInfo gr pt
+  case info of
+    ResPar ps -> liftM concat $ mapM mkPar ps
+    AnyInd _ n -> lookupParamValues gr $ redirectIdent n pt
+    _ -> prtBad "cannot find parameter type" pt
+ where
+   mkPar (ParD f co) = do
+     vs <- liftM combinations $ mapM (allParamValues gr) co
+     return $ map (Par (CIQ m f)) vs
+
+-- this is needed since param type can also be a record type
+
+allParamValues :: CanonGrammar -> CType -> Err [Term]
+allParamValues cnc ptyp = case ptyp of
+  Cn pc -> lookupParamValues cnc pc
+  RecType r -> do
+    let (ls,tys) = unzip [(l,t) | Lbg l t <- r]
+    tss <- mapM allPV tys
+    return [R (map (uncurry Ass) (zip ls ts)) | ts <- combinations tss]
+  TInts n -> return [EInt i | i <- [0..n]]
+  _ -> prtBad "cannot possibly find parameter values for" ptyp
+ where
+   allPV = allParamValues cnc
+
+-- runtime computation on GFC objects
+
+ccompute :: CanonGrammar -> [Term] -> Term -> Err Term
+ccompute cnc = vcomp
+ where
+
+  vcomp xs t = do
+    let xss = variations xs
+    ts <- mapM (\xx -> comp [] xx t) xss
+    return $ variants ts
+
+  variations xs = combinations [getVariants t | t <- xs]
+  variants ts = case ts of
+    [t] -> t
+    _ -> FV ts
+  getVariants t = case t of
+    FV ts -> ts
+    _ -> [t]
+
+  comp g xs t = case t of
+    Arg (A _ i)    -> err (const (return t)) return $ xs !? fromInteger i
+    Arg (AB _ _ i) -> err (const (return t)) return $ xs !? fromInteger i
+    I c     -> look c 
+    LI c    -> lookVar c g
+
+    -- short-cut computation of selections: compute the table only if needed
+    S u v   -> do
+      u' <- compt u
+      case u' of
+        T _ [Cas [PW] b] -> compt b  
+        T _ [Cas [PV x] b] -> do
+          v' <- compt v
+          comp ((x,v') : g) xs b  
+        T _ cs -> do
+          v' <- compt v
+          if noVar v' 
+             then matchPatt cs v' >>= compt
+             else return $ S u' v'
+        FV ccs -> do
+          v' <- compt v
+          mapM (\c -> compt (S c v')) ccs >>= return . FV
+
+        _      -> liftM (S u') $ compt v
+
+    P u l  -> do
+      u' <- compt u
+      case u' of
+        R rs -> maybe (Bad ("unknown label" +++ prt l +++ "in" +++ prt u'))
+                      return $ 
+                        lookup l [ (x,y) | Ass x y <- rs]
+        FV rrs -> do
+          mapM (\r -> compt (P r l)) rrs >>= return . FV
+
+        _    -> return $ P u' l
+    FV ts    -> liftM FV (mapM compt ts)
+    C E b    -> compt b
+    C a E    -> compt a
+    C a b    -> do
+      a' <- compt a
+      b' <- compt b
+      return $ case (a',b') of
+        (E,_) -> b'
+        (_,E) -> a'
+        _     -> C a' b'
+    R rs     -> liftM (R . map (uncurry Ass)) $ 
+                  mapPairsM compt [(l,r) | Ass l r <- rs]
+
+    -- only expand the table when the table is really needed: use expandLin
+    T ty rs -> liftM (T ty . map (uncurry Cas)) $ 
+                  mapPairsM compt [(l,r) | Cas l r <- rs]
+
+    V ptyp ts -> do
+      ts' <- mapM compt ts
+      vs0 <- allParamValues cnc ptyp
+      vs  <- mapM term2patt vs0
+      let cc = [Cas [p] u | (p,u) <- zip vs ts']
+      return $ T ptyp cc
+
+    Par c xs -> liftM (Par c) $ mapM compt xs
+
+    K (KS []) -> return E --- should not be needed
+
+    _        -> return t  
+   where
+     compt = comp g xs
+     look c = lookupGlobal cnc c >>= compt
+
+     lookVar c co = case lookup c co of
+       Just t -> return t
+       _ -> return $ LI c --- Bad $ "unknown local variable" +++ prt c --- 
+
+     noVar v = case v of
+       LI _ -> False
+       Arg _ -> False
+       R rs -> all noVar [t | Ass _ t <- rs]
+       Par _ ts -> all noVar ts
+       FV ts -> all noVar ts
+       S x y -> noVar x && noVar y
+       P t _ -> noVar t
+       _    -> True --- other cases that can be values to pattern match?