mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
"Committed_by_peb"
This commit is contained in:
peb
@@ -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?
|
||||
|
||||
63
src/GF/System/Tracing.hs
Normal file
63
src/GF/System/Tracing.hs
Normal file
@@ -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"
|
||||
@@ -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/<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
|
||||
|
||||
|
||||
|
||||
Reference in New Issue
Block a user