The latest GHC chokes on the latest HaskellDirect file src/Utils.lhs.
Here is a copy of error message and attached is the src/Utils.lhs file.
It will be seen from the file that ghc is objecting to an explicit
universal quantification. What should I do?
------------------------------------------------------------------------
===fptools== Recursively making `all' in src lib examples doc ...
PWD = /export/ger/fptools/hdirect
------------------------------------------------------------------------
------------------------------------------------------------------------
==fptools== gmake all -r;
in /export/ger/fptools/hdirect/src
------------------------------------------------------------------------
../../ghc/driver/ghc -syslib exts -Rghc-timing -H16m -W -recomp -O -O2-for-C -H30m
-c Utils.lhs -o Utils.o -osuf o
ghc: ignoring heap-size-setting option (-H16m)...not the largest seen
Utils.lhs:345: parse error on input `.'
Compilation had errors
%
% @(#) $Docid: May. 24th 1999 17:42 Sigbjorn Finne $
% @(#) $Contactid: [EMAIL PROTECTED] $
%
\begin{code}
module Utils
( showOct
, showHex
, mapFromMb
, mapMb
, mapMbM
, concMaybe
, split
, prefix
, traceIf
, elemBy
, mapUnzip
, diff
, deEscapeString
, (#)
--,UNUSED: catMapMaybes
, dropSuffix
-- re-exported
, trace
, tryOpen
, basename
, prefixDir
, hdirect_root
, bailIf
, decons
, safe_init
, mapAccumLM
, readTaggedFields
, read_int
, read_string
, read_bool
, read_qid
, FieldInfo(..)
) where
--import NumExts
import Char (chr, ord, readLitChar, isSpace, isAlphaNum)
import IOExts
import IO
{- BEGIN_GHC_ONLY
import Directory
END_GHC_ONLY -}
import Monad ( when )
import List ( mapAccumL, nub, isPrefixOf )
infixl 1 #
\end{code}
A convenience operator for invoking methods on objects:
\begin{code}
obj # meth = meth obj
\end{code}
Until NumExts is commonly available, we define the following show functions here:
\begin{code}
showIntAtBase :: Integral a => a -> (a -> Char) -> a -> ShowS
showIntAtBase base toChr n r
| n < 0 = '-':showIntAtBase 10 toChr (negate n) r
| otherwise =
case quotRem n base of { (n', d) ->
case toChr d of { ch ->
let
r' = ch : r
in
if n' == 0 then r' else showIntAtBase base toChr n' r'
}}
showHex :: Integral a => a -> ShowS
showHex n r =
showString "0x" $
showIntAtBase 16 (toChrHex) n r
where
toChrHex d
| d < 10 = chr (ord_0 + fromIntegral d)
| otherwise = chr (ord 'a' + fromIntegral (d - 10))
showOct :: Integral a => a -> ShowS
showOct n r =
showString "0o" $
showIntAtBase 8 (toChrOct) n r
where toChrOct d = chr (ord_0 + fromIntegral d)
ord_0 :: Num a => a
ord_0 = fromInt (ord '0')
\end{code}
Mapping from a Maybe:
\begin{code}
mapFromMb :: b -> (a -> b) -> Maybe a -> b
mapFromMb d f mb = case mb of Nothing -> d ; Just v -> f v
\end{code}
\begin{code}
split :: Eq a => a -> [a] -> [[a]]
split a [] = []
split a as =
case break (==a) as of
(xs,[]) -> [xs]
(xs,_:ys) -> xs:split a ys
\end{code}
\begin{code}
prefix :: Eq a => [a] -> [a] -> Maybe [a] -- what's left
prefix [] ls = Just ls
prefix ls [] = Nothing
prefix (x:xs) (y:ys)
| x == y = prefix xs ys
| otherwise = Nothing
\end{code}
\begin{code}
traceIf :: Bool -> String -> a -> a
traceIf True str v = trace str v
traceIf _ _ v = v
elemBy :: (a -> Bool) -> [a] -> Bool
elemBy isEqual [] = False
elemBy isEqual (y:ys) = isEqual y || elemBy isEqual ys
mapUnzip :: (a -> (b,c)) -> [a] -> ([b],[c])
mapUnzip f [] = ([],[])
mapUnzip f (x:xs) =
let
(a, b) = f x
(as,bs) = mapUnzip f xs
in
(a:as,b:bs)
\end{code}
Returns list of deltas, i.e,
@
diff [x0,x1..xp,xn] = [x0, x1-x0, .., xp - xn]
@
\begin{code}
diff :: Num a => [a] -> [a]
diff ls = snd (mapAccumL ( \ acc v -> (v, v - acc)) 0 ls)
\end{code}
\begin{code}
catMapMaybes :: (a -> b) -> [Maybe a] -> [b]
catMapMaybes f ls = [f x | Just x <- ls]
\end{code}
Dropping the extension off of a filename:
\begin{code}
dropSuffix :: String -> String
dropSuffix str =
case dropWhile (\ch -> ch /= '.' && ch /= '/' && ch /= '\\' )
(reverse str) of
('.':rs) -> reverse rs
_ -> str
-- give up if we reach a separator (/ or \) or end of list.
dropPrefix :: Eq a => [a] -> [a] -> [a]
dropPrefix [] ys = ys
dropPrefix xs [] = []
dropPrefix (x:xs) (y:ys)
| x == y = dropPrefix xs ys
| otherwise = y:ys
\end{code}
Slightly generalised version of code found in Green Card's front end:
\begin{code}
tryOpen :: Bool
-> [FilePath]
-> [String]
-> FilePath
-> IO (Maybe FilePath)
tryOpen verbose path exts name =
doUntil (mbOpenFile verbose) (allFileNames path name exts)
doUntil :: (a -> IO (Maybe b)) -> [a] -> IO (Maybe b)
doUntil f [] = return Nothing
doUntil f (a:as) = do
v <- f a
case v of
Nothing -> doUntil f as
Just k -> return v
allFileNames :: [String] -> String -> [String] -> [String]
allFileNames path file exts
= [addSuffix '/' d ++ file ++ (prefixWith '.' ext) | d <- path, ext <- exts]
where
addSuffix ch [] = []
addSuffix ch ls =
case (decons ls) of
(xs,x)
| x == ch -> ls
| otherwise -> ls++[ch]
prefixWith ch [] = []
prefixWith ch ls@(x:xs)
| ch == x = ls
| otherwise = ch:ls
\end{code}
Combining <tt>last</tt> and <tt>init</tt> into one (pass
over the list):
\begin{code}
decons :: [a] -> ([a],a)
decons xs = trundle xs
where
trundle [] = error "decons: empty list"
trundle [x] = ([], x)
trundle (x:xs) = let (ls, l) = trundle xs in (x:ls, l)
\end{code}
Try reading a file:
\begin{code}
mbOpenFile :: Bool -> FilePath -> IO (Maybe FilePath)
mbOpenFile verbose fpath = do
-- I seem to remember that Hugs doesn't support Directory...
{- BEGIN_GHC_ONLY
flg <- doesFileExist fpath
END_GHC_ONLY -}
{- BEGIN_NOT_FOR_GHC -}
flg <- (openFile fpath ReadMode >>= \ h -> hClose h >> return True)
`catch` (\ _ -> return False)
{- END_NOT_FOR_GHC -}
if not flg
then return Nothing
else do
when verbose (hPutStrLn stderr ("Reading file: " ++ show fpath))
return (Just fpath)
\end{code}
\begin{code}
basename :: String -> String
basename str = go str str
where
-- bi-lingual, the upshot of which is that
-- / isn't allowed in DOS-style paths (and vice
-- versa \ isn't allowed in POSIX(?) style pathnames).
go acc [] = acc
go acc ('/':xs) = go xs xs
go acc ('\\':xs) = go xs xs
go acc (_:xs) = go acc xs
prefixDir :: String -> String -> String
prefixDir [] rest = rest
prefixDir ['/'] rest = '/':rest
prefixDir ['\\'] rest = '/':rest
prefixDir [x] rest = x:'/':rest
prefixDir (x:xs) rest = x : prefixDir xs rest
\end{code}
Removing escape char from double quotes:
\begin{code}
deEscapeString :: String -> String
deEscapeString [] = []
deEscapeString ls@('\\':x:xs) =
case x of
'"' -> x : deEscapeString xs
_ ->
case readLitChar ls of
((ch,rs):_) -> ch : deEscapeString rs
_ -> '\\':x: deEscapeString xs
deEscapeString (x:xs) = x: deEscapeString xs
\end{code}
The top of the HaskellDirect Registry tree:
\begin{code}
hdirect_root = "Software\\Haskell\\HaskellDirect"
-- sporadically handy in a monadic context.
bailIf :: Bool -> a -> a -> a
bailIf True a b = a
bailIf _ _ b = b
\end{code}
Avoids Haskell version trouble:
\begin{code}
mapMb :: (a -> b) -> Maybe a -> Maybe b
mapMb f Nothing = Nothing
mapMb f (Just c) = Just (f c)
mapMbM :: (Monad m) => (a -> m b) -> Maybe a -> m (Maybe b)
mapMbM f Nothing = return Nothing
mapMbM f (Just c) = f c >>= return.Just
concMaybe :: Maybe a -> Maybe a -> Maybe a
concMaybe v@(Just x) _ = v
concMaybe _ v = v
\end{code}
\begin{code}
safe_init :: [a] -> [a]
safe_init [] = []
safe_init ls = init ls
\end{code}
\begin{code}
mapAccumLM :: (Monad m)
=> (acc -> x -> m (acc, y)) -- Function of elt of input list
-- and accumulator, returning new
-- accumulator and elt of result list
-> acc -- Initial accumulator
-> [x] -- Input list
-> m (acc, [y]) -- Final accumulator and result list
mapAccumLM f s [] = return (s, [])
mapAccumLM f s (x:xs) = do
(s', y) <- f s x
(s'',ys) <- mapAccumLM f s' xs
return (s'',y:ys)
\end{code}
\begin{code}
data FieldInfo a
= forall i . -- not really needed, but convenient.
FieldInfo
String -- field label
Bool -- True => optional
(String -> Maybe (i,String))
(i -> a -> a)
readTaggedFields :: [FieldInfo a]
-> (String -> a)
-> String
-> ([a],[String])
readTaggedFields finfo init_val = \ str -> go [] [] (consumeWhiteSpace str)
where
go vals errs [] = (reverse vals, reverse errs)
go vals errs str =
case readTaggedField finfo init_val str of
Left (v, rs, warns) -> go (v:vals) (warns ++ errs) (consumeWhiteSpace rs)
Right (_,non_occs, warns, rs, _) ->
let
rs' = dropWhile (/= '}') rs
in
go vals (map missingField non_occs ++ warns ++ errs) (consumeWhiteSpace rs')
readField :: [FieldInfo a]
-> a
-> String
-> Either (a,String,[String])
([String],[String],[String],String,a)
readField finfo val = \ str ->
case (readTags val str [] []) of
(val, occs, errs, rs)
| allOptionsThere occs -> Left (val, rs, errs)
| otherwise -> Right (nub occs, notOccs occs, errs, rs, val)
where
notOccs occs =
filter (\ x -> not (isOptional x) && not (x `elem` occs)) not_opt_labels
allOptionsThere occs = all (\ x -> x `elem` occs) not_opt_labels
isOptional x =
case (filter (\ (FieldInfo y _ _ _) -> y == x) finfo) of
(FieldInfo _ is_opt _ _):_ -> is_opt
_ -> False
not_opt_labels =
map (\ (FieldInfo s _ _ _) -> s) $
filter (\ (FieldInfo _ is_opt _ _) -> not is_opt) finfo
peelOfSeps xs str =
let
str' = consumeWhiteSpace str
go xs [] = xs
go xs (l:ls)
| l `isPrefixOf` xs = dropPrefix l xs
| otherwise = go xs ls
in
go str' xs
peelOfFieldSep = peelOfSeps labSeps
peelOfSep = peelOfSeps [fieldSep]
-- hard-wire these
fieldSep = ";"
labSeps = [":","="]
term_string = "}"
readTags val str occs errs =
let
str' = consumeWhiteSpace str
final_str = dropPrefix term_string str'
in
if term_string `isPrefixOf` str' then
(val, occs, errs, final_str)
else
case (span isIdentChar str') of
(tag,xs) ->
let
str' = consumeWhiteSpace (peelOfFieldSep xs)
-- unrecognised tag; spool its past value and cont..
str'' = peelOfSep (dropWhile (not.isSpace) str')
in
case lookupTag finfo tag of
Nothing -> readTags val str'' occs (unknownTag tag : errs)
Just (is_opt, rd_n_upd) ->
case rd_n_upd str' of
Nothing -> readTags val str'' occs (unknownValue tag str' :errs)
Just (updater,str'') ->
let
new_str = peelOfSep (consumeWhiteSpace str'')
new_val = updater val
in
readTags new_val new_str (tag:occs) errs
readTaggedField :: [FieldInfo a]
-> (String -> a)
-> String
-> Either (a,String,[String])
([String],[String],[String],String,a)
readTaggedField finfo init_val = \ str ->
case span (isIdentChar) str of
(tag, rs) ->
let
val = init_val tag
str' = consumeWhiteSpace (dropPrefix "{" (consumeWhiteSpace rs))
in
readField finfo val str'
isIdentChar :: Char -> Bool
isIdentChar x = isAlphaNum x || x `elem` ['_','\'']
missingField :: String -> String
missingField tag = "required tag " ++ show tag ++ " not found."
unknownTag :: String -> String
unknownTag tag =
"tag " ++ show tag ++ " not found (ignored)."
unknownValue :: String -> String -> String
unknownValue tag str =
"tag " ++ show tag ++ " had illegal field val: " ++ take 10 str
consumeWhiteSpace :: String -> String
consumeWhiteSpace xs =
case (dropWhile isSpace xs) of
'#':xs -> dropWhile (/='\n') xs
ls -> ls
lookupTag :: [FieldInfo a] -> String -> Maybe (Bool, String -> Maybe (a->a, String))
lookupTag [] tag = Nothing
lookupTag (x@(FieldInfo str is_opt _ _):xs) tag
| str == tag =
let
combineFields (FieldInfo _ _ rd upd) =
\ str -> case rd str of { Nothing -> Nothing ; Just (i,str') -> Just (upd
i,str') }
in
Just (is_opt, combineFields x)
| otherwise = lookupTag xs tag
read_int :: String -> Maybe (Int, String)
read_int str =
case reads str of
((x,str'):_) -> Just ((x::Int), str')
_ -> Nothing
read_string :: String -> Maybe (String, String)
read_string str =
case reads str of
((x,str'):_) -> Just ((x::String), str')
_ -> Nothing
read_id :: String -> Maybe (String, String)
read_id str =
case lex str of
((x,str'):_) -> Just ((x::String), str')
_ -> Nothing
read_qid :: String -> Maybe (String, String)
read_qid str =
case lex str of
((x,str'):_) ->
case str' of
'.':xs -> case lex xs of
((y,ys):_) -> Just (x ++ '.':y, ys)
_ -> Just ((x::String), str')
_ -> Just ((x::String), str')
_ -> Nothing
read_bool :: String -> Maybe (Bool, String)
read_bool str =
case reads str of
((x,str'):_) -> Just ((x::Bool), str')
_ -> Nothing
\end{code}
