Commit 316e5288 authored by simonpj's avatar simonpj

[project @ 1997-03-17 20:35:10 by simonpj]

More small changes towards 2.02
parent b86d5b03
......@@ -20,6 +20,12 @@
Incidentally, hbc won't have this particular problem, because it
updates immediately.
NOTE: [March 97] Now that stack squeezing happens when GC happens,
the stack is squished at GC. So this program uses a small stack
in a small heap (eg 4m heap 2m stack), but in a big heap (no GC)
it needs a much bigger stack (10m)! It would be better to try GC/stack
squeezing on stack oflo.
-}
module Main where
......
......@@ -18,4 +18,4 @@ main = do
file_cts <- readFile (head args)
hPutStr stderr file_cts
trace "hello, trace" $
catch (getEnv "__WURBLE__" >> return ()) (\ e -> error "hello, error\n")
catch (getEnv "__WURBLE__" >> return ()) (\ e -> error "hello, error\n")
TOP = ../..
include $(TOP)/mk/boilerplate.mk
SRC_RUNTEST_OPTS += -x1
SRC_RUNTEST_OPTS += -x1 -iMain.hs Main.hs
include $(TOP)/mk/target.mk
"cg025"
["Main.hs"]
"/users/fp/partain/bin:/users/fp/partain/bin/sparc-sun-sunos4:/usr/local/bin:/usr/local/gnu/bin:/usr/local/gnu/bin/sparc-sun-sunos4:/usr/local/gnu/bin/mh/sparc-sun-sunos4:/usr/local/tex/bin/sparc-sun-sunos4:/local/fp/bin:/local/fp/bin/sparc-sun-sunos4:/local/fp/spat/shade.v8/bin:/local/fp/spat/spixtools.v8/bin:/local/sun4/bin:/usr/X11/local/bin:/usr/X11/bin:/bin:/usr/bin:/usr/ccs/bin:/sbin:/usr/ucb:/usr/etc:/etc:."
"/ogi/staff/simonpj/bin/sparc-sunos5:/projects/pacsoft/ghc/bin/sparc-sunos5:/projects/pacsoft/ghc/sparc-sunos5/bin:/projects/unsupported/bin/sparc-sunos5:/projects/pacsoft/bin/sparc-sunos5:/usr/openwin/bin:/ogi/staff/simonpj/bin/share:/usr/local/bin:/usr/local/gnu/bin:/usr/bin:/usr/ccs/bin:/bin:/usr/ucb:/usr/local/mh/bin:/usr/local/X11/bin:/usr/bin/X11:/usr/openwin/bin:/projects/pacsoft/ghc/bin/share:/projects/unsupported/bin/share:/projects/unsupported/gnu/share/bin:/usr/local/CenterLine/bin:/usr/local/frame/bin:/projects/pacsoft/tools/psutils:.:/projects/unsupported/gnu/sparc-sunos5/bin"
--!!! test various I/O Requests
--
--
import IO
import System
import Trace
import IOBase (trace)
--import Trace ToDo: get this via GlaExts -- SOF
main = do
prog <- getProgName
......@@ -20,7 +21,7 @@ main = do
file_cts <- readFile (head args)
hPutStr stderr file_cts
trace "hello, trace" $
catch (getEnv "__WURBLE__" >> return ()) (\ e -> error "hello, error\n")
catch (getEnv "__WURBLE__" >> return ()) (\ e -> error "hello, error\n")
Trace On:
hello, trace
Trace Off.
......
--!!! test various I/O Requests
--
--
import IO
import System
import IOBase (trace)
--import Trace ToDo: get this via GlaExts -- SOF
main = do
prog <- getProgName
hPutStr stderr (shows prog "\n")
args <- getArgs
hPutStr stderr (shows args "\n")
path <- getEnv "PATH"
hPutStr stderr (shows path "\n")
stdin_txt <- getContents
putStr stdin_txt
file_cts <- readFile (head args)
hPutStr stderr file_cts
trace "hello, trace" $
catch (getEnv "__WURBLE__" >> return ()) (\ e -> error "hello, error\n")
TOP = ../..
include $(TOP)/mk/boilerplate.mk
EXTRA_HC_OPTS += -fglasgow-exts
SRCS = Main.hs
SRC_HC_OPTS += -fglasgow-exts
include $(TOP)/mk/target.mk
TOP = ../..
include $(TOP)/mk/boilerplate.mk
SRC_HC_OPTS += -syslib ghc
EXTRA_RUNTEST_OPTS += +RTS -K2m -H10m -RTS
SRC_RUNTEST_OPTS += +RTS -H25m -RTS
include $(TOP)/mk/target.mk
......@@ -4,10 +4,9 @@ main =
getEnv "TERM" >>= \ term ->
putStr term >>
putChar '\n' >>
(getEnv "One fish, two fish, red fish, blue fish" >>= \ fish ->
putStr fish >> putChar '\n')
`catch`
(\ err ->putStr (show err) >> putChar '\n')
getEnv "One fish, two fish, red fish, blue fish" >>= \ fish ->
putStr fish >>
putChar '\n'
......
......@@ -2,6 +2,5 @@ TOP = ../..
include $(TOP)/mk/boilerplate.mk
SRC_RUNTEST_OPTS += -x1
include $(TOP)/mk/target.mk
Fail: I/O error: NoSuchThing: environment variable: One fish, two fish, red fish, blue fish
dumb
NoSuchThing: environment variable: One fish, two fish, red fish, blue fish
[".", "..", "Jmakefile", "Main.hi", "Main.hs", "Main.o", "Makefile", "io009", "io009.stdout"]
[".", "..", ".depend", "CVS", "Main.hi", "Main.hs", "Main.o", "Makefile", "io009", "io009.stdout"]
......@@ -8,7 +8,7 @@ the alignment data.
\begin{haskell}{Alignments}
> module Alignments(
> FrameData(..), Alignment(..), readAlignment,
> FrameData, Alignment, readAlignment,
> strip_off_frame_number
> ) where
......
......@@ -288,7 +288,7 @@ definition stands for ``tied-mixture continuation.''
> can't_read :: String -> String
> can't_read file = " can't read the file " ++ file
> make_tm_table = amap (\as -> array (1, length as) as) .
> make_tm_table = map (\as -> array (1, length as) as) .
> accumArray (flip (:)) [] phone_bounds
\end{haskell}
......
......@@ -7,8 +7,8 @@ vectors.
> module HmmDensities(
> module Native, module MathTypes, module Phones,
> GaussianComponent(..), TiedMixture(..), TmTable(..),
> LogDensityTable(..),
> GaussianComponent, TiedMixture(..), TmTable,
> LogDensityTable,
> eval_log_densities, readMixtures, readMixture, extern_to_intern
> ) where
......@@ -345,7 +345,7 @@ for efficient retrieval.
> eval_log_densities :: TmTable -> Vector -> LogDensityTable
> eval_log_densities tmt x = ldt
> where ldt = amap (amap eval_tied_mixture) tmt
> where ldt = map (map eval_tied_mixture) tmt
> eval_tied_mixture (Gm gm) = eval_log_mixture x gm
> eval_tied_mixture (Tie p k) = ldt!p!k
......
......@@ -15,10 +15,10 @@ their nature.
> module HmmDigraphs(
> module BalBinSTrees, -- needed for ghc to compile
> module Phones, module Pronunciations,
> ProbArc(..), ProbDigraphNode(..), ProbDigraphL(..),
> ProbDigraphA(..),
> HmmNetworkDic(..),
> HmmState(..), HmmData(..),
> ProbArc, ProbDigraphNode, ProbDigraphL,
> ProbDigraphA,
> HmmNetworkDic,
> HmmState, HmmData,
> HmmTsL(..), HmmTsA(..),
> buildHmm,
> readHmms, build_hmm_array,
......@@ -43,12 +43,12 @@ described in later chapters in Part~\ref{part:library}.
The modules \verb~Phones~ and \verb~Pronunciations~ were
defined in Chapters~\ref{ch:Phones} and~\ref{ch:Pronunciations},
respectively.
\begin{verbatim}
\begin{haskell}
> import Phones
> import Pronunciations
\end{verbatim}
\end{haskell}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
......@@ -655,7 +655,7 @@ the probabilities for all HMMs in an array.
\begin{haskell}{get_log_probs}
> get_log_probs :: (Ix a) => Array a (HmmTsL b) -> Array a (HmmTsL b)
> get_log_probs = amap convert_to_log_probs
> get_log_probs = map convert_to_log_probs
\end{haskell}
......
\begin{haskell}{MathTypes}
> module MathTypes( Vector(..) ) where
> module MathTypes( Vector ) where
\end{haskell}
......
......@@ -16,7 +16,7 @@ structure functions that read data files.
>#ifndef __GLASGOW_HASKELL__
> module Maybe,
>#endif
> MST(..),
> MST,
> returnMST, bindMST, thenMST
> ) where
......
......@@ -6,8 +6,8 @@ pronunciation models of words and utterances.
> module Pronunciations(
> module Phones,
> module BalBinSTrees, module MaybeStateT,
> Word(..), DigraphNode(..), Digraph(..), PrnNetwork(..),
> DictionaryEntry(..),
> Word, DigraphNode, Digraph, PrnNetwork(..),
> DictionaryEntry,
> readDictionary, readsPrnNetwork, showPrnNetwork,
> pre_hmm
> ) where
......
......@@ -19,7 +19,7 @@ the monadic style of programming, see~\cite{Partain93}.
\begin{haskell}{StateT}
> module StateT(
> ST(..),
> ST,
> returnST, bindST, bindST_, thenST, thenST_,
> startingFrom, startingWith, maplST, maprST
> ) where
......
......@@ -2,6 +2,9 @@
$Locker: $
$Log: HappyParser.ly,v $
Revision 1.4 1997/03/17 20:35:25 simonpj
More small changes towards 2.02
Revision 1.3 1997/03/14 08:08:08 simonpj
Major update to more-or-less 2.02
......@@ -124,9 +127,8 @@ here goes optCode:
> {
> happyError :: Int -> Int -> [Token'] -> a
> happyError s i ts = error ("Parse error in line " ++ show i ++
> " [state " ++ show s ++ "]" ++
> happyError :: Int -> [Token'] -> a
> happyError i ts = error ("Parse error in line " ++ show i ++
> case ts of
> [] -> " (at EOF)\n"
> _ -> "\n" ++ show (take 20 ts) ++ "\n")
......
......@@ -9,6 +9,9 @@
-- Status : Unknown, Use with caution!
--
-- $Log: IOSupplement.hs,v $
-- Revision 1.4 1997/03/17 20:35:25 simonpj
-- More small changes towards 2.02
--
-- Revision 1.3 1997/03/14 08:08:09 simonpj
-- Major update to more-or-less 2.02
--
......@@ -27,26 +30,26 @@
-- $Locker: $
--
module IOSupplement (PathCont, getPath, readPathFile)
where
module IOSupplement (
getPath, readPathFile
) where
import System -- 1.3
import IOBase ( IOError (..) )
import IO
import IOBase ( IOError, fail, userError )
--------------------------------------------------------------------------------
type PathCont = [String] -> IO ()
type FailCont = IOError -> IO ()
type StrCont = String -> IO ()
getPath :: String -> [String] -> PathCont -> IO ()
--
-- accepts the name of an environment variable and a [String] of default paths
getPath :: String -> [String] -> IO [String]
-- Accepts the name of an environment variable and a [String] of default paths
-- and calls the continuation (::PathCont) with the resulting search path
--
getPath envVar dflt cont =
(do {path <- getEnv envVar; cont (manglePath path dflt)})
getPath envVar dflt =
(do {path <- getEnv envVar; return (manglePath path dflt)})
`catch`
(\ (NoSuchThing _) -> cont dflt)
(\ _ -> return dflt)
-- mangle a colon separated pathstring with a default path
......@@ -61,25 +64,21 @@ manglePath cs dflt = case span (/= ':') cs of
--------------------------------------------------------------------------------
readPathFile :: [String] -> String -> FailCont -> StrCont -> IO ()
--
readPathFile :: [String] -> String -> IO String
-- readPathFile searchPath fileName fc sc
-- scan searchPath for fileName and read it
-- unless fileName starts with '.' or is absolute (starts with '/')
--
readPathFile _ fileName@('/':_) fc sc = myreadFile fileName fc sc
readPathFile _ fileName@('.':_) fc sc = myreadFile fileName fc sc
readPathFile [] fileName fc sc =
fc (userError ("readPathFile failed on :" ++ fileName))
readPathFile (path: paths) fileName fc sc =
-- appendChan stderr ("Trying path "++fullName++"...\n") exit
(myreadFile fullName failCont sc)
where
fullName = path ++ '/': fileName
failCont _ = readPathFile paths fileName fc sc
readPathFile _ fileName@('/':_) = readFile fileName
readPathFile _ fileName@('.':_) = readFile fileName
readPathFile [] fileName
= fail (userError ("readPathFile failed on :" ++ fileName))
readPathFile (path: paths) fileName
= readFile fullName `catch`
(\ _ -> readPathFile paths fileName)
where
fullName = path ++ '/': fileName
myreadFile :: String -> FailCont -> StrCont -> IO ()
myreadFile filename fc sc
= catch (readFile filename >>= \ cts -> sc cts)
fc
......@@ -9,6 +9,9 @@
-- Status : Unknown, Use with caution!
--
-- $Log: Main.hs,v $
-- Revision 1.4 1997/03/17 20:35:26 simonpj
-- More small changes towards 2.02
--
-- Revision 1.3 1997/03/14 08:08:10 simonpj
-- Major update to more-or-less 2.02
--
......@@ -33,6 +36,7 @@
module Main (main)
where
import IO
import IOSupplement
import CommandLine (parse_cmds)
import StringMatch (stringMatch)
......@@ -76,51 +80,59 @@ program
psOutput figOutput
helpFlag verbose strs
| length strs < 2 || helpFlag =
getProgName >>= \ progName ->
hPutStr stderr
("Usage: "++progName++" [options] BNFfile Nonterminal ...\n"
++unlines usageBlurb)
("Usage: ebnf2ps [options] BNFfile Nonterminal ...\n"
++unlines usageBlurb)
| otherwise =
getPath "AFMPATH" afmPathDefault >>= \afmPath ->
readPathFile afmPath (ntFontName++".afm") >>= \ntAFM ->
readPathFile afmPath (tFontName++".afm") >>= \tAFM ->
let
fc = \_ -> message "Color database not found, using fall back data\n" (sc "")
sc = \rgbFileContents ->
let colorTable = prepareColors rgbFileContents
do
afmPath <- getPath "AFMPATH" afmPathDefault
ntAFM <- readPathFile afmPath (ntFontName++".afm")
tAFM <- readPathFile afmPath (tFontName++".afm")
rbgPath <- getPath "RGBPATH" rgbPathDefault
rgbFileContents <- readPathFile rgbPath rgbFileName
`catch`
(do
message "Color database not found, using fall back data\n"
return "")
let
colorTable = prepareColors rgbFileContents
[ntColor, tColor, lineColor, fatLineColor]
colorInfo@(c1,c2,c3,c4) = (lookupColor ntColor colorTable,
colorInfo@(c1,c2,c3,c4) = (lookupColor ntColor colorTable,
lookupColor tColor colorTable,
lookupColor lineColor colorTable,
lookupColor fatLineColor colorTable)
info = (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize,
info = (borderDistX, borderDistY, lineWidth, fatLineWidth, arrowSize,
makeFont ntFontName ntFontScale ntAFM,
makeFont tFontName tFontScale tAFM,
colorInfo)
in
message ("using colors: "++(showsColor c1 . showsColor c2 .
showsColor c3 . showsColor c4)
"\nfrom rgbPathDefault: "++show rgbPathDefault) (
getPath "EBNFINPUTS" ebnfInputDefault (\inputPath ->
message ("generating nonterminals: "++show nonterminals++
message ("using colors: "++(showsColor c1 . showsColor c2 .
showsColor c3 . showsColor c4)
"\nfrom rgbPathDefault: "++show rgbPathDefault)
inputPath <- getPath "EBNFINPUTS" ebnfInputDefault
message ("generating nonterminals: "++show nonterminals++
"\nfrom "++bnfName++
"\nusing input path "++show inputPath) (
readPathFile inputPath bnfName exit (\bnfContent ->
if happyInput then
let rawInput = theHappyParser bnfContent
prods | doSimplify = simplify rawInput
| otherwise = rawInput
in message "using happyInput"
(writeAll outExtension (layoutAll outWrapper info prods nonterminals) done)
else
case map (if doSimplify then simplify else id) (parseAll bnfContent) of
prods:_ ->
message "using ebnfInput"
(writeAll outExtension (layoutAll outWrapper info prods nonterminals) done)
_ -> appendChan stderr ("Could not parse "++bnfName++"\n") exit done))))
in
getPath "RGBPATH" rgbPathDefault (\rgbPath ->
readPathFile rgbPath rgbFileName fc sc)
"\nusing input path "++show inputPath)
bnfContent <- readPathFile inputPath bnfName
if happyInput then
let rawInput = theHappyParser bnfContent
prods | doSimplify = simplify rawInput
| otherwise = rawInput
in do
message "using happyInput"
writeAll outExtension (layoutAll outWrapper info prods nonterminals)
else
case map (if doSimplify then simplify else id) (parseAll bnfContent) of
prods:_ -> do
message "using ebnfInput"
writeAll outExtension (layoutAll outWrapper info prods nonterminals)
_ -> hPutStr stderr ("Could not parse "++bnfName++"\n")
where
afmPathDefault = ["/usr/local/tex/Adobe", "/usr/local/tex/lib/TeXPS/afm", "."]
ebnfInputDefault = ["."]
......@@ -176,19 +188,15 @@ usageBlurb =
--------------------------------------------------------------------------------
writeAll ext [] cont = cont
writeAll ext ((ntName, content): more) cont =
appendChan stdout content (\(WriteError str) ->
--partain: writeFile fileName content (\(WriteError str) ->
appendChan stderr ("Problem writing "++fileName++" :"++str) exit writeNext)
writeNext
where
writeNext = writeAll ext more cont
fileName = ntName ++ ext
writeAll ext [] = return ()
writeAll ext ((ntName, content): more)
= do
hPutStr stdout content
writeAll ext more
--------------------------------------------------------------------------------
str2int :: String -> Int
str2int s = case readDec s of
[] -> 0
(x,_):_ -> x
str2int s = case reads s of
[] -> 0
(x:_) -> x
......@@ -58,6 +58,5 @@ picture n = go n pic
go :: Int -> Csg -> [Char]
-- go n = (cdraw n) . quadoct . (octcsg n)
go n = (cdraw n) . quadoct . (octcsg n)
TOP = ../..
include $(TOP)/mk/boilerplate.mk
# Bah.hs is a test file, which we don't want in SRCS,
# so we list the ones we do want explicitly
SRCS = Csg.hs Fulsom.hs Interval.hs Kolor.hs Matrix.hs Oct.hs Patchlevel.hs \
Quad.hs Raster.hs Shapes.hs Types.hs Vector.hs
SRC_RUNTEST_OPTS += 7
include $(TOP)/mk/target.mk
......
TOP = ../..
include $(TOP)/mk/boilerplate.mk
-include opts.mk
include $(TOP)/mk/target.mk
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
# Without this we get the C version too!
SRCS = $(wildcard *.lhs *.hs)
SRC_HC_OPTS += -cpp -fglasgow-exts
SRC_RUNTEST_OPTS += -o1 nucleic2.stdout1 -o1 nucleic2.stdout2
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment