summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Parsing/ConvertFiniteGFC.hs33
-rw-r--r--src/GF/System/Tracing.hs63
-rw-r--r--src/haddock/haddock-script.csh61
3 files changed, 116 insertions, 41 deletions
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)
+
+rm -r $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
+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/<HEAD/<HEAD><BASE TARGET="contents"/; s/"index.html"/"index-frame.html"/; s/(<A HREF = "\S*index\S*.html")/$1 TARGET="index"/' $f > tempfile
- mv tempfile $f
+mv $docdir/index.html $docdir/index-frame.html
+foreach f ($docdir/*.html)
+ perl -pe 's/<HEAD/<HEAD><BASE TARGET="contents"/; s/"index.html"/"index-frame.html"/; s/(<A HREF = "\S*index\S*.html")/$1 TARGET="index"/' $f > .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
-
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 11:14:03 +0000