"Committed_by_peb"

src/GF/CF/CanonToCF.hs

@@ -5,16 +5,16 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/02/18 19:21:07 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.11 $
+-- > CVS $Revision: 1.12 $
 --
 -- AR 27\/1\/2000 -- 3\/12\/2001 -- 8\/6\/2003 
 -----------------------------------------------------------------------------
 
 module CanonToCF (canon2cf) where
 
-import Tracing -- peb 8/6-04
+import GF.System.Tracing -- peb 8/6-04
 
 import Operations
 import Option

src/GF/CF/ChartParser.hs

@@ -5,15 +5,16 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 13:54:24 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.6 $
+-- > CVS $Revision: 1.7 $
 --
 -- Bottom-up Kilbury chart parser from "Pure Functional Parsing", chapter 5.
 -- OBSOLETE -- should use new MCFG parsers instead 
 -----------------------------------------------------------------------------
 
-module ChartParser (chartParser) where
+module ChartParser {-# DEPRECATED "Use ParseCF instead" #-} 
+    (chartParser) where
 
 -- import Tracing
 -- import PrintParser

src/GF/Compile/NewRename.hs

@@ -1,13 +1,12 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : NewRename
 -- Maintainer  : AR
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/02/18 19:21:09 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.4 $
+-- > CVS $Revision: 1.5 $
 --
 -- AR 14\/5\/2003
 --

src/GF/Data/Assoc.hs

@@ -5,9 +5,9 @@
 -- Stability   : Stable
 -- Portability : Haskell 98
 --
--- > CVS $Date: 2005/03/21 14:17:39 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Association lists, or finite maps,
 -- including sets as maps with result type @()@.
@@ -16,18 +16,20 @@
 -----------------------------------------------------------------------------
 
 module GF.Data.Assoc ( Assoc,
-	       Set,
+		       Set,
-	       listAssoc,
+		       emptyAssoc,
-	       listSet,
+		       emptySet,
-	       accumAssoc,
+		       listAssoc,
-	       aAssocs,
+		       listSet,
-	       aElems,
+		       accumAssoc,
-	       assocMap,
+		       aAssocs,
-	       lookupAssoc,
+		       aElems,
-	       lookupWith,
+		       assocMap,
-	       (?),
+		       lookupAssoc,
-	       (?=)
+		       lookupWith,
-	     ) where
+		       (?),
+		       (?=)
+		     ) where
 
 import GF.Data.SortedList 
 
@@ -36,6 +38,9 @@ infixl 9 ?, ?=
 -- | a set is a finite map with empty values
 type Set a = Assoc a ()
 
+emptyAssoc :: Ord a => Assoc a b
+emptySet   :: Ord a => Set a
+
 -- | creating a finite map from a sorted key-value list 
 listAssoc   :: Ord a => SList (a, b) -> Assoc a b
 
@@ -78,6 +83,9 @@ lookupWith :: Ord a => b -> Assoc a b -> a -> b
 data Assoc a b = ANil | ANode (Assoc a b) a b (Assoc a b)
 		 deriving (Eq, Show)
 
+emptyAssoc = ANil
+emptySet   = emptyAssoc
+
 listAssoc as = assoc
   where (assoc, [])     = sl2bst (length as) as
 	sl2bst 0 xs     = (ANil, xs)

src/GF/Data/BacktrackM.hs

@@ -5,11 +5,11 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 14:17:39 $
+-- > CVS $Date: 2005/03/29 11:17:54 $
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
--- Backtracking state monad, with r/o environment
+-- Backtracking state monad, with r\/o environment
 -----------------------------------------------------------------------------
 
 

src/GF/Data/Operations.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/14 23:45:36 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
--- > CVS $Author: krijo $
+-- > CVS $Author: peb $
--- > CVS $Revision: 1.17 $
+-- > CVS $Revision: 1.18 $
 --
 -- some auxiliary GF operations. AR 19\/6\/1998 -- 6\/2\/2001
 --
@@ -56,7 +56,7 @@ module Operations (-- * misc functions
 		   sortByLongest, combinations, mkTextFile, initFilePath,
 
 		   -- * topological sorting with test of cyclicity
-		   topoTest, topoSort,
+		   topoTest, topoSort, cyclesIn,
 
 		   -- * the generic fix point iterator
 		   iterFix,
@@ -570,8 +570,7 @@ mkTextFile name = do
 initFilePath :: FilePath -> FilePath
 initFilePath f = reverse (dropWhile (/='/') (reverse f))
 
--- topological sorting with test of cyclicity
+-- | topological sorting with test of cyclicity
-
 topoTest :: Eq a => [(a,[a])] -> Either [a] [[a]]
 topoTest g = if length g' == length g then Left g' else Right (cyclesIn g ++[[]]) 
   where
@@ -591,7 +590,7 @@ cyclesIn deps = nubb $ clean $ filt $ iterFix findDep immediate where
   remdup [] = []
 
 
-
+-- | topological sorting 
 topoSort :: Eq a => [(a,[a])] -> [a]
 topoSort g = reverse $ tsort 0 [ffs | ffs@(f,_) <- g, inDeg f == 0] [] where
   tsort _ []     r = r

src/GF/Parsing/CFGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:43 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Definitions of context-free grammars,
 -- parser information and chart conversion
@@ -27,7 +27,7 @@ module GF.Parsing.CFGrammar
      checkGrammar
     ) where
 
-import Tracing 
+import GF.System.Tracing 
 
 -- haskell modules:
 import Array 

src/GF/Parsing/ConvertFiniteGFC.hs

