The attached file MonadLibrary.lhs compiles without optimization, but with
optimization on the following message is printed:
lips> ghc-4.04 -O -c -fglasgow-exts MonadLibrary.lhs
panic! (the `impossible' happened):
mk_cpr_let: not a product
forall a{-ruq-} b{-rur-}.
(a{-ruq-} -> b{-rur-})
-> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} a{-ruq-}
-> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} b{-rur-}
Please report it as a compiler bug to [EMAIL PROTECTED]
I downloaded the binary distribution from
http://research.microsoft.com/users/t-simonm/ghc/dist/4.04/ghc-4.04-sparc-sun-solaris2.tar.g
More details follow, and the full sourcecode for the imported modules are
attached.
Patrik Jansson
----------------------------------------------------------------
lips> uname -a
SunOS lips.cs.chalmers.se 5.6 Generic_105181-12 sun4u sparc SUNW,Ultra-4
lips> ghc-4.04 -v -O -c -fglasgow-exts MonadLibrary.lhs >& err
lips> cat err
The Glorious Glasgow Haskell Compilation System, version 4.04, patchlevel 0
literate pre-processor:
/usr/pd/lib/ghc-4.04/unlit MonadLibrary.lhs - >> /tmp/ghc2828.lpp
real 0.0
user 0.0
sys 0.0
Effective command line: -v -O -c -fglasgow-exts
Ineffective C pre-processor:
echo '{-# LINE 1 "MonadLibrary.lhs" -}' > /tmp/ghc2828.cpp && cat
/tmp/ghc2828.lpp >> /tmp/ghc2828.cpp
real 0.0
user 0.0
sys 0.0
Haskell compiler:
/usr/pd/lib/ghc-4.04/hsc /tmp/ghc2828.cpp -fglasgow-exts -ffoldr-build-on
-fdo-eta-reduction -fdo-lambda-eta-expansion -fcase-of-case -fcase-merge -flet-to-case
-fpedantic-bottoms -fsimplify [ -finline-phase0 -fmax-simplifier-iterations2 ]
-fspecialise -ffull-laziness -ffloat-inwards -fsimplify [ -finline-phase1
-fmax-simplifier-iterations4 ] -fsimplify [ -finline-phase2
-fmax-simplifier-iterations4 ] -fstrictness -fcpr-analyse -fworker-wrapper -fsimplify
[ -fmax-simplifier-iterations4 ] -fcse -ffull-laziness -ffloat-inwards -fsimplify [
-fmax-simplifier-iterations4 ] -flet-no-escape -fwarn-overlapping-patterns
-fwarn-missing-methods -fwarn-duplicate-exports -fhi-version=404 -static
-himap=.%.hi:/usr/pd/lib/ghc-4.04/imports/exts%.hi:/usr/pd/lib/ghc-4.04/imports/exts%.hi:/usr/pd/lib/ghc-4.04/imports/std%.hi
-v -hifile=/tmp/ghc2828.hi -C=/tmp/ghc2828.hc -F=/tmp/ghc2828_stb.c
-FH=/tmp/ghc2828_stb.h +RTS -H6000000 -K1000000
Glasgow Haskell Compiler, version 4.04, for Haskell 98, compiled by GHC version 4.04
panic! (the `impossible' happened):
mk_cpr_let: not a product
forall a{-ruq-} b{-rur-}.
(a{-ruq-} -> b{-rur-})
-> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} a{-ruq-}
-> MonadLibrary.StateM{-r2o,x-} m{-a30Y-} s{-a30Z-} b{-rur-}
Please report it as a compiler bug to [EMAIL PROTECTED]
real 4.8
user 4.6
sys 0.1
deleting... /tmp/ghc2828.lpp /tmp/ghc2828.cpp /tmp/ghc2828.hi /tmp/ghc2828.hc
/tmp/ghc2828_stb.c /tmp/ghc2828_stb.h
rm -f /tmp/ghc2828*
-----------------------------------------------
PS. when compiling the same module without -O I do get warnings, but I
guess these are unrelated to the above problem.
lips> ghc-4.04 -c -fglasgow-exts MonadLibrary.lhs
ghc-4.04: module version changed to 1; reason: no old .hi file
/tmp/ghc2720.hc:316: warning: `s4tO_closure' was declared `extern' and
later `static'
/tmp/ghc2720.hc:1123: warning: `s4ub_closure' was declared `extern' and
later `static'
/tmp/ghc2720.hc:3713: warning: `s4uU_closure' was declared `extern' and
later `static'
\chapter{Monad library}
\begin{verbatim}
> module MonadLibrary(module StateFix,
> State ,updateST ,fetchST ,executeST ,
> StateM(..),updateSTM,fetchSTM,executeSTM,mliftSTM,
> (<@),(<@-),(<*>),(<:*>),(<<),(@@),(<|),(+++),mIf,
> applyM,applyM2,
> Error(..),unDone,noErrorFilter,errorToList,
> LErr,unLErr,mapLErr,showLErr,handleError,
> STErr,mliftErr,convertSTErr,ErrorMonad(failEM),
> changeError,
> OutputT,output,runOutput,mliftOut,
> mapl,foreach,liftop,map0,map1,map2,mfoldl,mfoldr,
> mZero,mplus,
> accumseq,accumseq_,mguard) where
> import StateFix
> import MyPrelude(pair,mapFst,fMap)
> import Monad(MonadPlus(..),join)
> infixl 9 <@
> infixl 9 <@-
> infixr 9 @@
> infixr 9 <*>
> infixl 7 <|
> infixr 5 +++
> infixr 1 <<
> mZero :: MonadPlus m => m a
> mZero = mzero
> mguard :: MonadPlus m => Bool -> m ()
> mguard b = if b then return () else mZero
> (+++) :: MonadPlus m => m a -> m a -> m a
> (+++) = mplus
\end{verbatim}
\section{Monad based utilities}
Function \texttt{accumseq} is called \texttt{sequence} in Haskell 98
but earlier \textt{accumulate}.
\begin{verbatim}
> accumseq :: Monad m => [m a] -> m [a]
> accumseq = mapM id
> accumseq_ :: Monad m => [m a] -> m ()
> accumseq_ = foldr (>>) (return ())
> (<@) :: Functor f => f a -> (a -> b) -> f b
> x <@ f = fMap f x
> (<@-) :: Functor f => f a -> b -> f b
> x <@- e = fMap (\_->e) x
join :: Monad m => m (m a) -> m a
join x = x >>= id
Removed from the prelude: (renamed to (=<<))
> applyM :: Monad m => (a -> m b) -> m a -> m b
> applyM = flip (>>=)
> applyM2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c
> applyM2 f ma mb = ma >>= \a -> mb >>= \b -> f a b
> --applyM2 f ma mb = ma >>= (mb >>=) . f
> (@@) :: Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
> (@@) f g x = g x >>= f
The original LHS: {\tt (f @@ g) x} proves not to be allowed by
Haskell 1.4. (Though it should be, in my opinion.) It is OK in Haskell 98.
> mfoldl :: Monad m => (a -> b -> m a) -> a -> [b] -> m a
> mfoldl _ a [] = return a
> mfoldl f a (x:xs) = f a x >>= (\fax -> mfoldl f fax xs)
> mfoldr :: Monad m => (a -> b -> m b) -> b -> [a] -> m b
> mfoldr _ a [] = return a
> mfoldr f a (x:xs) = mfoldr f a xs >>= (\y -> f x y)
> mapl :: Monad m => (a -> m b) -> ([a] -> m [b])
> mapl _ [] = return []
> mapl f (x:xs) = f x >>= \y -> mapl f xs >>= \ys -> return (y:ys)
> mapr :: Monad m => (a -> m b) -> ([a] -> m [b])
> mapr _ [] = return []
> mapr f (x:xs) = mapr f xs >>= \ys -> f x >>= \y-> return (y:ys)
> mIf :: Monad m => m Bool -> m a -> m a -> m a
> mIf mb t f = mb >>= \b-> if b then t else f
> (<|) :: MonadPlus m => m a -> (a -> Bool) -> m a
> m <| p = m >>= \x -> if p x then return x else mZero
\end{verbatim}
\section{IO and ST monads}
Hugs:
\begin{verbatim}
instance Functor (ST a) where
map f sta = sta `thenST` \a -> return (f a)
\end{verbatim}
\section{Error monad}
\begin{verbatim}
> class Monad m => ErrorMonad m where
> failEM :: String -> m a
> data Error a = Done a
> | Err String
> deriving (Show, Eq)
> instance Functor Error where
> fmap f (Done x) = Done (f x)
> fmap _ (Err s) = Err s
> instance Monad Error where
> return = Done
> Done x >>= f = f x
> Err msg >>= _ = Err msg
> instance ErrorMonad Error where
> failEM = Err
> unDone :: Error a -> a
> unDone (Done x) = x
> unDone (Err s) = error s
> type LErr a = (a,Error ())
> showLErr :: Show a => LErr a -> String
> showLErr (x,err) = show x ++ handleError id (fMap (\_->"") err)
> mapLErr :: (a->b) -> LErr a -> LErr b
> mapLErr = mapFst
> unLErr :: LErr a -> a
> unLErr = handleLErr (error.("MonadLibrary.handleLErr:"++))
> handleLErr :: (String -> a) -> LErr a -> a
> handleLErr _ (x,Done ()) = x
> handleLErr def (_,Err msg) = def msg
> handleError :: (String -> a) -> Error a -> a
> handleError d = h
> where h (Done x) = x
> h (Err mess) = d mess
> errorToList :: Error a -> [a]
> errorToList (Err msg) = []
> errorToList (Done x) = [x]
> noErrorFilter :: [Error a] -> [a]
> noErrorFilter = concatMap errorToList
> instance ErrorMonad [] where
> failEM _ = []
\end{verbatim}
\section{IOErr monad}
\begin{verbatim}
> newtype IOErr a = IOErr (IO (Error a))
> {- in mapIOE, returnIOE, bindIOE, failIOE,
> liftIOtoIOErr, dropIOErrtoIO, dropError -}
>
> mapIOE :: (a -> b) -> (IOErr a) -> (IOErr b)
> mapIOE f (IOErr xs) = IOErr (xs <@ fMap f)
>
> instance Functor IOErr where
> fmap = mapIOE
>
> returnIOE :: a -> IOErr a
> returnIOE x = IOErr (return (Done x))
>
> bindIOE :: IOErr a -> (a -> IOErr b) -> IOErr b
> (IOErr xs) `bindIOE` f
> = IOErr (xs >>= \x ->
> case x of
> Done a -> unIOErr (f a)
> Err msg -> return (Err msg)
> )
> where unIOErr (IOErr x) = x
>
> instance Monad IOErr where
> return = returnIOE
> (>>=) = bindIOE
>
> failIOE :: String -> IOErr a
> failIOE msg = IOErr (return (Err msg))
>
> instance ErrorMonad IOErr where
> failEM = failIOE
>
> {-
> liftIOtoIOErr :: IO a -> IOErr a
> liftIOtoIOErr = IOErr . fMap Done
>
> dropIOErrtoIO :: IOErr a -> IO a
> dropIOErrtoIO (IOErr m)
> = m >>= \x ->
> case x of
> Done a -> return a
> Err msg -> putErrStrLn msg >>
> error "drop!" -- return undefined
>
> dropError :: IOErr a -> IO b -> (a -> IO b) -> IO b
> dropError (IOErr m) failure success
> = m >>= \x ->
> case x of
> Done a -> success a
> Err msg -> putErrStrLn msg >> failure
> -}
\end{verbatim}
\section{STErr monad}
\begin{verbatim}
> newtype STErr s a = STErr (ST s (Error a))
> {- in mapSTE,returnSTE,bindSTE,failSTE,liftSTtoSTErr,
> dropSTErrtoST,dropErrorST,convertSTErr -}
>
> mapSTE :: (a -> b) -> (STErr s a) -> (STErr s b)
> mapSTE f (STErr xs) = STErr (xs <@ fMap f)
>
> instance Functor (STErr s) where
> fmap = mapSTE
>
> returnSTE :: a -> STErr s a
> returnSTE x = STErr (return (Done x))
>
> bindSTE :: STErr s a -> (a -> STErr s b) -> STErr s b
> (STErr xs) `bindSTE` f
> = STErr (xs >>= \x ->
> case x of
> Done a -> convertSTErr (f a)
> Err msg -> return (Err msg)
> )
>
> instance Monad (STErr s) where
> return = returnSTE
> (>>=) = bindSTE
>
> failSTE :: String -> STErr s a
> failSTE msg = STErr (return (Err msg))
>
> instance ErrorMonad (STErr s) where
> failEM = failSTE
>
> changeError :: (String -> String) -> STErr s a -> STErr s a
> changeError f (STErr m) = STErr $ m >>= \e-> case e of
> Done x -> return (Done x)
> Err msg-> return (Err (f msg))
>
> liftSTtoSTErr :: ST s a -> STErr s a
> liftSTtoSTErr = STErr . fMap Done
>
> mzeroSTErr = STErr (return (Err "mzero:"))
>
> instance MonadPlus (STErr s) where
> mzero = mzeroSTErr
> a `mplus` b = STErr $
> convertSTErr a >>= \x -> case x of
> Done y -> return (Done y)
> Err _ -> convertSTErr b
> {-
> dropSTErrtoST :: STErr s a -> ST s a
> dropSTErrtoST (STErr m)
> = m >>= \x ->
> case x of
> Done a -> return a
> Err msg -> error ("dropSTErrtoST: "++msg)
>
>
> dropErrorST :: STErr s a -> (String -> ST s b) -> (a -> ST s b) -> ST s b
> dropErrorST (STErr m) failure success
> = m >>= \x ->
> case x of
> Done a -> success a
> Err msg -> failure msg
> -}
>
> convertSTErr :: STErr s a -> ST s (Error a)
> convertSTErr (STErr x) = x
\end{verbatim}
\section{State monad}
\begin{verbatim}
> data State s a = ST (s -> (a,s))
>
> instance Functor (State s) where
> fmap f (ST st) =
> ST (\s -> let {(x,s') = st s} in (f x, s'))
>
> instance Monad (State s) where
> return x = ST (\s -> (x,s))
> ST m >>= f = ST (\s -> let (x,s') = m s
> ST f' = f x
> in f' s')
>
> updateST :: (s->s) -> State s s
> updateST f = ST (\s -> (s, f s))
> fetchST :: State s s
> fetchST = updateST id
>
> executeST :: s -> State s a -> a
> executeST s (ST m) = a where (a,_) = m s
\end{verbatim}
\section{STM monad}
\begin{verbatim}
> data StateM m s a = STM (s -> m (a,s))
>
> instance Functor m => Functor (StateM m s) where
> fmap f (STM xs) =
> STM (\s -> fMap (\(x,s') -> (f x, s'))
> (xs s)
> )
> instance Monad m => Monad (StateM m s) where
> return x = STM (\s -> return (x,s))
> STM xs >>= f = STM (\s -> xs s >>= \(x, s') ->
> let STM f' = f x
> in f' s'
> )
>
> mZeroSTM :: MonadPlus m => StateM m s a
> mZeroSTM = STM (\_ -> mZero)
>
> instance MonadPlus m => MonadPlus (StateM m s) where
> mzero = mZeroSTM
> mplus (STM stm) (STM stm') = STM (\s -> stm s +++ stm' s)
>
> instance ErrorMonad m => ErrorMonad (StateM m s) where
> failEM msg = STM (\_ -> failEM msg)
>
> updateSTM :: Monad m => (s->s) -> StateM m s s
> updateSTM f = STM (\s -> return (s, f s))
>
> fetchSTM :: Monad m => StateM m a a
> fetchSTM = updateSTM id
>
> executeSTM :: Monad m => s -> StateM m s a -> m a
> executeSTM s (STM m) = m s >>= \ ~(x,_) -> return x
\end{verbatim}
\section{Conversions between monads}
\begin{verbatim}
> mliftErr :: ST s a -> STErr s a
> mliftErr = liftSTtoSTErr
>
> mliftSTM :: Functor f => f a -> StateM f s a
> mliftSTM m = STM (\s -> fMap (`pair` s) m)
> mliftOut :: Functor m => m a -> OutputT b m a
> mliftOut ma = OT (fMap return ma)
\end{verbatim}
\section{Operations on all monads}
\begin{verbatim}
> foreach :: Monad m => [a] -> (a -> m b) -> m [b]
> foreach = flip mapl
>
> loop :: Monad m => [a -> m a] -> a -> m a
> loop [] x = return x
> loop (f:fs) x = f x >>= \y ->
> loop fs y
> (<*>) :: Monad m => m a -> m b -> m (a,b)
> (<*>) = liftop pair
> (<:*>) :: Monad m => m a -> m [a] -> m [a]
> (<:*>) = liftop (:)
> (<<) :: Monad m => m a -> m b -> m a
> (<<) = liftop const
\end{verbatim}
\subsection{More monad utilities}
Some other functions used in the following. \verb|liftop| does for an
operator what \verb|map| (on a monad) does for a function.
\begin{verbatim}
> liftop :: Monad m => (a -> b -> c) -> m a -> m b -> m c
> map2 :: Monad m => (a -> b -> c) -> m a -> m b -> m c
> map1 :: Functor m => (a -> b) -> m a -> m b
> map0 :: Monad m => a -> m a
\end{verbatim}
The order of the \verb|bind|s is important. (Swap them and the parser
will be a nice left recursive black hole;-)
\begin{verbatim}
> liftop f mp mq=mp >>= \p-> mq >>= \q-> return (f p q)
> map2 = liftop
> map1 = fMap
> map0 = return
\end{verbatim}
\section{Writer and output monads}
\begin{verbatim}
> data Writer a b = Writer ([a]->[a]) b
> instance Functor (Writer a) where
> fmap f (Writer s x) = Writer s (f x)
> instance Monad (Writer a) where
> return = Writer id
> (Writer s a) >>= f = Writer (s.t) b
> where Writer t b = f a
> write :: a -> Writer a ()
> write x = Writer (x:) ()
> data OutputT a m b = OT (m (Writer a b))
> unOT :: (OutputT a m b) -> m (Writer a b)
> unOT (OT m) = m
> instance Functor m => Functor (OutputT a m) where
> fmap f (OT mx) = OT (fMap (fMap f) mx)
> instance (Functor m ,Monad m) => Monad (OutputT a m) where
> return x = OT (return (return x))
> (OT m) >>= f = OT ((fMap join . join . fMap f') m)
> where f' = swap . fMap (unOT . f)
> swap (Writer s ma) = fMap (Writer s) ma
> output :: Monad m => a -> OutputT a m ()
> output x = OT (return (write x))
> runOutput' :: Functor m => OutputT a m b -> m ([a] -> [a],b)
> runOutput' (OT m) = fMap (\(Writer s a) -> (s,a)) m
> runOutput :: Functor m => [a] -> OutputT a m b -> m ([a],b)
> runOutput l o = fMap (\(s,x)->(s l,x)) (runOutput' o)
\end{verbatim}
\section{Mutable variables}
This module serves as a glue between the rest of the PolyP
implementation and the varying implementations of the ST-monad. As
the ST-monad is a Haskell extension, the interface has not yet
settled.
The differences are of two kinds:
\begin{itemize}
\item Different names of the new functions (easy to fix):\\
The names used in the rest of PolyP are those that were earlier used
in hugs and still are used in hbc [980428].
\item Different ways of extending the type system to deal with
\texttt{runST} (harder to fix):\\
In hugs, \texttt{runST} is a keyword and not a function, which means
that it can not be renamed and it can not even be mentioned in the
import or export lists. In hbc, a special constructor \texttt{RunST}
is used in concert with (the normal function) \texttt{runST}. And in
ghc \texttt{runST} is a normal function. (Provided the flag
\texttt{-fglasgow-exts} is used when compiling.)
\end{itemize}
\begin{verbatim}
> module StateFix(module ST,MutVar,newVar,readVar,writeVar,(===),
> MutArr,newArr,readArr,writeArr) where
> import ST -- (ST,STRef,runST,newSTRef,readSTRef,writeSTRef)
In Haskell 98 the class Ix is in a separate module instead of in the
prelude. (The change was discovered when moving from ghc-4.02 to
ghc-4.03 thus the prelude in ghc-4.02 is wrong.)
> import Ix(Ix)
> type MutArr s a b = STArray s a b
> type MutVar s a = STRef s a
> newVar :: a -> ST s (MutVar s a)
> readVar :: MutVar a b -> ST a b
> writeVar :: MutVar a b -> b -> ST a ()
> newVar = newSTRef
> readVar = readSTRef
> writeVar= writeSTRef
\end{verbatim}
Due to problems with combining overloading with the \verb|ST s|-monad
(in particular the construct \verb|runST|) we will use a special
symbol (the triple equality sign symbol, \verb|===|) for pointer
equality.
\begin{verbatim}
> (===) :: MutVar s a -> MutVar s a -> Bool
> (===) = (==) -- Pointer equality
\end{verbatim}
\section{Mutable arrays}
\begin{verbatim}
> newArr :: Ix a => (a,a) -> b -> ST s (MutArr s a b)
> readArr :: Ix a => MutArr s a b -> a -> ST s b
> writeArr :: Ix a => MutArr s a b -> a -> b -> ST s ()
> newArr = newSTArray
> readArr = readSTArray
> writeArr = writeSTArray
\end{verbatim}
\chapter{Prelude-like functions}
\begin{verbatim}
> module MyPrelude(module MyPrelude,trace) where
> import NonStdTrace(trace)
> import qualified IO(hFlush,hPutStr,stdout,stderr)
> import Flags(Flags(..),flags)
> import System(exitWith,ExitCode(..))
\end{verbatim}
\section{Error messages}
\begin{verbatim}
> stopNow :: IO a
> stopNow = exitWith ExitSuccess
> fatalError :: String -> IO a
> fatalError s = IO.hPutStr IO.stderr ("PolyP ERROR: "++s) >> exitWith (ExitFailure 1)
> putErrStr :: String -> IO ()
> putErrStrLn :: String -> IO ()
> putErrStr = if verbose flags
> then IO.hPutStr IO.stderr
> else const (return ())
> putErrStrLn s = putErrStr (s++"\n")
> putStrNow :: String -> IO ()
> putStrNow s = putStr s >> IO.hFlush IO.stdout
\end{verbatim}
\section{Compatibility issues}
In Haskell 98 what was earlier \texttt{map} has been split into two
values: one class member \texttt{fmap} and one list map \texttt{map}.
To achieve backward compatibility we define \texttt{fMap} even for
earlier Haskell versions.
> fMap :: Functor f => (a->b) -> f a -> f b
> fMap = fmap
\section{Some list utilities}
\begin{verbatim}
> flatMap :: (a -> [b]) -> [a] -> [b]
> without :: Eq a => [a] -> [a] -> [a]
> withoutBy:: (a -> a -> Bool) -> [a] -> [a] -> [a]
> splitUp :: [a -> Bool] -> [a] -> [[a]]
> unique :: Eq a => [a] -> [a]
> combineUniqueBy :: (a -> a -> Bool) -> [a] -> [a] -> [a]
\end{verbatim}
Given an equality function and two lists qs and xs where the first
list contains no duplicates, {\tt combineUniqueBy} gives a sublist ys
of xs such that qs++ys contains no duplicates.
The function {\tt flatMap} maps a function (returning a list
instead of just one element) over a list and concatenates the
resulting lists afterwards.
The function {\tt without} removes all occurrences of elements in the
second list from the first list;
e.g. {\tt [1,2,3,3,4] `without` [1,3] = [2,4]}
The function {\tt splitUp} splits up a list according to a list of
predicates. The resulting list of lists has a length that is one
more than the list of predicates. The last list is used to store
all elements that don't satisfy any of the predicates;
e.g. {\tt splitUp [(>3), (<2)] [1..5] = [[4,5], [1], [2,3]]}.
\subsection{Maybe}
The {\tt Maybe} data type is used whenever a function is not certain
to return a value (for example in environment lookups). \verb|Maybe|
is a functor and a monad with zero and plus. In Haskell 1.3 this type
and most operations are already in the prelude.
\begin{verbatim}
data Maybe a = Nothing | Just a deriving Show
maybe :: b -> (a -> b) -> Maybe a -> b
> unJust :: Maybe a -> a
\end{verbatim}
\subsection{Debugging}
For debugging \verb|trace| can be very useful - it prints its first
string argument as a side effect when it is reduced. It is the identity
function on its second argument. \verb|debug| shows it's argument and
returns it.
In H1.3 (hbc) we include the trace function from the module NonStdTrace.
\begin{verbatim}
> debug :: Show a => a -> a
> maytrace :: String -> a -> a
> maytrace _ = id -- debug info off
\end{verbatim}
\subsection{Pairs}
\begin{verbatim}
> mapFst :: (a -> b) -> (a, c) -> (b, c)
> mapSnd :: (a -> b) -> (c, a) -> (c, b)
> pair :: a -> b -> (a,b)
> swap :: (a, b) -> (b, a)
\end{verbatim}
\subsection{Misc.}
\begin{verbatim}
> variablename :: Int -> String
\end{verbatim}
\section{Implementation}
\begin{verbatim}
> flatMap f = concat . map f
> xs `without` ys = filter (\x -> not (elem x ys)) xs
> withoutBy eq xs ys = filter (\x -> not (myelem x ys)) xs
> where myelem = any . eq
> splitUp preds [] = replicate (length preds + 1) []
> splitUp preds (x:xs) = let lists = splitUp preds xs
> in try x preds lists
> where try y [] [lastList] = [(y:lastList)]
> try y (pr:prs) (list:lists)
> | pr y = (y:list) : lists
> | otherwise = list:(try y prs lists)
> try _ _ [] = error "MyPrelude.lhs: splitUp: impossible: too few lists"
> try _ [] (_:_:_) = error "MyPrelude.lhs: splitUp: impossible: too many
>lists"
> debug x = trace (show x) x
> maydebug :: Show a => a -> a
> maydebug x = maytrace (show x) x
> mapFst f (a,b) = (f a,b)
> mapSnd f (a,b) = (a,f b)
> pair x y = (x,y)
> swap (x,y) = (y,x)
> variablename n | n<26 = [num2chr n]
> where num2chr m = toEnum (fromEnum 'a' + m)
> variablename n = variablename (n `div` 26 - 1) ++
> variablename (n `mod` 26)
> unJust (Just x) = x
> unJust Nothing = error "unJust!"
> unique xs = unique' xs []
> unique' :: Eq a => [a] -> [a] -> [a]
> unique' [] = id
> unique' (x:xs) = (x:).(unique' [y|y<-xs,y/=x])
> combineUniqueBy eq = cu
> where cu _ [] = []
> cu qs (x:xs) | x `elemByeq` qs = cu qs xs
> | otherwise = x:cu (x:qs) xs
> elemByeq = any . eq
\end{verbatim}
> module Flags(Flags(..),flags) where
> import CommandLine(unsafeGetArgs,unsafeGetEnvDef)
> data Flags = Flags {verbose :: Bool,
> version :: Bool,
> help :: Bool,
> requests :: [String],
> preludeFileNames :: [String],
> fileargs :: [String]}
> deriving Show
> defaultPreludeFileName :: String
> defaultPreludeFileName = "/users/cs/patrikj/poly/polyp/PolyP/lib/PolyPrel.hs"
> preludeFileName :: String
> preludeFileName = unsafeGetEnvDef "POLYPPRELUDE" defaultPreludeFileName
> defaultflags :: Flags
> defaultflags = Flags {verbose = False,
> version = False,
> help = False,
> requests = [],
> preludeFileNames = [preludeFileName],
> fileargs = []}
> flags :: Flags
> flags = analyseFlags unsafeGetArgs
> analyseFlags :: [String] -> Flags
> analyseFlags [] = defaultflags
> analyseFlags (fl:rest)
> | isVersionFlag fl = (analyseFlags rest) {version = True}
> | isVerboseFlag fl = (analyseFlags rest) {verbose = True}
> | isHelpFlag fl = (analyseFlags rest) {help = True}
> analyseFlags (fl:name:rest)
> | isIncludeFlag fl = mapPrFileName (name:) (analyseFlags rest)
> | isRequestFlag fl = mapRequests (name:) (analyseFlags rest)
> analyseFlags (file:rest) = mapFileArgs (file:) (analyseFlags rest)
> mapPrFileName :: ([String] -> [String]) -> Flags -> Flags
> mapPrFileName f x = x {preludeFileNames = f (preludeFileNames x)}
> mapRequests :: ([String] -> [String]) -> Flags -> Flags
> mapRequests f x = x {requests = f (requests x)}
> mapFileArgs :: ([String] -> [String]) -> Flags -> Flags
> mapFileArgs f x = x {fileargs = f (fileargs x)}
> isIncludeFlag :: String -> Bool
> isIncludeFlag = ("-p"==)
> isVerboseFlag :: String -> Bool
> isVerboseFlag = ("-v"==)
> isVersionFlag :: String -> Bool
> isVersionFlag = ("--version"==)
> isRequestFlag :: String -> Bool
> isRequestFlag = ("-r"==)
> isHelpFlag :: String -> Bool
> isHelpFlag ('-':c:_) = c `elem` "h?"
> isHelpFlag _ = False
Command Line arguments transformed to global variables.
> module CommandLine where
> import NonStdTrace(unsafePerformIO)
> import System(getEnv,getArgs)
> unsafeGetArgs :: [String]
> unsafeGetArgs = unsafePerformIO getArgs
> unsafeGetEnvDef :: String -> String -> String
> unsafeGetEnvDef e def = unsafePerformIO (getEnvDef e def)
> getEnvDef :: String -> String -> IO String
> getEnvDef e def = getEnv e `catch` \ _ -> return def
maybeGetEnv :: String -> IO (Maybe String)
maybeGetEnv e = (getEnv e <@ Just) `catch` \ _ -> return Nothing
