From f6ef8e8bf8471b83675285348d85672f946efbc5 Mon Sep 17 00:00:00 2001 From: peb Date: Tue, 29 Mar 2005 10:58:46 +0000 Subject: [PATCH] "Committed_by_peb" --- src/GF/Parsing/ConvertFiniteGFC.hs | 33 +++++++++++----- src/GF/System/Tracing.hs | 63 ++++++++++++++++++++++++++++++ src/haddock/haddock-script.csh | 61 ++++++++++++++--------------- 3 files changed, 116 insertions(+), 41 deletions(-) create mode 100644 src/GF/System/Tracing.hs diff --git a/src/GF/Parsing/ConvertFiniteGFC.hs b/src/GF/Parsing/ConvertFiniteGFC.hs index e9d32b321..2c66209d5 100644 --- a/src/GF/Parsing/ConvertFiniteGFC.hs +++ b/src/GF/Parsing/ConvertFiniteGFC.hs @@ -4,9 +4,9 @@ -- Stability : (stable) -- Portability : (portable) -- --- > CVS $Date: 2005/03/29 11:18:39 $ +-- > CVS $Date: 2005/03/29 11:58:46 $ -- > CVS $Author: peb $ --- > CVS $Revision: 1.1 $ +-- > CVS $Revision: 1.2 $ -- -- Calculating the finiteness of each type in a grammar ----------------------------------------------------------------------------- @@ -43,9 +43,11 @@ convertModule split (Mod mtyp ext op fl defs) where newDefs = solutions defMonad () () defMonad = member defs >>= convertDef split +---------------------------------------------------------------------- -- the main conversion function convertDef :: Splitable -> Def -> CnvMonad Def +-- converting abstract "cat" definitions convertDef split (AbsDCat cat decls cidents) = case splitableCat split cat of Just newCats -> do newCat <- member newCats @@ -59,8 +61,9 @@ convertDef split (AbsDCat cat decls cidents) case splitableCat split argCat of Nothing -> return (newCat, decl : newDecls) Just newArgs -> do newArg <- member newArgs - return (mergeCats "/" newCat newArg, newDecls) + return (mergeArg newCat newArg, newDecls) +-- converting abstract "fun" definitions 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) @@ -70,9 +73,13 @@ convertDef split (AbsDFun fun typ def) = do newTyp <- expandType split [] typ return (AbsDFun fun newTyp def) +-- converting concrete "lincat" definitions +-- convertDef split ( + convertDef _ def = return def --- expanding Exp's +---------------------------------------------------------------------- +-- expanding type expressions expandType :: Splitable -> [(Ident, Cat)] -> Exp -> CnvMonad Exp expandType split env (EProd x a@(EAtom (AC (CIQ mod cat))) b) = case splitableCat split cat of @@ -90,7 +97,7 @@ expandType 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)))) + = return (EAtom (AC (CIQ mod (foldl mergeArg 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 @@ -118,11 +125,11 @@ calcSplitable :: [Module] -> Splitable calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns) where splitableCats = tracePrt "splitableCats" (prtSep " ") $ groupPairs $ nubsort - [ (cat, mergeCats ":" fun cat) | (cat, fun) <- constantCats ] + [ (cat, mergeFun fun cat) | (cat, fun) <- constantCats ] splitableFuns = tracePrt "splitableFuns" (prtSep " ") $ nubsort - [ (fun, mergeCats ":" fun cat) | (cat, fun) <- constantCats ] + [ (fun, mergeFun fun cat) | (cat, fun) <- constantCats ] constantCats = tracePrt "constantCats" (prtSep " ") $ [ (cat, fun) | @@ -145,14 +152,22 @@ calcSplitable modules = (listAssoc splitableCats, listAssoc splitableFuns) ---------------------------------------------------------------------- +-- utilities +-- the main result category of a type expression 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) +-- mergeing categories +mergeCats :: String -> String -> String -> Cat -> Cat -> Cat +mergeCats before middle after (IC cat) (IC arg) + = IC (before ++ cat ++ middle ++ arg ++ after) + +mergeFun, mergeArg :: Cat -> Cat -> Cat +mergeFun = mergeCats "{" ":" "}" +mergeArg = mergeCats "" "" "" ---------------------------------------------------------------------- -- obsolete? diff --git a/src/GF/System/Tracing.hs b/src/GF/System/Tracing.hs new file mode 100644 index 000000000..b092949e8 --- /dev/null +++ b/src/GF/System/Tracing.hs @@ -0,0 +1,63 @@ +{-# OPTIONS -cpp #-} +---------------------------------------------------------------------- +-- | +-- Maintainer : PL +-- Stability : (stable) +-- Portability : (portable) +-- +-- > CVS $Date: 2005/03/29 11:58:46 $ +-- > CVS $Author: peb $ +-- > CVS $Revision: 1.1 $ +-- +-- Tracing utilities for debugging purposes. +-- If the CPP symbol TRACING is set, then the debugging output is shown. +----------------------------------------------------------------------------- + + +module GF.System.Tracing (trace, trace2, traceDot, traceCall, tracePrt) where + +import qualified IOExts + +-- | emit a string inside braces, before(?) calculating the value: +-- @{str}@ +trace :: String -> a -> a + +-- | emit function name and debugging output: +-- @{fun: out}@ +trace2 :: String -> String -> a -> a + +-- | emit a dot before(?) calculating the value, for displaying progress +traceDot :: a -> a + +-- | show when a value is starting to be calculated (with a '+'), +-- and when it is finished (with a '-') +traceCall :: String -> String -> (a -> String) -> a -> a + +-- | showing the resulting value (filtered through a printing function): +-- @{fun: value}@ +tracePrt :: String -> (a -> String) -> a -> a + +#if TRACING +trace str a = IOExts.trace (bold ++ "{" ++ normal ++ str ++ bold ++ "}" ++ normal) a +trace2 fun str a = trace (bold ++ fgcol 1 ++ fun ++ ": " ++ normal ++ str) a +traceDot a = IOExts.unsafePerformIO (putStr ".") `seq` a +traceCall fun start prt val + = trace2 ("+" ++ fun) start $ + val `seq` trace2 ("-" ++ fun) (prt val) val +tracePrt mod prt val = val `seq` trace2 mod (prt val) val +#else +trace _ = id +trace2 _ _ = id +traceDot = id +traceCall _ _ _ = id +tracePrt _ _ = id +#endif + + +escape = "\ESC" +highlight = escape ++ "[7m" +bold = escape ++ "[1m" +underline = escape ++ "[4m" +normal = escape ++ "[0m" +fgcol col = escape ++ "[0" ++ show (30+col) ++ "m" +bgcol col = escape ++ "[0" ++ show (40+col) ++ "m" diff --git a/src/haddock/haddock-script.csh b/src/haddock/haddock-script.csh index 289f3a3a3..a27cbf505 100644 --- a/src/haddock/haddock-script.csh +++ b/src/haddock/haddock-script.csh @@ -2,42 +2,42 @@ ###################################################################### # Author: Peter Ljunglöf -# Time-stamp: "2005-03-22, 06:24" -# CVS $Date: 2005/03/29 11:17:54 $ +# Time-stamp: "2005-03-29, 13:55" +# CVS $Date: 2005/03/29 11:58:45 $ # CVS $Author: peb $ # # a script for producing documentation through Haddock ###################################################################### -set base = `pwd` -set docdir = $base/haddock -set resourcedir = $base/haddock-resources +# set base = `pwd` +set docdir = haddock +set tempdir = .haddock-temp-files +set resourcedir = 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 '*/old-stuff/*' -not -path '*/for-*' -not -path '*/haddock*' -not -name 'Lex[GC]*' -not -name 'Par[GC]*'` $base/for-ghc-nofud/*.hs) +set files = (`find * -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) ###################################################################### echo 1. Creating and cleaning Haddock directory -echo -- $docdir +echo -- $docdir mkdir -p $docdir rm -r $docdir/* ###################################################################### -# echo -# echo 2. Selecting and soft linking Haskell files +echo +echo 2. Copying Haskell files to temporary directory ($tempdir) -# foreach d ($dirs) -# echo -- Directory: $d -# cd $base/$d -# foreach f (*.hs) -# ln -fs $base/$d/$f $docdir/$f -# # tr "\240" " " < $f > $docdir/$f -# end -# end +rm -r $tempdir + +foreach f ($files) + echo -- $f + mkdir -p `dirname $tempdir/$f` + perl -e 's/^#/-- CPP #/' $f > $tempdir/$f +end ###################################################################### @@ -53,36 +53,33 @@ rm -r $docdir/* ###################################################################### echo -echo 2. Invoking Haddock +echo 3. Invoking Haddock -# cd $docdir -haddock -o $docdir -h -t 'Grammatical Framework' $files +cd $tempdir +haddock -o ../$docdir -h -t 'Grammatical Framework' $files +cd .. ###################################################################### echo -echo 3. Restructuring to HTML framesets +echo 4. Restructuring to HTML framesets -cd $docdir echo -- Substituting for frame targets inside html files -mv index.html index-frame.html -foreach f (*.html) - perl -pe 's/ tempfile - mv tempfile $f +mv $docdir/index.html $docdir/index-frame.html +foreach f ($docdir/*.html) + perl -pe 's/ .tempfile + mv .tempfile $f end -cd $resourcedir echo -- Copying resource files: -echo -- `ls *.*` -cp *.* $docdir +echo -- `ls $resourcedir/*.*` +cp $resourcedir/*.* $docdir ###################################################################### echo -echo 4. Finished +echo 5. Finished echo -- The documentation is located at: echo -- $docdir/index.html -cd $base -