Merge branch 'master' into c-runtime

gf.cabal

@@ -122,7 +122,6 @@ executable gf
     GF.Command.TreeOperations
     GF.Compile.CFGtoPGF
     GF.Compile.CheckGrammar
-    GF.Compile.Compute.AppPredefined
     GF.Compile.Compute.ConcreteNew
     GF.Compile.Compute.Predef
     GF.Compile.Compute.Value

src/compiler/GF/Compile/CheckGrammar.hs

@@ -269,7 +269,7 @@ checkInfo opts cwd sgr (m,mo) c info = checkInModule cwd mo NoLoc empty $ do
    chIn loc cat = checkInModule cwd mo loc ("Happened in" <+> cat <+> c)
 
    mkPar (f,co) = do
-       vs <- liftM combinations $ mapM (\(_,_,ty) -> allParamValues gr ty) co
+       vs <- liftM sequence $ mapM (\(_,_,ty) -> allParamValues gr ty) co
        return $ map (mkApp (QC (m,f))) vs
 
    checkUniq xss = case xss of

src/compiler/GF/Compile/Compute/AppPredefined.hs

@@ -1,143 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : AppPredefined
--- Maintainer  : AR
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/10/06 14:21:34 $ 
--- > CVS $Author: aarne $
--- > CVS $Revision: 1.13 $
---
--- Predefined function type signatures and definitions.
------------------------------------------------------------------------------
-
-module GF.Compile.Compute.AppPredefined ({-
-          isInPredefined, typPredefined, arrityPredefined, predefModInfo, appPredefined-}
-		  ) where
-{-
-import GF.Compile.TypeCheck.Primitives
-import GF.Infra.Option
-import GF.Data.Operations
-import GF.Grammar
-import GF.Grammar.Predef
-
-import qualified Data.Map as Map
-import GF.Text.Pretty
-import Data.Char (isUpper,toUpper,toLower)
-
--- predefined function type signatures and definitions. AR 12/3/2003.
-
-isInPredefined :: Ident -> Bool
-isInPredefined f = Map.member f primitives
-
-arrityPredefined :: Ident -> Maybe Int
-arrityPredefined f = do ty <- typPredefined f
-                        let (ctxt,_) = typeFormCnc ty
-                        return (length ctxt)
-
-predefModInfo :: SourceModInfo
-predefModInfo = ModInfo MTResource MSComplete noOptions [] Nothing [] [] "Predef.gf" Nothing primitives
-
-appPredefined :: Term -> Err (Term,Bool)
-appPredefined t = case t of
-  App f x0 -> do
-   (x,_) <- appPredefined x0
-   case f of
-    -- one-place functions
-    Q (mod,f) | mod == cPredef ->
-      case x of
-        (K s) | f == cLength  -> retb $ EInt $ length s
-        (K s) | f == cIsUpper -> retb $ if (all isUpper s) then predefTrue else predefFalse
-        (K s) | f == cToUpper -> retb $ K $ map toUpper s
-        (K s) | f == cToLower -> retb $ K $ map toLower s
-        (K s) | f == cError   -> retb $ Error s
-
-        _                    -> retb t
-
-    -- two-place functions
-    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 i s)
-      (EInt i, K s)    | f == cTake    -> retb $ K (take i s)
-      (EInt i, K s)    | f == cTk      -> retb $ K (take (max 0 (length s - i)) s)
-      (EInt i, K s)    | f == cDp      -> retb $ K (drop (max 0 (length s - i)) s)
-      (K s,    K t)    | f == cEqStr   -> retb $ if s == t then predefTrue else predefFalse
-      (K s,    K t)    | f == cOccur   -> retb $ if substring s t then predefTrue else predefFalse
-      (K s,    K t)    | f == cOccurs  -> retb $ if any (flip elem t) s then predefTrue else predefFalse
-      (EInt i, EInt j) | f == cEqInt   -> retb $ if i==j then predefTrue else predefFalse
-      (EInt i, EInt j) | f == cLessInt -> retb $ if i<j  then predefTrue else predefFalse
-      (EInt i, EInt j) | f == cPlus    -> retb $ EInt $ i+j
-      (_,      t)      | f == cShow  && notVar t  -> retb $ foldrC $ map K $ words $ render (ppTerm Unqualified 0 t)
-      (_,      K s)    | f == cRead    -> retb $ Cn (identS s) --- because of K, only works for atomic tags
-      (_,      t)      | f == cToStr   -> trm2str t >>= retb
-      _ -> retb t ---- prtBad "cannot compute predefined" t
-
-    -- three-place functions
-    App (App (Q (mod,f)) z0) y0 | mod == cPredef -> do
-     (y,_) <- appPredefined y0
-     (z,_) <- appPredefined z0
-     case (z, y, x) of
-       (ty,op,t) | f == cMapStr -> retf $ mapStr ty op t
-       _ | f == cEqVal && notVar y && notVar x -> retb $ if y==x then predefTrue else predefFalse
-       _ -> retb t ---- prtBad "cannot compute predefined" t
-
-    _ -> retb t ---- prtBad "cannot compute predefined" t
-  _ -> retb t
-                  ---- should really check the absence of arg variables
- where
-   retb t = return (retc t,True)  -- no further computing needed
-   retf t = return (retc t,False) -- must be computed further
-   retc t = case t of
-     K [] -> t
-     K s  -> foldr1 C (map K (words s))
-     _    -> t
-   norm t = case t of
-     Empty -> K []
-     C u v -> case (norm u,norm v) of
-       (K x,K y) -> K (x +++ y)
-       _ -> t
-     _ -> t
-   notVar t = case t of
-     Vr _ -> False
-     App f a -> notVar f && notVar a
-     _ -> True ---- would need to check that t is a value
-   foldrC ts = if null ts then Empty else foldr1 C ts
-
--- read makes variables into constants
-
-predefTrue = QC (cPredef,cPTrue)
-predefFalse = QC (cPredef,cPFalse)
-
-substring :: String -> String -> Bool
-substring s t = case (s,t) of
-  (c:cs, d:ds) -> (c == d && substring cs ds) || substring s ds
-  ([],_) -> True
-  _ -> False
-
-trm2str :: Term -> Err Term
-trm2str t = case t of
-  R ((_,(_,s)):_) -> trm2str s
-  T _ ((_,s):_)   -> trm2str s
-  V _ (s:_)       -> trm2str s
-  C _ _           -> return $ t
-  K _             -> return $ t
-  S c _           -> trm2str c
-  Empty           -> return $ t
-  _               -> Bad (render (text "cannot get Str from term" <+> ppTerm Unqualified 0 t))
-
--- simultaneous recursion on type and term: type arg is essential!
--- But simplify the task by assuming records are type-annotated
--- (this has been done in type checking)
-mapStr :: Type -> Term -> Term -> Term
-mapStr ty f t = case (ty,t) of
-  _ | elem ty [typeStr,typeTok] -> App f t
-  (_,        R ts)    -> R [(l,mapField v)   | (l,v) <- ts]
-  (Table a b,T ti cs) -> T ti [(p,mapStr b f v) | (p,v) <- cs]
-  _    -> t 
- where
-   mapField (mty,te) = case mty of
-     Just ty -> (mty,mapStr ty f te)
-     _ -> (mty,te)
--}

