refactoring in GF.Grammar.Grammar

3 files changed, 49 insertions, 49 deletions

diff --git a/src/compiler/GF/Compile/Concrete/AppPredefined.hs b/src/compiler/GF/Compile/Concrete/AppPredefined.hs
index c05127191..73355381e 100644
--- a/src/compiler/GF/Compile/Concrete/AppPredefined.hs
+++ b/src/compiler/GF/Compile/Concrete/AppPredefined.hs
@@ -71,13 +71,13 @@ appPredefined t = case t of
    (x,_) <- appPredefined x0
    case f of
     -- one-place functions
-    Q mod f | mod == cPredef ->
+    Q (mod,f) | mod == cPredef ->
       case x of
         (K s) | f == cLength -> retb $ EInt $ toInteger $ length s
         _                    -> retb t
 
     -- two-place functions
-    App (Q mod f) z0 | mod == cPredef -> do
+    App (Q (mod,f)) z0 | mod == cPredef -> do
      (z,_) <- appPredefined z0
      case (norm z, norm x) of
       (EInt i, K s)    | f == cDrop    -> retb $ K (drop (fi i) s)
@@ -96,7 +96,7 @@ appPredefined t = case t of
       _ -> retb t ---- prtBad "cannot compute predefined" t
 
     -- three-place functions
-    App (App (Q mod f) z0) y0 | mod == cPredef -> do
+    App (App (Q (mod,f)) z0) y0 | mod == cPredef -> do
      (y,_) <- appPredefined y0
      (z,_) <- appPredefined z0
      case (z, y, x) of
@@ -123,8 +123,8 @@ appPredefined t = case t of
 
 -- read makes variables into constants
 
-predefTrue = QC cPredef cPTrue
-predefFalse = QC cPredef cPFalse
+predefTrue = QC (cPredef,cPTrue)
+predefFalse = QC (cPredef,cPFalse)
 
 substring :: String -> String -> Bool
 substring s t = case (s,t) of
diff --git a/src/compiler/GF/Compile/Concrete/Compute.hs b/src/compiler/GF/Compile/Concrete/Compute.hs
index 44a6bfad1..ce76479a6 100644
--- a/src/compiler/GF/Compile/Concrete/Compute.hs
+++ b/src/compiler/GF/Compile/Concrete/Compute.hs
@@ -52,8 +52,8 @@ computeTermOpt rec gr = comput True where
    comput full g t = ---- errIn ("subterm" +++ prt t) $ --- for debugging 
               case t of
 
-     Q p c | p == cPredef -> return t
-           | otherwise    -> look p c 
+     Q (p,c) | p == cPredef -> return t
+             | otherwise    -> look (p,c) 
 
      Vr x -> do
        t' <- maybe (Bad (render (text "no value given to variable" <+> ppIdent x))) return $ lookup x g
