msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

"Committed_by_peb"

Browse Source
This commit is contained in:
peb
2005-03-29 10:17:53 +00:00
parent fcc25f0bba
commit c400db8ce7
30 changed files with 430 additions and 372 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
src/GF/CF/CanonToCF.hs
View File

@@ -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

7
src/GF/CF/ChartParser.hs
View File

@@ -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

5
src/GF/Compile/NewRename.hs
View File

@@ -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
--

36
src/GF/Data/Assoc.hs
View File

@@ -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,
listAssoc,
listSet,
accumAssoc,
aAssocs,
aElems,
assocMap,
lookupAssoc,
lookupWith,
(?),
(?=)
) where
Set,
emptyAssoc,
emptySet,
listAssoc,
listSet,
accumAssoc,
aAssocs,
aElems,
assocMap,
lookupAssoc,
lookupWith,
(?),
(?=)
) 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)

6
src/GF/Data/BacktrackM.hs
View File

@@ -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
-----------------------------------------------------------------------------

13
src/GF/Data/Operations.hs
View File

@@ -5,9 +5,9 @@
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date: 2005/03/14 23:45:36 $
-- > CVS $Author: krijo $
-- > CVS $Revision: 1.17 $
-- > CVS $Date: 2005/03/29 11:17:56 $
-- > CVS $Author: peb $
-- > 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

6
src/GF/Parsing/CFGrammar.hs
View File

@@ -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

257
src/GF/Parsing/ConvertFiniteGFC.hs Normal file
View File

@@ -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
-}

6
src/GF/Parsing/ConvertGFCtoMCFG.hs
View File

@@ -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

11
src/GF/Parsing/ConvertGFCtoMCFG/Coercions.hs
View File

@@ -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) $

7
src/GF/Parsing/ConvertGFCtoMCFG/Nondet.hs
View File

@@ -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 IOExts (unsafePerformIO)
import GF.System.Tracing
import GF.Printing.PrintParser
import GF.Printing.PrintSimplifiedTerm
-- import PrintGFC

10
src/GF/Parsing/ConvertGFCtoMCFG/Old.hs
View File

@@ -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

10
src/GF/Parsing/ConvertGFCtoMCFG/Strict.hs
View File

@@ -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 IOExts (unsafePerformIO)
import GF.System.Tracing
-- 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 ]

237
src/GF/Parsing/ConvertGFCtoMCFG/Utils.hs
View File

@@ -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

8
src/GF/Parsing/ConvertGrammar.hs
View File

@@ -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

6
src/GF/Parsing/ConvertMCFGtoCFG.hs
View File

@@ -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

14
src/GF/Parsing/GrammarTypes.hs
View File

@@ -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
-- | SVar Ident -- bound pattern variable
-- | SInt Integer -- integer
-- SRes CIdent -- resource identifier
-- SVar Ident -- bound pattern variable
-- SInt Integer -- integer
deriving (Eq, Ord, Show)
(+.) :: STerm -> Label -> STerm

6
src/GF/Parsing/ParseCF.hs
View File

@@ -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

8
src/GF/Parsing/ParseCFG/General.hs
View File

@@ -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

8
src/GF/Parsing/ParseCFG/Incremental.hs
View File

@@ -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:

6
src/GF/Parsing/ParseGFC.hs
View File

@@ -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

8
src/GF/Parsing/ParseMCFG/Basic.hs
View File

@@ -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

6
src/GF/Parsing/Utilities.hs
View File

@@ -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
-----------------------------------------------------------------------------

8
src/GF/Printing/PrintParser.hs
View File

@@ -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

9
src/GF/Printing/PrintSimplifiedTerm.hs
View File

@@ -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

5
src/GF/Text/OCSCyrillic.hs
View File

@@ -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)
-----------------------------------------------------------------------------

9
src/GF/UseGrammar/Custom.hs
View File

@@ -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

51
src/Makefile
View File

@@ -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
strip gf
mv gf ../bin/
$(GHMAKE) $(GHCOPTFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf-bin
strip gf-bin
mv gf-bin ../bin/gf
noopt:
$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf
strip gf
mv gf ../bin/
$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf-bin
strip 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
strip gft
mv gft ../bin/
$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) -itranslate translate/GFT.hs -o gft-bin
strip gft-bin
mv gft-bin ../bin/gft
nofud: nofud-links
$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf
strip gf
mv gf ../bin/
$(GHMAKE) $(GHCFLAGS) $(GHCINCLUDENOFUD) GF.hs -o gf-bin
strip 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:
$(GHMAKE) $(GHCFLAGS) -itrace $(GHCINCLUDENOFUD) GF.hs -o gf
strip gf
mv gf ../bin/
tracing: GHCFLAGS += -DTRACING
tracing: temp
ghci-trace: nofud-links
$(GHCI) $(GHCFLAGS) -itrace $(GHCINCLUDENOFUD)
ghci-trace: GHCFLAGS += -DTRACING
ghci-trace: ghci
touch-files:
touch GF/System/Tracing.hs
# profiling
prof: GHCOPTFLAGS += -prof -auto-all -auto-dicts
prof: all

27
src/haddock/haddock-check.perl
View File

@@ -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
grammar infra newparsing notrace parsers shell
source speech translate useGrammar util visualization/;
@dirs = qw{. api canonical cf cfgm compile for-ghc-nofud
grammar infra notrace parsers shell
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/.*/);
@@ -77,7 +81,7 @@ for $file (@FILES) {
print " > Missing CVS information\n"
unless s/^(-- \s+ \> \s+ CVS \s+ \$ .*? \$ \s* \n)+//sx;
s/^ (--+ \s* \n) +//sx;
print " > Missing module description\n"
print " > Missing module description\n"
unless /^ -- \s+ [^\(]/x;
}
@@ -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;

6
src/haddock/haddock-script.csh
View File

@@ -2,8 +2,8 @@
######################################################################
# Author: Peter Ljunglöf
# Time-stamp: "2005-02-18, 14:26"
# CVS $Date: 2005/02/18 19:21:06 $
# Time-stamp: "2005-03-22, 06:24"
# 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)
######################################################################