@@ -0,0 +1,257 @@
+----------------------------------------------------------------------
+-- |
+-- Maintainer  : PL
+-- Stability   : (stable)
+-- Portability : (portable)
+--
+-- > CVS $Date: 2005/03/29 11:18:39 $ 
+-- > CVS $Author: peb $
+-- > CVS $Revision: 1.1 $
+--
+-- Calculating the finiteness of each type in a grammar
+-----------------------------------------------------------------------------
+
+module GF.Parsing.ConvertFiniteGFC where
+
+import Operations
+import GFC
+import MkGFC
+import AbsGFC
+import Ident (Ident(..))
+import GF.System.Tracing
+import GF.Printing.PrintParser
+import GF.Printing.PrintSimplifiedTerm
+import GF.Data.SortedList
+import GF.Data.Assoc
+import GF.Data.BacktrackM
+
+type Cat = Ident
+type Name = Ident
+
+type CnvMonad a = BacktrackM () () a
+
+convertGrammar :: CanonGrammar -> CanonGrammar
+convertGrammar = canon2grammar . convertCanon . grammar2canon
+
+convertCanon :: Canon -> Canon
+convertCanon (Gr modules) = Gr (map (convertModule split) modules)
+    where split = calcSplitable modules
+
+convertModule :: Splitable -> Module -> Module
+convertModule split (Mod mtyp ext op fl defs) 
+    = Mod mtyp ext op fl newDefs
+    where newDefs  = solutions defMonad () () 
+	  defMonad = member defs >>= convertDef split
+
+-- the main conversion function
+convertDef :: Splitable -> Def -> CnvMonad Def
+
+convertDef split (AbsDCat cat decls cidents)
+    = case splitableCat split cat of
+        Just newCats -> do newCat <- member newCats
+			   return $ AbsDCat newCat decls cidents
+	Nothing -> do (newCat, newDecls) <- expandDecls cat decls
+		      return $ AbsDCat newCat newDecls cidents
+    where expandDecls cat [] = return (cat, [])
+	  expandDecls cat (decl@(Decl var typ) : decls)
+	      = do (newCat, newDecls) <- expandDecls cat decls
+		   let argCat = resultCat typ
+		   case splitableCat split argCat of
+		     Nothing -> return (newCat, decl : newDecls) 
+		     Just newArgs -> do newArg <- member newArgs
+					return (mergeCats "/" newCat newArg, newDecls)
+
+convertDef split (AbsDFun fun typ@(EAtom (AC (CIQ mod cat))) def)
+    = case splitableFun split fun of
+        Just newCat -> return (AbsDFun fun (EAtom (AC (CIQ mod newCat))) def)
+	Nothing -> do newTyp <- expandType split [] typ
+		      return (AbsDFun fun newTyp def)
+convertDef split (AbsDFun fun typ def)
+    = do newTyp <- expandType split [] typ
+	 return (AbsDFun fun newTyp def)
+
+convertDef _ def = return def
+
+-- expanding Exp's
+expandType :: Splitable -> [(Ident, Cat)] -> Exp -> CnvMonad Exp
+expandType split env (EProd x a@(EAtom (AC (CIQ mod cat))) b)
+    = case splitableCat split cat of
+        Nothing -> do b' <- expandType split env b
+		      return (EProd x a b')
+	Just newCats -> do newCat <- member newCats
+			   b' <- expandType split ((x,newCat):env) b
+			   return (EProd x (EAtom (AC (CIQ mod newCat))) b')
+expandType split env (EProd x a b)
+    = do a' <- expandType split env a
+	 b' <- expandType split env b
+	 return (EProd x a' b')
+expandType split env app
+    = expandApp split env [] app
+
+expandApp :: Splitable -> [(Ident, Cat)] -> [Cat] -> Exp -> CnvMonad Exp
+expandApp split env addons (EAtom (AC (CIQ mod cat)))
+    = return (EAtom (AC (CIQ mod (foldl (mergeCats "/") cat addons))))
+expandApp split env addons (EApp exp arg@(EAtom (AC (CIQ mod fun))))
+    = case splitableFun split fun of
+        Just newCat -> expandApp split env (newCat:addons) exp
+	Nothing -> do exp' <- expandApp split env addons exp
+		      return (EApp exp' arg)
+expandApp split env addons (EApp exp arg@(EAtom (AV x)))
+    = case lookup x env of
+        Just newCat -> expandApp split env (newCat:addons) exp
+	Nothing -> do exp' <- expandApp split env addons exp
+		      return (EApp exp' arg)
+
+----------------------------------------------------------------------
+-- splitable categories (finite, no dependencies)
+-- they should also be used as some dependency
+
+type Splitable = (Assoc Cat [Cat], Assoc Name Cat)
+
+splitableCat :: Splitable -> Cat -> Maybe [Cat]
+splitableCat = lookupAssoc . fst 
+
+splitableFun :: Splitable -> Name -> Maybe  Cat
+splitableFun = lookupAssoc . snd
+
+calcSplitable :: [Module] -> Splitable
+calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns)
+    where splitableCats = tracePrt "splitableCats" (prtSep " ") $
+			  groupPairs $ nubsort 
+			  [ (cat, mergeCats ":" fun cat) | (cat, fun) <- constantCats ]
+
+	  splitableFuns = tracePrt "splitableFuns" (prtSep " ") $
+			  nubsort
+			  [ (fun, mergeCats ":" fun cat) | (cat, fun) <- constantCats ]
+
+	  constantCats = tracePrt "constantCats" (prtSep " ") $
+			 [ (cat, fun) |
+			   AbsDFun fun (EAtom (AC (CIQ _ cat))) _ <- absDefs,
+			   dependentConstants ?= cat ]
+
+          dependentConstants = listSet $
+			       tracePrt "dep consts" prt $
+			       dependentCats <\\> funCats
+
+	  funCats = tracePrt "fun cats" prt $
+		    nubsort [ resultCat typ |
+			      AbsDFun _ typ@(EProd _ _ _) _ <- absDefs ]
+
+          dependentCats = tracePrt "dep cats" prt $
+			  nubsort [ cat | AbsDCat _ decls _ <- absDefs,
+				    Decl _ (EAtom (AC (CIQ _ cat))) <- decls ]
+			    
+          absDefs = concat [ defs | Mod (MTAbs _) _ _ _ defs <- modules ]
+
+
+----------------------------------------------------------------------
+
+resultCat :: Exp -> Cat
+resultCat (EProd _ _ b) = resultCat b
+resultCat (EApp a _) = resultCat a
+resultCat (EAtom (AC (CIQ _ cat))) = cat
+
+mergeCats :: String -> Cat -> Cat -> Cat
+mergeCats str (IC cat) (IC arg) = IC (cat ++ str ++ arg)
+
+----------------------------------------------------------------------
+-- obsolete?
+
+{-
+type FiniteCats = Assoc Cat Integer
+
+calculateFiniteness :: Canon -> FiniteCats
+calculateFiniteness canon@(Gr modules) 
+    = trace2 "#typeInfo" (prt tInfo) $
+      finiteCats
+
+    where finiteCats = listAssoc [ (cat, fin) | (cat, Just fin) <- finiteInfo ]
+          finiteInfo = map finInfo groups 
+
+	  finInfo :: (Cat, [[Cat]]) -> (Cat, Maybe Integer)
+	  finInfo (cat, ctxts)
+	      | cyclicCats ?= cat = (cat, Nothing)
+	      | otherwise = (cat, fmap (sum . map product) $
+			     sequence (map (sequence . map lookFinCat) ctxts))
+
+	  lookFinCat :: Cat -> Maybe Integer
+	  lookFinCat cat = maybe (error "lookFinCat: Nothing") id $
+			   lookup cat finiteInfo
+
+	  cyclicCats :: Set Cat
+	  cyclicCats = listSet $
+		       tracePrt "cyclic cats" prt $
+		       union $ map nubsort $ cyclesIn dependencies
+
+	  dependencies :: [(Cat, [Cat])]
+	  dependencies = tracePrt "dependencies" (prtAfter "\n") $
+			 mapSnd (union . nubsort) groups
+
+	  groups :: [(Cat, [[Cat]])]
+	  groups  = tracePrt "groups" (prtAfter "\n") $
+		    mapSnd (map snd) $ groupPairs (nubsort allFuns)
+
+	  allFuns = tracePrt "all funs" (prtAfter "\n") $
+		    [ (cat, (fun, ctxt)) |
+		      Mod (MTAbs _) _ _ _ defs <- modules,
+		      AbsDFun fun typ _ <- defs,
+		      let (cat, ctxt) = err error id $ typeForm typ ]
+
+          tInfo = calculateTypeInfo 30 finiteCats (splitDefs canon)
+
+-- | stolen from 'Macros.qTypeForm', converted to GFC, and severely simplified
+typeForm :: Monad m => Exp -> m (Cat, [Cat])
+typeForm t = case t of
+  EProd x a b  -> do
+    (cat, ctxt) <- typeForm b 
+    a' <- stripType a
+    return (cat, a':ctxt)
+  EApp c a -> do
+    (cat, _) <- typeForm c
+    return (cat, [])
+  EAtom (AC (CIQ _ con)) ->
+    return (con, []) 
+  _       -> 
+    fail $ "no normal form of type: " ++ prt t
+
+stripType :: Monad m => Exp -> m Cat
+stripType (EApp c a) = stripType c
+stripType (EAtom (AC (CIQ _ con))) = return con
+stripType t = fail $ "can't strip type: " ++ prt t
+
+mapSnd f xs = [ (a, f b) | (a, b) <- xs ]
+-}
+
+----------------------------------------------------------------------
+-- obsolete?
+
+{-
+type SplitDefs = ([Def],  [Def],  [Def],  [Def])
+-----            AbsDCat AbsDFun CncDCat CncDFun
+
+splitDefs :: Canon -> SplitDefs
+splitDefs (Gr modules) = foldr splitDef ([], [], [], []) $ 
+			 concat [ defs | Mod _ _ _ _ defs <- modules ]
+
+splitDef :: Def -> SplitDefs -> SplitDefs
+splitDef ac@(AbsDCat _ _ _) (acs, afs, ccs, cfs) = (ac:acs, afs, ccs, cfs)
+splitDef af@(AbsDFun _ _ _) (acs, afs, ccs, cfs) = (acs, af:afs, ccs, cfs)
+splitDef cc@(CncDCat _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, cc:ccs, cfs)
+splitDef cf@(CncDFun _ _ _ _ _) (acs, afs, ccs, cfs) = (acs, afs, ccs, cf:cfs)
+splitDef _ sd = sd
+
+--calculateTypeInfo :: Integer -> FiniteCats -> SplitDefs -> ?
+calculateTypeInfo maxFin allFinCats (acs, afs, ccs, cfs)
+    = (depCatsToExpand, catsToSplit)
+    where absDefsToExpand = tracePrt "absDefsToExpand" prt $
+			    [ ((cat, fin), cats) | 
+			      AbsDCat cat args _ <- acs, 
+			      not (null args),
+			      cats <- mapM catOfDecl args,
+			      fin <- lookupAssoc allFinCats cat,
+			      fin <= maxFin
+			    ]
+	  (depCatsToExpand, argsCats') = unzip absDefsToExpand
+	  catsToSplit = union (map nubsort argsCats')
+	  catOfDecl (Decl _ exp) = err fail return $ stripType exp
+-}

src/GF/Parsing/ConvertGFCtoMCFG.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:46 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- All different conversions from GFC to MCFG
 -----------------------------------------------------------------------------
@@ -20,7 +20,7 @@ import GFC (CanonGrammar)
 import GF.Parsing.GrammarTypes
 import Ident (Ident(..))
 import Option
-import Tracing
+import GF.System.Tracing
 
 import qualified GF.Parsing.ConvertGFCtoMCFG.Old as Old
 import qualified GF.Parsing.ConvertGFCtoMCFG.Nondet as Nondet

src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs

@@ -1,20 +1,21 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : AddCoercions
+-- Module      : ConvertGFCtoMCFG.Coercions
 -- Maintainer  : PL
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:53 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
+-- Adding coercion functions to a MCFG if necessary.
 -----------------------------------------------------------------------------
 
 
 module GF.Parsing.ConvertGFCtoMCFG.Coercions (addCoercions) where
 
-import Tracing
+import GF.System.Tracing
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 -- import PrintGFC
@@ -33,7 +34,7 @@ addCoercions :: MCFGrammar -> MCFGrammar
 addCoercions rules = coercions ++ rules
     where (allHeads, allArgs) = unzip [ ((head, lbls), nubsort args) | 
 					Rule head args lins _ <- rules, 
-					let lbls = [ lbl | Lin lbl _ <- lins ] ]
+					let lbls = [ lbl | Lin lbl _ <- lins ] ]
 	  allHeadSet = nubsort allHeads
 	  allArgSet  = union   allArgs <\\> map fst allHeadSet
 	  coercions = tracePrt "#coercions total" (prt . length) $

src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:53 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Converting GFC grammars to MCFG grammars, nondeterministically.
 --
@@ -20,8 +20,7 @@
 
 module GF.Parsing.ConvertGFCtoMCFG.Nondet (convertGrammar) where
 
-import Tracing
+import GF.System.Tracing
-import IOExts (unsafePerformIO)
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 -- import PrintGFC

src/GF/Parsing/ConvertGFCtoMCFG/Old.hs

@@ -1,15 +1,15 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : ConvertGFCtoMCFG
+-- Module      : ConvertGFCtoMCFG.Old
 -- Maintainer  : PL
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:44:39 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
--- Converting GFC grammars to MCFG grammars.
+-- Converting GFC grammars to MCFG grammars. (Old variant)
 --
 -- the resulting grammars might be /very large/
 --
@@ -20,7 +20,7 @@
 
 module GF.Parsing.ConvertGFCtoMCFG.Old (convertGrammar) where
 
-import Tracing
+import GF.System.Tracing
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 --import PrintGFC

src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:54 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Converting GFC grammars to MCFG grammars, nondeterministically.
 --
@@ -20,8 +20,8 @@
 
 module GF.Parsing.ConvertGFCtoMCFG.Strict (convertGrammar) where
 
-import Tracing
+import GF.System.Tracing
-import IOExts (unsafePerformIO)
+-- import IOExts (unsafePerformIO)
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 -- import PrintGFC
@@ -113,7 +113,7 @@ enumerateArg (A cat nr) = do env <- readEnv
 substitutePaths :: GrammarEnv -> [STerm] -> Term -> STerm
 substitutePaths env arguments trm  = subst trm
     where subst (con `Con` terms) = con `SCon` map subst terms
-	  subst (R record)        = SRec [ (lbl, subst term) | lbl `Ass` term <- record ]
+	  subst (R record)        = SRec [ (lbl, subst term) | lbl `Ass` term <- record ]
 	  subst (term `P` lbl)    = subst term +. lbl
 	  subst (T ptype table)   = STbl [ (pattern2sterm pat, subst term) | 
 					   pats `Cas` term <- table, pat <- pats ]

src/GF/Parsing/ConvertGFCtoMCFG/Utils.hs

@@ -1,237 +0,0 @@
-----------------------------------------------------------------------
--- |
--- Module      : ConvertGFCtoMCFGnondet
--- Maintainer  : PL
--- Stability   : (stable)
--- Portability : (portable)
---
--- > CVS $Date: 2005/03/21 22:31:54 $ 
--- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
---
--- Converting GFC grammars to MCFG grammars, nondeterministically.
---
--- the resulting grammars might be /very large/
---
--- the conversion is only equivalent if the GFC grammar has a context-free backbone.
--- (also, the conversion might fail if the GFC grammar has dependent or higher-order types)
------------------------------------------------------------------------------
-
-
-module GF.Conversion.ConvertGFCtoMCFG.Utils where
-
-import Tracing
-import IOExts (unsafePerformIO)
-import GF.Printing.PrintParser
-import GF.Printing.PrintSimplifiedTerm
--- import PrintGFC
--- import qualified PrGrammar as PG
-
-import Monad
-import Ident (Ident(..))
-import AbsGFC
-import GFC
-import Look
-import Operations
-import qualified Modules as M
-import CMacros (defLinType)
-import MkGFC (grammar2canon)
-import GF.Parsing.Parser
-import GF.Parsing.GrammarTypes 
-import GF.Parsing.MCFGrammar (Grammar, Rule(..), Lin(..))
-import GF.Data.SortedList
--- import Maybe (listToMaybe)
-import List (groupBy) -- , transpose)
-
-import GF.Data.BacktrackM
-
-----------------------------------------------------------------------
-
-type GrammarEnv  = (CanonGrammar, Ident)
-
-buildConversion :: (Def -> BacktrackM GrammarEnv state MCFRule)
-		-> GrammarEnv -> MCFGrammar
-buildConversion cnvDef env = trace2 "language" (prt (snd gram)) $
-			     trace2 "modules" (prtSep " " modnames) $
-			     tracePrt "#mcf-rules total" (prt . length) $
-			     solutions conversion env undefined
-    where Gr modules = grammar2canon (fst gram)
-	  modnames   = uncurry M.allExtends gram
-	  conversion = member modules >>= convertModule
-	  convertModule (Mod (MTCnc modname _) _ _ _ defs)
-	      | modname `elem` modnames = member defs >>= cnvDef cnvtype
-	  convertModule _ = failure
-
-
-----------------------------------------------------------------------
--- strict conversion
-
-extractArg :: [STerm] -> ArgVar -> CnvMonad MCFCat
-extractArg args (A cat nr) = emcfCat cat (args !! fromInteger nr)
-
-emcfCat :: Cat -> STerm -> CnvMonad MCFCat
-emcfCat cat term = do env <- readEnv
-		      member $ map (MCFCat cat) $ parPaths env (lookupCType env cat) term
-
-enumerateArg :: ArgVar -> CnvMonad STerm
-enumerateArg (A cat nr) = do env <- readEnv
-			     let ctype = lookupCType env cat
-			     enumerate (SArg (fromInteger nr) cat emptyPath) ctype
-    where enumerate arg (TStr) = return arg 
-	  enumerate arg ctype@(Cn _) = do env <- readEnv 
-					  member $ groundTerms env ctype
-	  enumerate arg (RecType rtype) 
-	      = liftM SRec $ sequence [ liftM ((,) lbl) $ 
-					enumerate (arg +. lbl) ctype |
-					lbl `Lbg` ctype <- rtype ]
-	  enumerate arg (Table stype ctype)
-	      = do env <- readEnv
-		   state <- readState
-		   liftM STbl $ sequence [ liftM ((,) sel) $ 
-					   enumerate (arg +! sel) ctype |
-					   sel <- solutions (enumerate err stype) env state ]
-	      where err = error "enumerate: parameter type should not be string"
-
--- Substitute each instantiated parameter path for its instantiation
-substitutePaths :: GrammarEnv -> [STerm] -> Term -> STerm
-substitutePaths env arguments trm  = subst trm
-    where subst (con `Con` terms) = con `SCon` map subst terms
-	  subst (R record)        = SRec [ (lbl, subst term) | lbl `Ass` term <- record ]
-	  subst (term `P` lbl)    = subst term +. lbl
-	  subst (T ptype table)   = STbl [ (pattern2sterm pat, subst term) | 
-					   pats `Cas` term <- table, pat <- pats ]
-	  subst (V ptype table)   = STbl [ (pat, subst term) | 
-					   (pat, term) <- zip (groundTerms env ptype) table ]
-	  subst (term `S` select) = subst term +! subst select
-	  subst (term `C` term')  = subst term `SConcat` subst term'
-	  subst (K str)           = SToken str
-	  subst (E)               = SEmpty
-	  subst (FV terms)        = evalFV $ map subst terms
-	  subst (Arg (A _ arg))   = arguments !! fromInteger arg
-
-
-termPaths :: GrammarEnv -> CType -> STerm -> [(Path, (CType, STerm))]
-termPaths env (TStr) term = [ (emptyPath, (TStr, term)) ]
-termPaths env (RecType rtype) (SRec record) 
-    = [ (path ++. lbl, value) |
-	(lbl, term) <- record,
-	let ctype = lookupLabelling lbl rtype,
-	(path, value) <- termPaths env ctype term ]
-termPaths env (Table _ ctype) (STbl table)
-    = [ (path ++! pat, value) |
-	(pat, term) <- table,
-	(path, value) <- termPaths env ctype term ]
-termPaths env ctype (SVariants terms)
-    = terms >>= termPaths env ctype
-termPaths env (Cn pc) term = [ (emptyPath, (Cn pc, term)) ]
-
-{- ^^^ variants are pushed inside (not equivalent -- but see record-variants.txt):
-{a=a1; b=b1}  | {a=a2; b=b2}   ==>  {a=a1|a2; b=b1|b2}
-[p=>p1;q=>q1] | [p=>p2;q=>q2]  ==>  [p=>p1|p2;q=>q1|q2]
--}
-
-parPaths :: GrammarEnv -> CType -> STerm -> [[(Path, STerm)]]
-parPaths env ctype term = mapM (uncurry (map . (,))) (groupPairs paths)
-    where paths = nubsort [ (path, value) | (path, (Cn _, value)) <- termPaths env ctype term ]
-
-strPaths :: GrammarEnv -> CType -> STerm -> [(Path, STerm)]
-strPaths env ctype term = [ (path, evalFV values) | (path, values) <- groupPairs paths ]
-    where paths = nubsort [ (path, value) | (path, (TStr, value)) <- termPaths env ctype term ]
-
-extractLin :: [MCFCat] -> (Path, STerm) -> [Lin MCFCat MCFLabel Tokn]
-extractLin args (path, term) = map (Lin path) (convertLin term)
-    where convertLin (t1 `SConcat` t2) = liftM2 (++) (convertLin t1) (convertLin t2)
-	  convertLin (SEmpty) = [[]]
-	  convertLin (SToken tok) = [[Tok tok]]
-	  convertLin (SVariants terms) = concatMap convertLin terms
-	  convertLin (SArg nr _ path) = [[Cat (args !! nr, path, nr)]]
-
-evalFV terms0 = case nubsort (concatMap flattenFV terms0) of
-	          [term] -> term
-		  terms  -> SVariants terms
-    where flattenFV (SVariants ts) = ts
-	  flattenFV  t      = [t]
-
-lookupLabelling :: Label -> [Labelling] -> CType
-lookupLabelling lbl rtyp = case [ ctyp | lbl' `Lbg` ctyp <- rtyp, lbl == lbl' ] of
-			     [ctyp] -> ctyp
-			     err -> error $ "lookupLabelling:" ++ show err
-
-pattern2sterm :: Patt -> STerm
-pattern2sterm (con `PC` patterns) = con `SCon` map pattern2sterm patterns
-pattern2sterm (PR record) = SRec [ (lbl, pattern2sterm pattern) | 
-				   lbl `PAss` pattern <- record ]
-
-------------------------------------------------------------
--- updating the mcf rule
-
-updateArg :: Int -> Constraint -> CnvMonad ()
-updateArg arg cn
-    = do (head, args, lins) <- readState 
-	 args' <- updateNth (addToMCFCat cn) arg args
-	 writeState (head, args', lins)
-
-updateHead :: Constraint -> CnvMonad ()
-updateHead cn
-    = do (head, args, lins) <- readState
-	 head' <- addToMCFCat cn head
-	 writeState (head', args, lins)
-
-updateLin :: Constraint -> CnvMonad ()
-updateLin (path, term) 
-    = do let newLins = term2lins term
-	 (head, args, lins) <- readState
-	 let lins' = lins ++ map (Lin path) newLins
-	 writeState (head, args, lins')
-
-term2lins :: STerm -> [[Symbol (Cat, Path, Int) Tokn]]
-term2lins (SArg arg cat path) = return [Cat (cat, path, arg)]
-term2lins (SToken str)        = return [Tok str]
-term2lins (SConcat t1 t2)     = liftM2 (++) (term2lins t1) (term2lins t2)
-term2lins (SEmpty)            = return []
-term2lins (SVariants terms)   = terms >>= term2lins
-term2lins term = error $ "term2lins: " ++ show term
-
-addToMCFCat :: Constraint -> MCFCat -> CnvMonad MCFCat
-addToMCFCat cn (MCFCat cat cns) = liftM (MCFCat cat) $ addConstraint cn cns
-
-addConstraint :: Constraint -> [Constraint] -> CnvMonad [Constraint]
-addConstraint cn0 (cn : cns)
-    | fst cn0 >  fst cn = liftM (cn:) (addConstraint cn0 cns)
-    | fst cn0 == fst cn = guard (snd cn0 == snd cn) >>
-			  return (cn : cns)
-addConstraint cn0 cns   = return (cn0 : cns)
-
-
-----------------------------------------------------------------------
--- utilities 
-
-updateNth :: Monad m => (a -> m a) -> Int -> [a] -> m [a]
-updateNth update 0 (a : as) = liftM (:as) (update a)
-updateNth update n (a : as) = liftM (a:)  (updateNth update (n-1) as)
-
-catOfArg (A aCat _) = aCat
-catOfArg (AB aCat _ _) = aCat
-
-lookupCType :: GrammarEnv -> Cat -> CType
-lookupCType env cat = errVal defLinType $ 
-		      lookupLincat (fst env) (CIQ (snd env) cat)
-
-groundTerms :: GrammarEnv -> CType -> [STerm]
-groundTerms env ctype = err error (map term2spattern) $
-			allParamValues (fst env) ctype
-
-cTypeForArg :: GrammarEnv -> STerm -> CType
-cTypeForArg env (SArg nr cat (Path path))
-    = follow path $ lookupCType env cat
-    where follow [] ctype = ctype
-	  follow (Right pat : path) (Table _ ctype) = follow path ctype
-	  follow (Left lbl : path) (RecType rec)
-	      = case [ ctype | Lbg lbl' ctype <- rec, lbl == lbl' ] of
-		  [ctype] -> follow path ctype
-		  err     -> error $ "follow: " ++ show rec ++ " . " ++ show lbl ++ 
-			             " results in " ++ show err
-
-term2spattern (R rec)         = SRec [ (lbl, term2spattern term) | Ass lbl term <- rec ]
-term2spattern (Con con terms) = SCon con $ map term2spattern terms
-

src/GF/Parsing/ConvertGrammar.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:46 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- All (?) grammar conversions which are used in GF
 -----------------------------------------------------------------------------
@@ -19,11 +19,13 @@ module GF.Parsing.ConvertGrammar
     ) where
 
 import GFC (CanonGrammar)
+import MkGFC (grammar2canon)
 import GF.Parsing.GrammarTypes
 import Ident (Ident(..))
 import Option
-import Tracing
+import GF.System.Tracing
 
+-- import qualified GF.Parsing.FiniteTypes.Calc  as Fin
 import qualified GF.Parsing.ConvertGFCtoMCFG  as G2M
 import qualified GF.Parsing.ConvertMCFGtoCFG  as M2C
 import qualified GF.Parsing.MCFGrammar        as MCFG

src/GF/Parsing/ConvertMCFGtoCFG.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:47 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Converting MCFG grammars to (possibly overgenerating) CFG
 -----------------------------------------------------------------------------
@@ -16,7 +16,7 @@
 module GF.Parsing.ConvertMCFGtoCFG
     (convertGrammar) where
 
-import Tracing
+import GF.System.Tracing
 import GF.Printing.PrintParser
 
 import Monad

src/GF/Parsing/GrammarTypes.hs

@@ -1,13 +1,12 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : GrammarTypes
 -- Maintainer  : PL
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:48 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- All possible instantiations of different grammar formats used for parsing
 --
@@ -36,6 +35,7 @@ module GF.Parsing.GrammarTypes
 
 import Ident (Ident(..))
 import AbsGFC
+-- import qualified GF.Parsing.FiniteTypes.Calc as Fin
 import qualified GF.Parsing.CFGrammar as CFG
 import qualified GF.Parsing.MCFGrammar as MCFG
 import GF.Printing.PrintParser
@@ -75,16 +75,16 @@ data STerm    = SArg Int Cat Path     -- ^ argument variable, the 'Path' is a pa
 				      -- pointing into the term 
 	      | SCon Constr [STerm]   -- ^ constructor
 	      | SRec [(Label, STerm)] -- ^ record
-	      | STbl [(STerm, STerm)] -- ^ table of patterns/terms
+	      | STbl [(STerm, STerm)] -- ^ table of patterns\/terms
 	      | SVariants [STerm]     -- ^ variants
 	      | SConcat STerm STerm   -- ^ concatenation
 	      | SToken Tokn           -- ^ single token
 	      | SEmpty                -- ^ empty string
 	      | SWildcard             -- ^ wildcard pattern variable
 
-	      -- | SRes CIdent        -- resource identifier
+	      -- SRes CIdent        -- resource identifier
-	      -- | SVar Ident         -- bound pattern variable
+	      -- SVar Ident         -- bound pattern variable
-	      -- | SInt Integer       -- integer
+	      -- SInt Integer       -- integer
 		deriving (Eq, Ord, Show)
 
 (+.) :: STerm -> Label -> STerm

src/GF/Parsing/ParseCF.hs

@@ -5,16 +5,16 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:50 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- Chart parsing of grammars in CF format
 -----------------------------------------------------------------------------
 
 module GF.Parsing.ParseCF (parse, alternatives) where
 
-import Tracing
+import GF.System.Tracing
 import GF.Printing.PrintParser
 import GF.Printing.PrintSimplifiedTerm
 

src/GF/Parsing/ParseCFG/General.hs

@@ -1,13 +1,13 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : CFParserGeneral
+-- Module      : ParseCFG.General
 -- Maintainer  : Peter Ljunglöf
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:54 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Several implementations of CFG chart parsing
 -----------------------------------------------------------------------------
@@ -15,7 +15,7 @@
 module GF.Parsing.ParseCFG.General 
     (parse, Strategy) where
 
-import Tracing
+import GF.System.Tracing
 
 import GF.Parsing.Utilities
 import GF.Parsing.CFGrammar

src/GF/Parsing/ParseCFG/Incremental.hs

@@ -1,13 +1,13 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : CFParserIncremental
+-- Module      : ParseCFG.Incremental
 -- Maintainer  : PL
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:54 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Incremental chart parsing for context-free grammars
 -----------------------------------------------------------------------------
@@ -17,7 +17,7 @@
 module GF.Parsing.ParseCFG.Incremental 
     (parse, Strategy) where
 
-import Tracing
+import GF.System.Tracing
 import GF.Printing.PrintParser
 
 -- haskell modules:

src/GF/Parsing/ParseGFC.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:51 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.2 $
+-- > CVS $Revision: 1.3 $
 --
 -- The main parsing module, parsing GFC grammars
 -- by translating to simpler formats, such as PMCFG and CFG
@@ -15,7 +15,7 @@
 
 module GF.Parsing.ParseGFC (newParser) where
 
-import Tracing 
+import GF.System.Tracing 
 import GF.Printing.PrintParser
 import qualified PrGrammar
 

src/GF/Parsing/ParseMCFG/Basic.hs

@@ -1,13 +1,13 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : MCFParserBasic
+-- Module      : ParseMCFG.Basic
 -- Maintainer  : Peter Ljunglöf
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:55 $ 
+-- > CVS $Date: 2005/03/29 11:17:55 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Simplest possible implementation of MCFG chart parsing
 -----------------------------------------------------------------------------
@@ -15,7 +15,7 @@
 module GF.Parsing.ParseMCFG.Basic 
     (parse) where
 
-import Tracing
+import GF.System.Tracing
 
 import Ix
 import GF.Parsing.Utilities

src/GF/Parsing/Utilities.hs

@@ -1,13 +1,13 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : Parser
+-- Module      : Parsing.Utilities
 -- Maintainer  : PL
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:31:52 $ 
+-- > CVS $Date: 2005/03/29 11:17:54 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Basic type declarations and functions to be used when parsing
 -----------------------------------------------------------------------------

src/GF/Printing/PrintParser.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 14:17:44 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Pretty-printing of parser objects
 -----------------------------------------------------------------------------
@@ -69,6 +69,10 @@ instance Print Int where
 instance Print Integer where
     prt = show
 
+instance Print a => Print (Maybe a) where
+    prt (Just a) = "!" ++ prt a
+    prt Nothing  = "Nothing"
+
 instance Print a => Print (Err a) where
     prt (Ok a) = prt a
     prt (Bad str) = str

src/GF/Printing/PrintSimplifiedTerm.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 14:17:44 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.1 $
+-- > CVS $Revision: 1.2 $
 --
 -- Instances for printing terms in a simplified format
 -----------------------------------------------------------------------------
@@ -19,6 +19,7 @@ import AbsGFC
 import CF
 import CFIdent
 import GF.Printing.PrintParser
+import qualified PrintGFC as P
 
 instance Print Term where
     prt (Arg arg)         = prt arg
@@ -100,6 +101,10 @@ instance Print CFCat where
 instance Print CFFun where 
     prt (CFFun fun) = prt (fst fun)
 
+instance Print Exp where
+    prt = P.printTree
+
+
 sizeCT :: CType -> Int
 sizeCT (RecType rt) = 1 + sum [ sizeCT t | _ `Lbg` t <- rt ]
 sizeCT (Table pt vt) = 1 + sizeCT pt + sizeCT vt

src/GF/Text/OCSCyrillic.hs

@@ -1,13 +1,12 @@
 ----------------------------------------------------------------------
 -- |
--- Module      : OSCyrillic
 -- Maintainer  : (Maintainer)
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/02/18 19:21:15 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.4 $
+-- > CVS $Revision: 1.5 $
 --
 -- (Description of the module)
 -----------------------------------------------------------------------------

src/GF/UseGrammar/Custom.hs

@@ -5,9 +5,9 @@
 -- Stability   : (stable)
 -- Portability : (portable)
 --
--- > CVS $Date: 2005/03/21 22:40:06 $ 
+-- > CVS $Date: 2005/03/29 11:17:56 $ 
 -- > CVS $Author: peb $
--- > CVS $Revision: 1.47 $
+-- > CVS $Revision: 1.48 $
 --
 -- A database for customizable GF shell commands. 
 --
@@ -75,6 +75,8 @@ import qualified GF.Parsing.ParseCF as PCF
 -- see also customGrammarPrinter
 import qualified GF.Parsing.ConvertGrammar as Cnv
 import qualified GF.Printing.PrintParser as Prt
+import qualified GF.Data.Assoc as Assoc
+import qualified GF.Parsing.ConvertFiniteGFC as Fin
 
 import GFC
 import qualified MkGFC as MC
@@ -256,6 +258,9 @@ customGrammarPrinter =
   ,(strCI "cfg",        Prt.prt . Cnv.cfg . statePInfo)
   ,(strCI "mcfg_show",  show . Cnv.mcfg . statePInfo)
   ,(strCI "cfg_show",   show . Cnv.cfg . statePInfo)
+-- hack for printing finiteness of grammar categories:
+  -- ,(strCI "finiteness", Prt.prtAfter "\n" . Assoc.aAssocs . Cnv.fintypes . statePInfo)
+  ,(strCI "finite",     prCanon . Fin.convertGrammar . stateGrammarST)
 --- also include printing via grammar2syntax!
   ] 
   ++ moreCustomGrammarPrinter

src/Makefile

@@ -9,7 +9,7 @@ GHCFUDFLAG=
 JAVAFLAGS=-target 1.4 -source 1.4
 
 HUGSINCLUDE    =.:{Hugs}/libraries:for-hugs:api:source:canonical:cf:grammar:infra:shell:useGrammar:compile:newparsing:cfgm:speech:visualization:
-BASICINCLUDE   =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -inotrace -icfgm -ispeech -ivisualization
+BASICINCLUDE   =-iapi -icompile -igrammar -iinfra -ishell -isource -icanonical -iuseGrammar -icf -inewparsing -iparsers -icfgm -ispeech -ivisualization
 GHCINCLUDE     =-ifor-ghc       $(BASICINCLUDE)
 GHCINCLUDENOFUD=-ifor-ghc-nofud $(BASICINCLUDE) 
 GHCINCLUDEGFT  =-ifor-gft       $(BASICINCLUDE) 
@@ -23,6 +23,8 @@ NOT_IN_DIST= \
 	src/old-stuff \
 	src/parsing \
 	src/conversions \
+	src/trace \
+	src/notrace \
 	src/util/AlphaConvGF.hs
 
 BIN_DIST_DIR=$(DIST_DIR)-$(host)
@@ -31,28 +33,28 @@ SNAPSHOT_DIR=GF-$(shell date +%Y%m%d)
 
 all: unix gfdoc jar
 
-temp: today noopt
+temp: today touch-files noopt
 
-unix: today nofud-links opt
+unix: today touch-files nofud-links opt
 
-windows: today nofud-links justwindows
+windows: today touch-files nofud-links justwindows
 
 install-java: javac
 	-rm -f ../bin/java
 	ln -s ../src/java ../bin
 	@echo "PLEASE edit GFHOME in bin/jgf"
 opt:
-	$(GHMAKE) $(GHCOPTFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf
+	$(GHMAKE) $(GHCOPTFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf-bin
-	strip gf
+	strip gf-bin
-	mv gf ../bin/
+	mv gf-bin ../bin/gf
 noopt:
-	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf
+	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf-bin
-	strip gf
+	strip gf-bin
-	mv gf ../bin/
+	mv gf-bin ../bin/gf
 
 ghc: nofud
 
-ghci: nofud-links ghci-nofud
+ghci: touch-files nofud-links ghci-nofud
 
 fud:
 	$(GHCXMAKE) $(GHCFLAGS) $(GHCINCLUDE) $(GHCFUDFLAG) GF.hs -o fgf
@@ -60,14 +62,14 @@ fud:
 	mv fgf ../bin/
 
 gft:
-	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) -itranslate translate/GFT.hs -o gft
+	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) -itranslate translate/GFT.hs -o gft-bin
-	strip gft
+	strip gft-bin
-	mv gft ../bin/
+	mv gft-bin ../bin/gft
 
 nofud: nofud-links
-	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf
+	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf-bin
-	strip gf
+	strip gf-bin
-	mv gf ../bin/
+	mv gf-bin ../bin/gf
 
 justwindows:
 	$(GHMAKE) $(GHCOPTFLAGS) $(WINDOWSINCLUDE) GF.hs -o gf.exe
@@ -87,6 +89,7 @@ shell:
 	$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDE) Shell.hs
 clean: 
 	-rm -rf */*.o */*.hi *.o *.hi */*.ghi *.ghi *~ */*~
+	-rm -f GF/*.{o,hi,ghi} GF/*/*.{o,hi,ghi} GF/*/*/*.{o,hi,ghi}
 	-rm -f java/*.class
 
 distclean: clean
@@ -113,14 +116,16 @@ help:
 	cd util ; runhugs MkHelpFile ; mv HelpFile.hs .. ; cd ..
 
 # added by peb:
-tracing:
+tracing: GHCFLAGS += -DTRACING
-	$(GHMAKE) $(GHCFLAGS) -itrace $(GHCINCLUDENOFUD) GF.hs -o gf
+tracing: temp
-	strip gf
-	mv gf ../bin/
 
-ghci-trace: nofud-links 
+ghci-trace: GHCFLAGS += -DTRACING
-	$(GHCI) $(GHCFLAGS) -itrace $(GHCINCLUDENOFUD)
+ghci-trace: ghci
 
+touch-files: 
+	touch GF/System/Tracing.hs
+
+# profiling
 prof: GHCOPTFLAGS += -prof -auto-all -auto-dicts
 prof: all
 

src/haddock/haddock-check.perl

@@ -31,17 +31,19 @@ sub check_headerline {
   if (s/^-- \s $title \s* : \s+ (.+?) \s*\n//sx) {
     $name = $1;
     print "   > Incorrect ".lcfirst $title.": $name\n" unless $name =~ $regexp;
+    return $&;
   } else {
-    print "   > Header missing".lcfirst $title."\n";
+    print "   > Header missing: ".lcfirst $title."\n";
   }
 }
 
 if ($#ARGV >= 0) {
   @FILES = @ARGV;
 } else {
-  @dirs = qw/. api canonical cf cfgm compile for-ghc-nofud
+  @dirs = qw{. api canonical cf cfgm compile for-ghc-nofud
-	     grammar infra newparsing notrace parsers shell
+	     grammar infra notrace parsers shell
-	     source speech translate useGrammar util visualization/;
+	     source speech translate useGrammar util visualization
+	     GF GF/* GF/*/*};
   @FILES = grep(!/\/(Par|Lex)(GF|GFC|CFG)\.hs$/,
 		glob "{".join(",",@dirs)."}/*.hs");
 }
@@ -65,11 +67,13 @@ for $file (@FILES) {
   }
 
   # the module header
+  $hdr_module = $module = "";
+
   s/^ (--+ \s* \n) +//sx;
   unless (s/^ -- \s \| \s* \n//sx) {
     print "   > Incorrect module header\n";
   } else {
-    &check_headerline("Module", qr/^ [A-Z] \w* $/x);
+    $hdr_module = s/^-- \s Module \s* : \s+ (.+?) \s*\n//sx ? $1 : "";
     &check_headerline("Maintainer", qr/^ [\wåäöÅÄÖüÜ\s\@\.]+ $/x);
     &check_headerline("Stability", qr/.*/);
     &check_headerline("Portability", qr/.*/);
@@ -91,13 +95,15 @@ for $file (@FILES) {
   # the export list
   $exportlist = "";
 
-  if (/\n module \s+ (\w+) \s+ \( (.*?) \) \s+ where/sx) {
+  if (/\n module \s+ ((?: \w | \.)+) \s+ \( (.*?) \) \s+ where/sx) {
     ($module, $exportlist) = ($1, $2);
 
     $exportlist =~ s/\b module \s+ [A-Z] \w*//gsx;
     $exportlist =~ s/\(\.\.\)//g;
 
-  } else {
+  } elsif (/\n module \s+ ((?: \w | \.)+) \s+ where/sx) {
+    $module = $1;
+
     # modules without export lists
     print "   > No export list\n";
 
@@ -120,8 +126,13 @@ for $file (@FILES) {
 
       $exportlist .= " $fn ";
     }
+  } else {
+    print "  > No module header found\n";
   }
 
+  print "  > Module names not matching: $module != $hdr_module\n"
+    if $hdr_module && $module !~ /\Q$hdr_module\E$/;
+
   # fixing exportlist (double spaces as separator)
   $exportlist = " $exportlist ";
   $exportlist =~ s/(\s | \,)+/  /gx;

src/haddock/haddock-script.csh

@@ -2,8 +2,8 @@
 
 ######################################################################
 # Author: Peter Ljunglöf
-# Time-stamp: "2005-02-18, 14:26"
+# Time-stamp: "2005-03-22, 06:24"
-# CVS $Date: 2005/02/18 19:21:06 $
+# CVS $Date: 2005/03/29 11:17:54 $
 # CVS $Author: peb $
 #
 # a script for producing documentation through Haddock
@@ -15,7 +15,7 @@ set resourcedir = $base/haddock-resources
 
 #set dirs = (. api compile grammar infra shell source canonical useGrammar cf newparsing parsers notrace cfgm speech visualization for-hugs for-ghc)
 
-set files = (`find $base -name '*.hs' -not -path '*/conversions/*' -not -path '*/parsing/*' -not -path '*/for-*' -not -path '*/haddock*' -not -name 'Lex[GC]*' -not -name 'Par[GC]*'` $base/for-ghc-nofud/*.hs)
+set files = (`find $base -name '*.hs' -not -path '*/old-stuff/*' -not -path '*/for-*' -not -path '*/haddock*' -not -name 'Lex[GC]*' -not -name 'Par[GC]*'` $base/for-ghc-nofud/*.hs)
 
 ######################################################################