@@ -86,9 +86,9 @@ computeTermOpt rec gr = comput True where
         as' <- mapM (comp g) as
         case h' of
           _ | not (null [() | FV _ <- as']) -> compApp g (mkApp h' as')
-          c@(QC _ _) -> do
+          c@(QC _) -> do
             return $ mkApp c as'
-          Q mod f | mod == cPredef -> do     
+          Q (mod,f) | mod == cPredef -> do     
             (t',b) <- appPredefined (mkApp h' as')
             if b then return t' else comp g t'
 
@@ -163,11 +163,11 @@ computeTermOpt rec gr = comput True where
          (_,Empty)         -> return x
          (Empty,_)         -> return y
          (K a, K b)        -> return $ K (a ++ b)
-         (_, Alts (d,vs)) -> do
+         (_, Alts d vs)    -> do
 ----         (K a, Alts (d,vs)) -> do
             let glx = Glue x
-            comp g $ Alts (glx d, [(glx v,c) | (v,c) <- vs])
-         (Alts _, ka) -> checks [do
+            comp g $ Alts (glx d) [(glx v,c) | (v,c) <- vs]
+         (Alts _ _, ka) -> checks [do
             y' <- strsFromTerm ka
 ----         (Alts _, K a) -> checks [do
             x' <- strsFromTerm x -- this may fail when compiling opers
@@ -183,17 +183,17 @@ computeTermOpt rec gr = comput True where
            r <- composOp (comp g) t
            returnC r
 
-     Alts (d,aa) -> do
+     Alts d aa -> do
        d' <- comp g d
        aa' <- mapM (compInAlts g) aa
-       returnC (Alts (d',aa'))
+       returnC (Alts d' aa')
 
      -- remove empty
      C a b    -> do
        a' <- comp g a
        b' <- comp g b
        case (a',b') of
-         (Alts _, K a) -> checks [do
+         (Alts _ _, K a) -> checks [do
             as <- strsFromTerm a' -- this may fail when compiling opers
             return $ variants [
               foldr1 C (map K (str2strings (plusStr v (str a)))) | v <- as]
@@ -238,7 +238,7 @@ computeTermOpt rec gr = comput True where
          (FV fs, _)  -> mapM (\c -> comp g (App c a')) fs >>= return . variants
          (Abs _ x b,_) -> comp (ext x a' g) b
 
-         (QC _ _,_)  -> returnC $ App f' a'
+         (QC _,_)  -> returnC $ App f' a'
 
          (S (T i cs) e,_) -> prawitz g i (flip App a') cs e
          (S (V i cs) e,_) -> prawitzV g i (flip App a') cs e
@@ -250,9 +250,9 @@ computeTermOpt rec gr = comput True where
      hnf  = comput False
      comp = comput True
 
-     look p c
-       | rec       = lookupResDef gr p c >>= comp []
-       | otherwise = lookupResDef gr p c
+     look c
+       | rec       = lookupResDef gr c >>= comp []
+       | otherwise = lookupResDef gr c
 
      ext x a g = (x,a):g
 
@@ -264,13 +264,13 @@ computeTermOpt rec gr = comput True where
 
      isCan v = case v of
        Con _    -> True
-       QC _ _   -> True
+       QC _     -> True
        App f a  -> isCan f && isCan a
        R rs     -> all (isCan . snd . snd) rs
        _        -> False
 
      compPatternMacro p = case p of
-       PM m c -> case look m c of
+       PM c -> case look c of
          Ok (EPatt p') -> compPatternMacro p'
          _ -> Bad (render (text "pattern expected as value of" $$ nest 2 (ppPatt Unqualified 0 p)))
        PAs x p -> do
@@ -384,7 +384,7 @@ computeTermOpt rec gr = comput True where
      contP p = case p of
        PV x -> [(x,Vr x)]
        PC _ ps -> concatMap contP ps
-       PP _ _ ps -> concatMap contP ps
+       PP _ ps -> concatMap contP ps
        PT _ p -> contP p
        PR rs -> concatMap (contP . snd) rs
 
diff --git a/src/compiler/GF/Compile/Concrete/TypeCheck.hs b/src/compiler/GF/Compile/Concrete/TypeCheck.hs
index eafa0dbd7..04674103f 100644
--- a/src/compiler/GF/Compile/Concrete/TypeCheck.hs
+++ b/src/compiler/GF/Compile/Concrete/TypeCheck.hs
@@ -23,8 +23,8 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
     _ | Just _ <- isTypeInts ty -> return ty ---- shouldn't be needed
       | isPredefConstant ty     -> return ty ---- shouldn't be needed
 
-    Q m ident -> checkIn (text "module" <+> ppIdent m) $ do
-      ty' <- checkErr (lookupResDef gr m ident) 
+    Q (m,ident) -> checkIn (text "module" <+> ppIdent m) $ do
+      ty' <- checkErr (lookupResDef gr (m,ident)) 
       if ty' == ty then return ty else comp g ty' --- is this necessary to test?
 
     Vr ident  -> checkLookup ident g -- never needed to compute!
@@ -70,22 +70,22 @@ computeLType gr g0 t = comp (reverse [(b,x, Vr x) | (b,x,_) <- g0] ++ g0) t
 inferLType :: SourceGrammar -> Context -> Term -> Check (Term, Type)
 inferLType gr g trm = case trm of
 
-   Q m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
+   Q (m,ident) | isPredef m -> termWith trm $ checkErr (typPredefined ident)
 
-   Q m ident -> checks [
-     termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g
+   Q ident -> checks [
+     termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
      ,
-     checkErr (lookupResDef gr m ident) >>= inferLType gr g
+     checkErr (lookupResDef gr ident) >>= inferLType gr g
      ,
      checkError (text "cannot infer type of constant" <+> ppTerm Unqualified 0 trm)
      ]
 
-   QC m ident | isPredef m -> termWith trm $ checkErr (typPredefined ident)
+   QC (m,ident) | isPredef m -> termWith trm $ checkErr (typPredefined ident)
 
-   QC m ident -> checks [
-       termWith trm $ checkErr (lookupResType gr m ident) >>= computeLType gr g
+   QC ident -> checks [
+       termWith trm $ checkErr (lookupResType gr ident) >>= computeLType gr g
        ,
-       checkErr (lookupResDef gr m ident) >>= inferLType gr g
+       checkErr (lookupResDef gr ident) >>= inferLType gr g
        ,
        checkError (text "cannot infer type of canonical constant" <+> ppTerm Unqualified 0 trm)
        ]
@@ -188,13 +188,13 @@ inferLType gr g trm = case trm of
      ts' <- mapM (\t -> justCheck g t typeStr) ts 
      return (Strs ts', typeStrs)
 
-   Alts (t,aa) -> do
+   Alts t aa -> do
      t'  <- justCheck g t typeStr
      aa' <- flip mapM aa (\ (c,v) -> do
         c' <- justCheck g c typeStr 
         v' <- checks $ map (justCheck g v) [typeStrs, EPattType typeStr]
         return (c',v'))
-     return (Alts (t',aa'), typeStr)
+     return (Alts t' aa', typeStr)
 
    RecType r -> do
      let (ls,ts) = unzip r
@@ -267,7 +267,7 @@ inferLType gr g trm = case trm of
      return (arg,val)
    isConstPatt p = case p of
      PC _ ps -> True --- all isConstPatt ps
-     PP _ _ ps -> True --- all isConstPatt ps
+     PP _ ps -> True --- all isConstPatt ps
      PR ps -> all (isConstPatt . snd) ps
      PT _ p -> isConstPatt p
      PString _ -> True
@@ -283,7 +283,7 @@ inferLType gr g trm = case trm of
      _ -> False
 
    inferPatt p = case p of
-     PP q c ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr q c)
+     PP (q,c) ps | q /= cPredef -> checkErr $ liftM valTypeCnc (lookupResType gr (q,c))
      PAs _ p  -> inferPatt p
      PNeg p   -> inferPatt p
      PAlt p q -> checks [inferPatt p, inferPatt q]
@@ -298,7 +298,7 @@ inferLType gr g trm = case trm of
 -- the latter permits matching with value type
 getOverload :: SourceGrammar -> Context -> Maybe Type -> Term -> Check (Maybe (Term,Type))
 getOverload gr g mt ot = case appForm ot of
-     (f@(Q m c), ts) -> case lookupOverload gr m c of
+     (f@(Q c), ts) -> case lookupOverload gr c of
        Ok typs -> do
          ttys <- mapM (inferLType gr g) ts
          v <- matchOverload f typs ttys
@@ -390,7 +390,7 @@ checkLType gr g trm typ0 = do
           (trm',ty') <- inferLType gr g trm
           termWith trm' $ checkEqLType gr g typ ty' trm'
 
-    Q _ _ -> do
+    Q _ -> do
        over <- getOverload gr g (Just typ) trm
        case over of
          Just trty -> return trty
@@ -522,8 +522,8 @@ checkLType gr g trm typ0 = do
 pattContext :: SourceGrammar -> Context -> Type -> Patt -> Check Context
 pattContext env g typ p = case p of
   PV x -> return [(Explicit,x,typ)]
-  PP q c ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
-    t <- checkErr $ lookupResType env q c
+  PP (q,c) ps | q /= cPredef -> do ---- why this /=? AR 6/1/2006
+    t <- checkErr $ lookupResType env (q,c)
     let (cont,v) = typeFormCnc t
     checkCond (text "wrong number of arguments for constructor in" <+> ppPatt Unqualified 0 p) 
               (length cont == length ps)
@@ -617,15 +617,15 @@ checkIfEqLType gr g t u trm = do
            | t == typeInt,           Just _ <- isTypeInts u -> True ---- why this ???? AR 11/12/2005
 
      ---- this should be made in Rename
-     (Q  m a, Q  n b) | a == b -> elem m (allExtendsPlus gr n) 
-                               || elem n (allExtendsPlus gr m)
-                               || m == n --- for Predef
-     (QC m a, QC n b) | a == b -> elem m (allExtendsPlus gr n) 
-                               || elem n (allExtendsPlus gr m)
-     (QC m a, Q  n b) | a == b -> elem m (allExtendsPlus gr n) 
-                               || elem n (allExtendsPlus gr m)
-     (Q  m a, QC n b) | a == b -> elem m (allExtendsPlus gr n) 
-                               || elem n (allExtendsPlus gr m)
+     (Q  (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+                                   || elem n (allExtendsPlus gr m)
+                                   || m == n --- for Predef
+     (QC (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+                                   || elem n (allExtendsPlus gr m)
+     (QC (m,a), Q  (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+                                   || elem n (allExtendsPlus gr m)
+     (Q  (m,a), QC (n,b)) | a == b -> elem m (allExtendsPlus gr n) 
+                                   || elem n (allExtendsPlus gr m)
 
      (Table a b,  Table c d)  -> alpha g a c && alpha g b d
      (Vr x,       Vr y)       -> x == y || elem (x,y) g || elem (y,x) g