src/compiler/GF/Compile/Compute/ConcreteNew.hs

@@ -14,7 +14,7 @@ import GF.Grammar.Lockfield(isLockLabel,lockRecType) --unlockRecord,lockLabel
 import GF.Compile.Compute.Value hiding (Error)
 import GF.Compile.Compute.Predef(predef,predefName,delta)
 import GF.Data.Str(Str,glueStr,str2strings,str,sstr,plusStr,strTok)
-import GF.Data.Operations(Err,err,errIn,maybeErr,combinations,mapPairsM)
+import GF.Data.Operations(Err,err,errIn,maybeErr,mapPairsM)
 import GF.Data.Utilities(mapFst,mapSnd)
 import GF.Infra.Option
 import Control.Monad(ap,liftM,liftM2) -- ,unless,mplus
@@ -317,7 +317,7 @@ strsFromValue t = case t of
     return [strTok (str2strings def) vars | 
               def  <- d0,
               vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
-                                                          vv <- combinations v0]
+                                                          vv <- sequence v0]
            ]
   VFV ts -> concat # mapM strsFromValue ts
   VStrs ts -> concat # mapM strsFromValue ts

src/compiler/GF/Compile/Update.hs

@@ -109,8 +109,9 @@ rebuildModule cwd gr mo@(i,mi@(ModInfo mt stat fs_ me mw ops_ med_ msrc_ env_ js
     -- add the instance opens to an incomplete module "with" instances
     Just (ext,incl,ops) -> do
       let (infs,insts) = unzip ops
-      let stat' = ifNull MSComplete (const MSIncomplete)
+      let stat' = if all (flip elem infs) is
-                    [i | i <- is, notElem i infs]
+                    then MSComplete
+                    else MSIncomplete
       unless (stat' == MSComplete || stat == MSIncomplete) 
              (checkError ("module" <+> i <+> "remains incomplete"))
       ModInfo mt0 _ fs me' _ ops0 _ fpath _ js <- lookupModule gr ext

src/compiler/GF/CompileInParallel.hs

@@ -80,7 +80,7 @@ batchCompile1 lib_dir (opts,filepaths) =
      let rel = relativeTo lib_dir cwd
          prelude_dir = lib_dir</>"prelude"
          gfoDir = flag optGFODir opts
-     maybe done (D.createDirectoryIfMissing True) gfoDir
+     maybe (return ()) (D.createDirectoryIfMissing True) gfoDir
 {-
      liftIO $ writeFile (maybe "" id gfoDir</>"paths")
                         (unlines . map (unwords . map rel) . nub $ map snd filepaths)
@@ -238,14 +238,14 @@ instance (Functor m,Monad m) => Applicative (CollectOutput m) where
   (<*>) = ap
 
 instance Monad m => Monad (CollectOutput m) where
-  return x = CO (return (done,x))
+  return x = CO (return (return (),x))
   CO m >>= f = CO $ do (o1,x) <- m
                        let CO m2 = f x
                        (o2,y) <- m2
                        return (o1>>o2,y)
 instance MonadIO m => MonadIO (CollectOutput m) where
   liftIO io = CO $ do x <- liftIO io
-                      return (done,x)
+                      return (return (),x)
 
 instance Output m => Output (CollectOutput m) where
   ePutStr   s = CO (return (ePutStr s,()))

src/compiler/GF/CompileOne.hs

@@ -21,7 +21,7 @@ import GF.Grammar.Binary(decodeModule,encodeModule)
 import GF.Infra.Option
 import GF.Infra.UseIO(FullPath,IOE,isGFO,gf2gfo,MonadIO(..),Output(..),putPointE)
 import GF.Infra.CheckM(runCheck')
-import GF.Data.Operations(ErrorMonad,liftErr,(+++),done)
+import GF.Data.Operations(ErrorMonad,liftErr,(+++))
 
 import GF.System.Directory(doesFileExist,getCurrentDirectory,renameFile)
 import System.FilePath(makeRelative)
@@ -66,7 +66,7 @@ reuseGFO opts srcgr file =
 
      if flag optTagsOnly opts
        then writeTags opts srcgr (gf2gftags opts file) sm1
-       else done
+       else return ()
 
      return (Just file,sm)
 
@@ -137,7 +137,7 @@ compileSourceModule opts cwd mb_gfFile gr =
            idump opts pass (dump out)
            return (ret out)
 
-    maybeM f = maybe done f
+    maybeM f = maybe (return ()) f
 
 
 --writeGFO :: Options -> InitPath -> FilePath -> SourceModule -> IOE ()
@@ -158,12 +158,12 @@ writeGFO opts cwd file mo =
 --intermOut :: Options -> Dump -> Doc -> IOE ()
 intermOut opts d doc
   | dump opts d = ePutStrLn (render ("\n\n--#" <+> show d $$ doc))
-  | otherwise   = done
+  | otherwise   = return ()
 
 idump opts pass = intermOut opts (Dump pass) . ppModule Internal
 
 warnOut opts warnings
-  | null warnings = done
+  | null warnings = return ()
   | otherwise     = do t <- getTermColors
                        ePutStr (blueFg t);ePutStr ws;ePutStrLn (restore t)
   where

src/compiler/GF/Data/Operations.hs

@@ -26,8 +26,8 @@ module GF.Data.Operations (
 		   -- ** Checking
 		   checkUnique, unifyMaybeBy, unifyMaybe,
 
-                   -- ** Monadic operations on lists and pairs
+           -- ** Monadic operations on lists and pairs
-		   mapPairListM, mapPairsM, pairM,
+		   mapPairsM, pairM,
  
 		   -- ** Printing
 		   indent, (+++), (++-), (++++), (+++-), (+++++),
@@ -39,8 +39,7 @@ module GF.Data.Operations (
 		   topoTest, topoTest2,
 
 		   -- ** Misc
-		   ifNull,
+		   readIntArg,
-		   combinations, done, readIntArg, --singleton,
 		   iterFix,  chunks,
                 
 		  ) where
@@ -60,9 +59,6 @@ infixr 5 ++-
 infixr 5 ++++
 infixr 5 +++++
 
-ifNull :: b -> ([a] -> b) -> [a] -> b
-ifNull b f xs = if null xs then b else f xs
-
 -- the Error monad
 
 -- | Add msg s to 'Maybe' failures
@@ -70,7 +66,7 @@ maybeErr :: ErrorMonad m => String -> Maybe a -> m a
 maybeErr s = maybe (raise s) return
 
 testErr :: ErrorMonad m => Bool -> String -> m ()
-testErr cond msg = if cond then done else raise msg
+testErr cond msg = if cond then return () else raise msg
 
 errIn :: ErrorMonad m => String -> m a -> m a
 errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
@@ -78,9 +74,6 @@ errIn msg m = handle m (\s -> raise (s ++++ "OCCURRED IN" ++++ msg))
 lookupErr :: (ErrorMonad m,Eq a,Show a) => a -> [(a,b)] -> m b
 lookupErr a abs = maybeErr ("Unknown" +++ show a) (lookup a abs)
 
-mapPairListM :: Monad m => ((a,b) -> m c) -> [(a,b)] -> m [(a,c)]
-mapPairListM f xys = mapM (\ p@(x,_) -> liftM ((,) x) (f p)) xys
-
 mapPairsM :: Monad m => (b -> m c) -> [(a,b)] -> m [(a,c)]
 mapPairsM f xys = mapM (\ (x,y) -> liftM ((,) x) (f y)) xys
 
@@ -193,21 +186,6 @@ wrapLines n s@(c:cs) =
                      l = length w
             _ -> s -- give up!!
 
---- optWrapLines = if argFlag "wraplines" True then wrapLines 0 else id
-
--- | 'combinations' is the same as 'sequence'!!!
--- peb 30\/5-04
-combinations :: [[a]] -> [[a]]
-combinations t = case t of 
-  []    -> [[]]
-  aa:uu -> [a:u | a <- aa, u <- combinations uu]
-
-{-
--- | 'singleton' is the same as 'return'!!!
-singleton :: a -> [a]
-singleton = (:[])
--}
-
 -- | Topological sorting with test of cyclicity
 topoTest :: Ord a => [(a,[a])] -> Either [a] [[a]]
 topoTest = topologicalSort . mkRel'
@@ -247,10 +225,6 @@ chunks sep ws = case span (/= sep) ws of
 readIntArg :: String -> Int
 readIntArg n = if (not (null n) && all isDigit n) then read n else 0
 
--- | @return ()@
-done :: Monad m => m ()
-done = return ()
-
 class (Functor m,Monad m) => ErrorMonad m where
   raise   :: String -> m a
   handle  :: m a -> (String -> m a) -> m a

src/compiler/GF/Grammar/Lookup.hs

@@ -166,11 +166,11 @@ allParamValues cnc ptyp =
     RecType r -> do
        let (ls,tys) = unzip $ sortByFst r
        tss <- mapM (allParamValues cnc) tys
-       return [R (zipAssign ls ts) | ts <- combinations tss]
+       return [R (zipAssign ls ts) | ts <- sequence tss]
     Table pt vt -> do
        pvs <- allParamValues cnc pt
        vvs <- allParamValues cnc vt
-       return [V pt ts | ts <- combinations (replicate (length pvs) vvs)]
+       return [V pt ts | ts <- sequence (replicate (length pvs) vvs)]
     _ -> raise (render ("cannot find parameter values for" <+> ptyp))
   where
     -- to normalize records and record types

src/compiler/GF/Grammar/Macros.hs

@@ -554,16 +554,12 @@ strsFromTerm t = case t of
     return [strTok (str2strings def) vars | 
               def  <- d0,
               vars <- [[(str2strings v, map sstr c) | (v,c) <- zip vv c0] | 
-                                                          vv <- combinations v0]
+                                                          vv <- sequence v0]
            ]
   FV ts -> mapM strsFromTerm ts >>= return . concat
   Strs ts -> mapM strsFromTerm ts >>= return . concat  
   _ -> raise (render ("cannot get Str from term" <+> ppTerm Unqualified 0 t))
 
--- | to print an Str-denoting term as a string; if the term is of wrong type, the error msg
-stringFromTerm :: Term -> String
-stringFromTerm = err id (ifNull "" (sstr . head)) . strsFromTerm
-
 getTableType :: TInfo -> Err Type
 getTableType i = case i of
   TTyped ty -> return ty

src/compiler/GF/Interactive.hs

@@ -12,7 +12,7 @@ import GF.Command.CommandInfo
 import GF.Command.Help(helpCommand)
 import GF.Command.Abstract
 import GF.Command.Parse(readCommandLine,pCommand)
-import GF.Data.Operations (Err(..),done)
+import GF.Data.Operations (Err(..))
 import GF.Data.Utilities(whenM,repeatM)
 import GF.Grammar hiding (Ident,isPrefixOf)
 import GF.Infra.UseIO(ioErrorText,putStrLnE)
@@ -159,7 +159,7 @@ execute1' s0 =
       do execute . lines =<< lift (restricted (readFile w))
          continue
       where
-        execute [] = done
+        execute []           = return ()
         execute (line:lines) = whenM (execute1' line) (execute lines)
 
     execute_history _   =
@@ -285,8 +285,8 @@ importInEnv opts files =
          if (verbAtLeast opts Normal)
            then case pgf1 of
                   Just pgf -> putStrLnFlush $ unwords $ "\nLanguages:" : Map.keys (languages pgf)
-                  Nothing  -> done
+                  Nothing  -> return ()
-           else done
+           else return ()
          return pgf1
 
 tryGetLine = do