packages feed

curry-frontend 0.1 → 0.2

raw patch · 33 files changed

+504/−867 lines, 33 filesdep +containers

Dependencies added: containers

Files

+ LIESMICH view
@@ -0,0 +1,172 @@+===============================================================================+==+==  Münster-Curry-Compiler+==  Distribution zur Anwendung als Frontend in PAKCS+==+==  Letztes Update: 27.10.05++Diese Distribution enthält die modifizierte Version des +Münster-Curry-Compilers (MCC) für die Verwendung als Frontend in PAKCS. Dieses +System ist u.a. in der Lage aus Curry-Programmen (entwickelt nach +PAKCS-Standard) Flat-Darstellungen (FlatCurry ".fcy", FlatInterface ".fint" +und FlatXML "_flat.xml"), sowie Abstract-Darstellungen (AbstractCurry ".acy" +und untyped AbstractCurry ".uacy") zu generieren.++++1. Installation+---------------++1.1 Installation der Binary-Distribution++Die Binary-Distribution befindet sich in einem tar-Archiv und wird+durch folgendes Kommando entpackt:++	tar zxvf <Distribution>.tar.gz++Danach steht der Compiler im Verzeichnis 'mcc' zur Verfügung.+++1.2 Installation der Source-Distribution++Nach dem Entpacken des tar-Archivs mittels++	tar zxvf <Distribution>.tar.gz++kann der Compiler durch Aufruf von 'make' im Verzeichnis 'mcc' installiert+werden. Bei Recompilierung (z.B. nach Änderungen in der Quelldateien)+wird empfohlen vor einer erneuten Installation 'make clean' auszuführen.++++Nach erfolgreicher Installation befindet sich in beiden Fällen im Verzeichnis +'mcc/bin/' folgende ausführbare Datei:++	cymake		- der Curry-Programm-Builder++Dieses Tool übersetzt Curry-Programme unter Berücksichtigung der Import-+abhängigkeiten.++++2. Kommandoübersicht+--------------------++In der folgenden Tabelle sind die Optionen zur Generierung der jeweiligen+Darstellungen für das Kommando 'cymake' aufgelistet:++	--flat		: Erzeugt FlatCurry- und FlatInterface-Datei+	--xml		: Erzeugt FlatXML-Datei+	--acy		: Erzeugt (typinferierte) AbstractCurry-Datei+	--uacy		: Erzeugt ungetypte AbstractCurry-Datei++++3. Erzeugung von FlatCurry- und FlatXML-Programmen+--------------------------------------------------++Die Übersetzung eines Curry-Programms 'file.curry', sowie sämtlicher+importierter Module nach FlatCurry bzw. FlatInterface, bewirkt folgendes+Kommando:++	cymake --flat <filename>++Hierdurch werden die Dateien mit den entsprechenden Endungen ".fcy" und+".fint" generiert. Der Dateiname <filename> kann hierbei mit oder ohne +Endung ".curry" bzw. ".lcurry" angegeben werden.++Die analogen Übersetzungen in die FlatXML-Darstellung bewirkt folgendes+Kommando:++	cymake --xml <file name>++Die hierdurch generierte Flat-XML-Datei hat die Endung '_flat.xml'.++++4. Erzeugung von AbstractCurry-Programmen+-----------------------------------------++Die Übersetzung eines Curry-Programms 'file.curry' nach (typgeprüftem)+AbstractCurry bewirkt folgendes Kommando:++	cymake --acy <filename>++Hierdurch wird die entsprechende Datei (mit der Endung ".acy") generiert.+Der Dateiname <filename> kann hierbei mit oder ohne Endung ".curry" bzw.+".lcurry" angegeben werden.++Ungetypte, bzw. typsignierte AbstractCurry-Programme werden mit folgendem+Kommando generiert:++	cymake --uacy <filename>++Die hierdurch generierte Datei besitzt die Endung ".uacy".++Die Generierung des ungetypten AbstractCurry-Programms findet ohne+Typüberprüfung statt (d.h. auch Programme mit Typfehlern werden übersetzt).+Alle Funktionen besitzen entweder die im Quellprogramm angegebenen Typsignatur,+oder, sofern diese nicht vorhanden ist, den Dummy-Typ "prelude.untyped".++In beiden Fällen werden für die Übersetzung FlatCurry-Dateien +für alle importierten Module erzeugt. Dies ist notwendig, da die +entsprechenden Interfaces für die Typinferenz (nur im Fall der getypten +AbstractCurry-Generierung) und die statisch-semantische Analyse benötigt +werden.++++5. Anmerkungen+--------------++- Um die PAKCS-Bibliotheken (insbesondere die Prelude) für Übersetzungen +  nutzen zu können muß die Umgebungsvariable 'PAKCS_LIB' auf die+  entsprechenden Pfade verweisen, z.B. mittels++	export PAKCS_LIB=<pakcs path>/pacs/lib:<pakcs path>/pacs/lib/meta:...++  wobei <pakcs path> das Verzeichnis ist, das die PAKCS-Distribution+  enthält.++- Im Gegensatz zu PAKCS erlaubt das Frontend die Verwendung anonymer+  Variablen (dargestellt durch dem Unterstrich '_') in Typdeklarationen,+  z.B.++	data T _ = C++++Bekannte Probleme+------------------++- Lambda-, do-, if-, case-, oder let-Ausdrücke, die in Argumenten von+  Funktionsaufrufen verwendet werden, müssen immer geklammert werden.++- 'let'-Anweisungen dürfen nicht folgendes Layout besitzen:++           let x = <expr>+               in ...++- Die Regeln einer Funktionsdeklaration müssen immer zusammenstehen, d.h.+  nicht durch andere Deklarationen unterbrochen werden.++- Es ist bislang nicht möglich, den Konstruktor für leere Listen [], sowie +  den Unit-Konstruktor () zu qualifizieren (z.B. führt 'prelude.[]' zu +  einem Fehler). Der Listenkonstruktor (:), sowie Tupel-Konstruktoren+  dagegen sind qualifizierbar.++- FlatXML-Übersetzungen können derzeit mittels der Funktionen aus dem+  PAKCS-Modul "FlatXML" noch nicht eingelesen werden, da es Unstimmigkeiten+  zwischen dem generierten und den erforderlichen Formaten gibt.++- Bei der Erzeugung von typgeprüftem AbstractCurry können die im Quelltext+  verwendeten Bezeichner für Typvariablen nicht ins AbstractCurry-Programm+  übernommen werden. Stattdessen generiert der Übersetzer neue+  Bezeichner.++- Bei der Erzeugung von ungetyptem AbstractCurry werden Typsynonyme in+  Typsignaturen von Funktionen nicht dereferenziert.++- Das Frontend gibt derzeit noch keinerlei Warnungen aus.++
curry-frontend.cabal view
@@ -1,7 +1,7 @@ Name:          curry-frontend-Version:       0.1+Version:       0.2 Cabal-Version: >= 1.6-Synopsis:      A compiler for the functional logic language Curry to several intermediate language formats.+Synopsis:      Compile the functional logic language Curry to several intermediate formats Description:   The Curry Frontend consists of the executable program "cymake".                It is used by various backends to compile Curry programs to                 an internal representation. @@ -12,19 +12,20 @@ License:       OtherLicense License-File:  LICENSE Author:        Wolfgang Lux, Martin Engelke, Bernd Brassel, Holger Siegel-Maintainer:    Michael Hanus-Bug-Reports:   mailto:mh@informatik.uni-kiel.de+Maintainer:    Holger Siegel+Bug-Reports:   mailto:hsi@informatik.uni-kiel.de Homepage:      http://curry-language.org Build-Type:    Simple Stability:     experimental -Extra-Source-Files: src/currydoc.css+Extra-Source-Files: LIESMICH+Data-Files:    src/currydoc.css 		      Executable cymake   hs-source-dirs:   src   Main-is:          cymake.hs-  Build-Depends:    base >= 3 && < 4, mtl, old-time, directory, filepath+  Build-Depends:    base >= 3 && < 4, mtl, old-time, directory, filepath, containers   Other-Modules:    AbstractCurry, CurryBuilder, Env, IL, Message                     CurryCompilerOpts, Error, Modules, Subst, Arity                     CurryDeps, Eval, ILPP, NestEnv, SyntaxCheck, Base@@ -34,11 +35,11 @@                     CurryLexer, Imports, PathUtils, TypeCheck                     CurryParser, InterfaceCheck, Position                     Types, CurryPP, Frontend, PrecCheck-                    TypeSubst, CurrySubdir, GenAbstractCurry+                    TypeSubst, GenAbstractCurry                     Pretty, Typing, Combined, CurrySyntax                     GenFlatCurry, KindCheck, Qual, Unlit, CompilerResults                     LexComb, SCC, Utils, GetOpt                     Lift, ScopeEnv, WarnCheck-                    LLParseComb, Set, Desugar, Ident, ShowCurrySyntax-                    Map, Simplify+                    LLParseComb, Desugar, Ident, ShowCurrySyntax+                    Simplify
src/Base.lhs view
@@ -17,6 +17,8 @@ > import Data.List > import Control.Monad > import Data.Maybe+> import qualified Data.Set as Set+> import qualified Data.Map as Map  > import Ident  > import Position@@ -27,8 +29,8 @@ > import ExtendedFlat hiding (SrcRef, Fixity(..), TypeExpr, Expr(..)) > import Env > import TopEnv-> import Map-> import Set++ > import Utils  @@ -56,18 +58,18 @@ > toQualTypes m tvs tys = map (qualifyType m) (toTypes tvs tys)  > toType :: [Ident] -> TypeExpr -> Type-> toType tvs ty = toType' (fromListFM (zip (tvs ++ tvs') [0..])) ty+> toType tvs ty = toType' (Map.fromList (zip (tvs ++ tvs') [0..])) ty >   where tvs' = [tv | tv <- nub (fv ty), tv `notElem` tvs]  > toTypes :: [Ident] -> [TypeExpr] -> [Type]-> toTypes tvs tys = map (toType' (fromListFM (zip (tvs ++ tvs') [0..]))) tys+> toTypes tvs tys = map (toType' (Map.fromList (zip (tvs ++ tvs') [0..]))) tys >   where tvs' = [tv | tv <- nub (concatMap fv tys), tv `notElem` tvs] -> toType' :: FM Ident Int -> TypeExpr -> Type+> toType' :: Map.Map Ident Int -> TypeExpr -> Type > toType' tvs (ConstructorType tc tys) = >   TypeConstructor tc (map (toType' tvs) tys) > toType' tvs (VariableType tv) =->   maybe (internalError ("toType " ++ show tv)) TypeVariable (lookupFM tv tvs)+>   maybe (internalError ("toType " ++ show tv)) TypeVariable (Map.lookup tv tvs) > toType' tvs (TupleType tys) >   | null tys = TypeConstructor (qualify unitId) [] >   | otherwise = TypeConstructor (qualify (tupleId (length tys'))) tys'@@ -821,7 +823,7 @@ >   fv (RecordType fs rty) = (maybe [] fv rty) ++ fv (map snd fs)  > filterBv :: QuantExpr e => e -> [Ident] -> [Ident]-> filterBv e = filter (`notElemSet` fromListSet (bv e))+> filterBv e = filter (`Set.notMember` Set.fromList (bv e))  \end{verbatim} Since multiple variable occurrences are allowed in function patterns,
src/Combined.lhs view
@@ -20,38 +20,10 @@ > module Combined where  > import Control.Monad-> import Data.IORef--> import Error+> import Control.Monad.Identity  \end{verbatim}-\subsection{Identity monad}-The identity monad only serves as a base monad if no other monad ---usually either \texttt{[]} or \texttt{IO} -- can be used. It allows to-derive the usual -- i.e. unparameterized -- state and environment-monads. -Unfortunately, we cannot define \texttt{Id} as a \texttt{newtype}-because of a bug in the nhc compiler.-\begin{verbatim}--> -- newtype Id a = Id a-> data Id a = Id a--> unId :: Id a -> a-> unId (Id x) = x--> instance Functor Id where->   fmap f (Id x) = Id (f x)--> instance Monad Id where->   return x = Id x->   Id x >>= k = k x--> callId :: Id a -> a-> callId = unId--\end{verbatim} \subsection{State transformers} The state transformer monad is defined as usual, except that the result of the state transformer function is itself a monad. The@@ -60,7 +32,7 @@ \begin{verbatim}  > newtype StateT s m a = StateT (s -> m (a,s))-> type St s a = StateT s Id a+> type St s = StateT s Identity  > unStateT :: StateT s m a -> (s -> m (a,s)) > unStateT (StateT st) = st@@ -84,7 +56,7 @@ > callSt (StateT st) s = st s >>= return . fst  > runSt :: St s a -> s -> a-> runSt st = callId . callSt st+> runSt st = runIdentity . callSt st  \end{verbatim} In addition to the standard monad functions, state monads should@@ -144,7 +116,7 @@ \begin{verbatim}  > data ReaderT r m a = ReaderT (r -> m a)-> type Rt r a = ReaderT r Id a+> type Rt r a = ReaderT r Identity a  > unReaderT :: ReaderT r m a -> (r -> m a) > unReaderT (ReaderT rt) = rt@@ -168,33 +140,11 @@ > callRt (ReaderT rt) r = rt r  > runRt :: Rt r a -> r -> a-> runRt rt = callId . callRt rt--\end{verbatim}-Similar to the state monad class, an environment monad class which-provides functions to access the current state and to run an-environment monad in a given state could be defined as follows:-\begin{verbatim}--class Monad m => EnvMonad r m where-  env :: m r-  putEnv :: r -> m a -> m a--instance Monad m => EnvMonad r (ReaderT r m) where-  env = ReaderT return-  putEnv r (ReaderT rt) = ReaderT (\_ -> rt r)--\end{verbatim}-Again, this requires multi-parameter type classes; thus we define the-appropriate instance functions for the type \texttt{ReaderT} instead.-\begin{verbatim}+> runRt rt = runIdentity . callRt rt  > envRt :: Monad m => ReaderT r m r > envRt = ReaderT return  -> putEnvRt :: Monad m => r -> ReaderT r m a -> ReaderT r m a-> putEnvRt r (ReaderT rt) = ReaderT (\_ -> rt r)- \end{verbatim} Currying can also be applied to state reader monads. \begin{verbatim}@@ -210,90 +160,7 @@ transformer monad. This is handled by the combinator \texttt{ro}. \begin{verbatim} -> ro :: Monad m => ReaderT r m a -> StateT r m a-> ro (ReaderT rt) = StateT (\s -> rt s >>= \x -> return (x,s))--\end{verbatim}-\subsection{Error monad}-Another useful monad defined in~\cite{LiangHudakJones95:ModInterp} is-the error monad.-\begin{verbatim}--> data ErrorT m a = ErrorT (m (Error a))--> unErrorT :: ErrorT m a -> m (Error a)-> unErrorT (ErrorT m) = m--> instance Functor f => Functor (ErrorT f) where->   fmap f (ErrorT m) = ErrorT (fmap (fmap f) m)--> instance Monad m => Monad (ErrorT m) where->   return = ErrorT . return . Ok->   fail = ErrorT . return . Error->   ErrorT m >>= f = ErrorT (m >>= k)->     where k (Ok x) = unErrorT (f x)->           k (Error msg) = return (Error msg)--> instance MonadPlus m => MonadPlus (ErrorT m) where->   mzero = ErrorT mzero->   ErrorT m `mplus` ErrorT m' = ErrorT (m `mplus` m')--> liftErr :: Monad m => m a -> ErrorT m a-> liftErr = ErrorT . liftM Ok--> callErr :: ErrorT m a -> m (Error a)-> callErr = unErrorT--\end{verbatim}-\subsection{Mutable variables}-All major Haskell implementations provide some kind of mutable state-variables. In order to be able to lift these operations to the-combined monads approach, we define a class for handling these-references. Currently this is restricted to the use of mutable-variables in the \texttt{IO} monad.\footnote{We use the interface-provided by Hugs and ghc and provide compatibility implementations for-hbc and nhc that adapt the respective implementations to the one used-here. See appendix~\ref{sec:hbc-ioexts} and~\ref{sec:nhc-ioexts} for-details.}-\begin{verbatim}--> type Ref a = IORef a--> class Monad m => RefMonad m where->   newRef :: a -> m (Ref a)->   readRef :: Ref a -> m a->   writeRef :: Ref a -> a -> m ()--> instance RefMonad IO where->   newRef = newIORef->   readRef = readIORef->   writeRef = writeIORef--\end{verbatim}-\subsection{Lifting operations}-In order to use the operations of one the classes defined above in-another monad, the appropriate \texttt{lift}\dots{} combinators have-to be applied. The following instance declarations automatically-provide these lifting operations. Unfortunately we cannot define such-implicit lifting operations for neither the state monad functions nor-the environment monad functions as we were unable to define those-classes.-\begin{verbatim}--> -- Reference monad-> instance RefMonad m => RefMonad (ErrorT m) where->   newRef = liftErr . newRef->   readRef = liftErr . readRef->   writeRef ref = liftErr . writeRef ref--> instance RefMonad m => RefMonad (ReaderT s m) where->   newRef = liftRt . newRef->   readRef = liftRt . readRef->   writeRef ref = liftRt . writeRef ref--> instance RefMonad m => RefMonad (StateT s m) where->   newRef = liftSt . newRef->   readRef = liftSt . readRef->   writeRef ref = liftSt . writeRef ref+ro :: Monad m => ReaderT r m a -> StateT r m a+ro (ReaderT rt) = StateT (\s -> rt s >>= \x -> return (x,s))  \end{verbatim}
src/CurryBuilder.hs view
@@ -32,7 +32,7 @@ buildCurry :: Options -> FilePath -> IO () buildCurry options file    = do let paths = importPaths options-	file'          <- getSourcePath paths file+	file'          <- getCurryPath paths file 	(cfile, errs1) <- return (maybe ("", [missingModule file]) 			                (\f -> (f,[])) 				        file')@@ -49,7 +49,7 @@    = mapM compile (map snd deps) >> return ()  where  compile (Source file' mods)-    | rootname file == rootname file'+    | dropExtension file == dropExtension file'       = do             flatIntfExists <- doesModuleExist (flatIntName file') 	   if flatIntfExists && not (force options) && null (dump options)@@ -96,8 +96,8 @@   flatInterface mod      = case (lookup mod deps) of-        Just (Source file _)  -> Just (flatIntName (rootname file))-	Just (Interface file) -> Just (flatIntName (rootname file))+        Just (Source file _)  -> Just (flatIntName (dropExtension file))+	Just (Interface file) -> Just (flatIntName (dropExtension file)) 	_                     -> Nothing   compOpts isImport@@ -113,13 +113,6 @@     | otherwise = options  ----------------------------------------------------------------------------------- Searches in 'paths' for the corresponding Curry file of 'fn' and returns--- the complete path if it exist. The filename 'fn' doesn't need one of the --- Curry file extensions ".curry" or ".lcurry"-getSourcePath :: [FilePath] -> FilePath -> IO (Maybe FilePath)-getSourcePath paths file = getCurryPath paths [] file-  -- Computes a dependency list for the Curry file 'file' (such a list -- usualy starts with the prelude and ends with 'file'). The result
src/CurryDeps.lhs view
@@ -48,7 +48,7 @@ > buildScript clean debug linkAlways flat xml acy uacy >             paths libraryPaths ofn fn = >   do->     mfn'      <- getCurryPath paths libraryPaths fn+>     mfn'      <- getCurryPath (paths ++ libraryPaths) fn >     (fn',es1) <- return (maybe ("",["Error: missing module \"" ++ fn ++ "\""]) >                                (\x -> (x,[])) >                                mfn')@@ -62,7 +62,7 @@ >                        (outputFile fn') fn ms)) >     return es >   where outputFile fn->           | extension fn `elem` moduleExts ++ objectExts = Nothing+>           | takeExtension fn `elem` moduleExts ++ objectExts = Nothing >           | otherwise = ofn `mplus` Just fn >         makeScript clean = if clean then makeCleanScript else makeBuildScript @@ -83,13 +83,13 @@ >   | e == icurryExt = return emptyEnv >   | e `elem` objectExts = targetDeps paths libraryPaths mEnv r >   | otherwise = targetDeps paths libraryPaths mEnv fn->   where r = rootname fn->         e = extension fn+>   where r = dropExtension fn+>         e = takeExtension fn  > targetDeps :: [FilePath] -> [FilePath] -> SourceEnv -> FilePath >            -> IO SourceEnv > targetDeps paths libraryPaths mEnv fn =->   lookupFile [fn ++ e | e <- sourceExts] >>=+>   lookupFile [""] sourceExts fn >>= >   maybe (return (bindEnv m Unknown mEnv)) (sourceDeps paths libraryPaths m mEnv) >   where m = mkMIdent [fn] @@ -108,24 +108,11 @@ directories more than twice. \begin{verbatim} - > lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent >              -> IO (Maybe FilePath)-> lookupModule paths libraryPaths m =->   lookupFile [p `catPath` fn ++ e | p <- "" : paths, e <- moduleExts] >>=->   maybe (lookupFile [p `catPath` fn ++ e ->                      | p <- libraryPaths, e <- moduleExts])->         (return . Just)->   where fn = foldr1 catPath (moduleQualifiers m)->                      -- | p <- libraryPaths, e <- [icurryExt, curryExt, lcurryExt]])--> --lookupModule :: [FilePath] -> [FilePath] -> ModuleIdent-> --             -> IO (Maybe FilePath)-> --lookupModule paths libraryPaths m =-> --  lookupFile [p `catPath` fn ++ e | p <- "" : paths, e <- moduleExts] >>=-> --  maybe (lookupFile [p `catPath` fn ++ icurryExt | p <- libraryPaths])-> --        (return . Just)-> --  where fn = foldr1 catPath (moduleQualifiers m)+> lookupModule paths libraryPaths m+>     = lookupFile ("" : paths ++ libraryPaths) moduleExts fn+>     where fn = foldr1 catPath (moduleQualifiers m)  \end{verbatim} In order to compute the dependency graph, source files for each module@@ -252,7 +239,7 @@ >                       ++ (maybe [] linkCommands ofn)) >   where  >         compCommands (Source fn' ms)->            | (acy || uacy) && rootname fn /= rootname fn'+>            | (acy || uacy) && dropExtension fn /= dropExtension fn' >              = (smake ([flatName fn', flatIntName fn']) >                       (fn' : catMaybes (map flatInt ms)) >                       "")@@ -299,7 +286,7 @@ >             Just (Source fn' _)  >	        -> Just (flatIntName fn') >             Just (Interface fn') ->	        -> Just (flatIntName (basename (rootname fn')))+>	        -> Just (flatIntName (takeBaseName fn')) >             Just Unknown  >	        -> Nothing >             _ -> Nothing@@ -345,22 +332,16 @@ if the given file name has no extension. \begin{verbatim} -> getCurryPath :: [FilePath] -> [FilePath] -> FilePath -> IO (Maybe FilePath)-> getCurryPath paths libraryPaths fn->   = lookupFile filepaths+> getCurryPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)+> getCurryPath paths fn+>   = lookupFile filepaths exts fn >  where->  filepaths = [p `catPath` fn' | p   <- "":(paths ++ libraryPaths),->                                 fn' <- fns']->  fns' | null (extension fn) = [fn ++ ext' | ext' <- sourceExts]->       | otherwise           = [fn]--> --getSourceName :: FilePath -> IO FilePath-> --getSourceName fn-> --   | null (extension fn)-> --      = do mfn <- lookupFile [fn ++ ext' | ext' <- sourceExts]-> --           return (fromMaybe fn mfn)-> --   | otherwise -> --     = return fn+>  filepaths = "":paths'+>  fnext = takeExtension fn+>  exts | null fnext = sourceExts+>       | otherwise  = [fnext]+>  paths' | pathSeparator `elem` fn = []+>         | otherwise               = paths   \end{verbatim}@@ -372,29 +353,29 @@ \begin{verbatim}  > interfName :: FilePath -> FilePath-> interfName sfn = rootname sfn ++ icurryExt+> interfName sfn = replaceExtension sfn icurryExt  > flatName :: FilePath -> FilePath-> flatName fn = rootname fn ++ flatExt+> flatName fn = replaceExtension fn flatExt  > flatIntName :: FilePath -> FilePath-> flatIntName fn = rootname fn ++ flatIntExt+> flatIntName fn = replaceExtension fn flatIntExt  > xmlName :: FilePath -> FilePath-> xmlName fn = rootname fn ++ xmlExt+> xmlName fn = replaceExtension fn xmlExt  > acyName :: FilePath -> FilePath-> acyName fn = rootname fn ++ acyExt+> acyName fn = replaceExtension fn acyExt  > uacyName :: FilePath -> FilePath-> uacyName fn = rootname fn ++ uacyExt+> uacyName fn = replaceExtension fn uacyExt  > sourceRepName :: FilePath -> FilePath-> sourceRepName fn = rootname fn ++ sourceRepExt+> sourceRepName fn = replaceExtension fn sourceRepExt  > objectName :: Bool -> FilePath -> FilePath > objectName debug = name (if debug then debugExt else oExt)->   where name ext fn = rootname fn ++ ext+>   where name ext fn = replaceExtension fn ext  > curryExt, lcurryExt, icurryExt, oExt :: String > curryExt = ".curry"
src/CurryHtml.hs view
@@ -16,7 +16,7 @@                      then sourceprogname ++ "_curry.html"                      else outputfilename              modulname = fileName sourceprogname-        fullfname <- getCurryPath imports [] sourcefilename+        fullfname <- getCurryPath imports sourcefilename         program <- filename2program imports (maybe sourcefilename id fullfname)         (if null outputfilename then writeModule output                                  else writeFile   output)
src/CurryLexer.lhs view
@@ -15,12 +15,13 @@  > import Data.Char  > import Data.List+> import qualified Data.Map as Map  > import LexComb > import Position-> import Map  + \end{verbatim} \paragraph{Tokens} Note that the equality and ordering instances of \texttt{Token} disregard the attributes.@@ -211,8 +212,8 @@ Tables for reserved operators and identifiers \begin{verbatim} -> reserved_ops, reserved_and_special_ops :: FM String Category-> reserved_ops = fromListFM [+> reserved_ops, reserved_and_special_ops :: Map.Map String Category+> reserved_ops = Map.fromList [ >     ("@",  At), >     ("::", DoubleColon), >     ("..", DotDot),@@ -224,15 +225,15 @@ >     ("~",  Tilde), >     (":=", Binds) >   ]-> reserved_and_special_ops = foldr (uncurry addToFM) reserved_ops [+> reserved_and_special_ops = foldr (uncurry Map.insert) reserved_ops [ >     (":",  Colon), >     (".",  Sym_Dot), >     ("-",  Sym_Minus), >     ("-.", Sym_MinusDot) >   ] -> reserved_ids, reserved_and_special_ids :: FM String Category-> reserved_ids = fromListFM [+> reserved_ids, reserved_and_special_ids :: Map.Map String Category+> reserved_ids = Map.fromList [ >     ("case",     KW_case), >     ("choice",   KW_choice), >     ("data",     KW_data),@@ -256,7 +257,7 @@ >     ("type",     KW_type), >     ("where",    KW_where) >   ]-> reserved_and_special_ids = foldr (uncurry addToFM) reserved_ids [+> reserved_and_special_ids = foldr (uncurry Map.insert) reserved_ids [ >     ("as",        Id_as), >     ("ccall",     Id_ccall), >     ("forall",    Id_forall),@@ -398,14 +399,14 @@ > lexIdent :: (Token -> P a) -> P a > lexIdent cont p s = >   maybe (lexOptQual cont (token Id) [ident]) (cont . token)->         (lookupFM ident reserved_and_special_ids)+>         (Map.lookup ident reserved_and_special_ids) >         (incr p (length ident)) rest >   where (ident,rest) = span isIdent s >         token t = idTok t [] ident  > lexSym :: (Token -> P a) -> P a > lexSym cont p s =->   cont (idTok (maybe Sym id (lookupFM sym reserved_and_special_ops)) [] sym)+>   cont (idTok (maybe Sym id (Map.lookup sym reserved_and_special_ops)) [] sym) >        (incr p (length sym)) rest >   where (sym,rest) = span isSym s @@ -432,14 +433,14 @@ > lexQualIdent cont identCont mIdent p s = >   maybe (lexOptQual cont (idTok QId mIdent ident) (mIdent ++ [ident])) >         (const identCont)->         (lookupFM ident reserved_ids)+>         (Map.lookup ident reserved_ids) >         (incr p (length ident)) rest >   where (ident,rest) = span isIdent s  > lexQualSym :: (Token -> P a) -> P a -> [String] -> P a > lexQualSym cont identCont mIdent p s = >   maybe (cont (idTok QSym mIdent sym)) (const identCont)->         (lookupFM sym reserved_ops)+>         (Map.lookup sym reserved_ops) >         (incr p (length sym)) rest >   where (sym,rest) = span isSym s
− src/CurrySubdir.hs 
@@ -1,90 +0,0 @@-module CurrySubdir where--import System.FilePath-import System.Directory-import System.Time (ClockTime)-import Control.Monad (when)-import Data.List(intersperse)---- some definitions from PathUtils--curDirPath :: FilePath-curDirPath = "."---- divide given puth names in directories--path :: String -> [String]-path = canonPath . separateBy (==pathSeparator) -  where-    canonPath (c:cs) = c:filter (not . null) cs---- separate a list by separator predicate--separateBy :: (a -> Bool) -> [a] -> [[a]]-separateBy p = sep id -  where-    sep xs [] = [xs []]-    sep xs (c:cs) = if p c then xs [] : sep id cs-                           else sep (xs . (c:)) cs---- make canonical path from list of directories--unpath :: [String] -> String-unpath = concat . intersperse [pathSeparator]----When we split a path into its basename and directory we will make---sure that the basename does not contain any path separators.- -dirname, basename :: FilePath -> FilePath-dirname  = unpath . init . path-basename = last . path---- add a subdirectory to a given filename --- if it is not already present--inSubdir :: String -> String -> String-inSubdir sub fn = unpath $ add (path fn) -  where-    add ps@[n] = sub:ps-    add ps@[p,n] | p==sub = ps-    add (p:ps) = p:add ps----The sub directory to hide files in:--currySubdir :: String -currySubdir = ".curry"--inCurrySubdir :: String -> String-inCurrySubdir = inSubdir currySubdir----write a file to curry subdirectory--writeModule :: String -> String -> IO ()-writeModule filename contents = do-  --writeFile filename contents-  let filename' = inCurrySubdir filename-      subdir = dirname filename'-  ex <- doesDirectoryExist subdir-  when (not ex) (createDirectory subdir)-  writeFile filename' contents---- do things with file in subdir--onExistingFileDo :: (String -> IO a) -> String -> IO a-onExistingFileDo act filename = do-  ex <- doesFileExist filename-  if ex then act filename -        else act $ inCurrySubdir filename--readModule :: String -> IO String-readModule = onExistingFileDo readFile--maybeReadModule :: String -> IO (Maybe String)-maybeReadModule filename = -  catch (readModule filename >>= return . Just) (\_ -> return Nothing)--doesModuleExist :: String -> IO Bool-doesModuleExist = onExistingFileDo doesFileExist--getModuleModTime :: String -> IO ClockTime-getModuleModTime = onExistingFileDo getModificationTime
src/Desugar.lhs view
@@ -84,7 +84,7 @@ variables. \begin{verbatim} -> type DesugarState a = StateT ValueEnv (StateT Int Id) a+> type DesugarState a = StateT ValueEnv (St Int) a  > run :: DesugarState a -> ValueEnv -> a > run m tyEnv = runSt (callSt m tyEnv) 1
src/Env.lhs view
@@ -26,30 +26,28 @@ \begin{verbatim}  > module Env where-> import Map -> newtype Env a b = Env (FM a b) deriving Show+> import qualified Data.Map as Map -> emptyEnv :: Ord a => Env a b-> emptyEnv = Env zeroFM+> newtype Env a b = Env (Map.Map a b) deriving Show -> environment :: Ord a => [(a,b)] -> Env a b-> environment = foldr (uncurry bindEnv) emptyEnv+> emptyEnv :: Ord a => Env a b+> emptyEnv = Env Map.empty  > envToList :: Ord v => Env v e -> [(v,e)]-> envToList (Env rho) = toListFM rho+> envToList (Env rho) = Map.toList rho  > bindEnv :: Ord v => v -> e -> Env v e -> Env v e-> bindEnv v e (Env rho) = Env (addToFM v e rho)+> bindEnv v e (Env rho) = Env (Map.insert v e rho)  > unbindEnv :: Ord v => v -> Env v e -> Env v e-> unbindEnv v (Env rho) = Env (deleteFromFM v rho)+> unbindEnv v (Env rho) = Env (Map.delete v rho)  > lookupEnv :: Ord v => v -> Env v e -> Maybe e-> lookupEnv v (Env rho) = lookupFM v rho+> lookupEnv v (Env rho) = Map.lookup v rho  > envSize :: Ord v => Env v e -> Int-> envSize (Env rho) = length (toListFM rho)+> envSize (Env rho) = Map.size rho  > instance Ord a => Functor (Env a) where >   fmap f (Env rho) = Env (fmap f rho)
src/Error.lhs view
@@ -31,12 +31,5 @@ > ok (Ok x) = x > ok (Error e) = error e -> okM :: Monad m => Error a -> m a-> okM (Ok x) = return x-> okM (Error e) = fail e--> emap :: (String -> String) -> Error a -> Error a-> emap _ (Ok x) = Ok x-> emap f (Error e) = Error (f e)  \end{verbatim}
src/Exports.lhs view
@@ -16,10 +16,10 @@  > import Data.List > import Data.Maybe+> import qualified Data.Set as Set+> import qualified Data.Map as Map  > import Base-> import Map-> import Set > import TopEnv  \end{verbatim}@@ -43,7 +43,7 @@ >         Linear -> Module m (Just (Exporting noPos es')) ds >         NonLinear v -> errorAt' (ambiguousExportValue v) >     NonLinear tc -> errorAt' (ambiguousExportType tc) ->   where ms = fromListSet [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds]+>   where ms = Set.fromList [fromMaybe m asM | ImportDecl _ m _ asM _ <- ds] >         es' = joinExports $                                              -- $ >               maybe (expandLocalModule tcEnv tyEnv) >                     (expandSpecs ms m tcEnv tyEnv)@@ -67,12 +67,12 @@ identifiers. \begin{verbatim} -> expandSpecs :: Set ModuleIdent -> ModuleIdent -> TCEnv -> ValueEnv+> expandSpecs :: Set.Set ModuleIdent -> ModuleIdent -> TCEnv -> ValueEnv >             -> ExportSpec -> [Export] > expandSpecs ms m tcEnv tyEnv (Exporting _ es) = >   concat (map (expandExport ms m tcEnv tyEnv) es) -> expandExport :: Set ModuleIdent -> ModuleIdent -> TCEnv+> expandExport :: Set.Set ModuleIdent -> ModuleIdent -> TCEnv >              -> ValueEnv -> Export -> [Export] > expandExport _ m tcEnv tyEnv (Export x) = expandThing m tcEnv tyEnv x > expandExport _ m tcEnv _ (ExportTypeWith tc cs) =@@ -80,9 +80,9 @@ > expandExport _ m tcEnv tyEnv (ExportTypeAll tc) =  >   expandTypeAll m tyEnv tcEnv tc > expandExport ms m tcEnv tyEnv (ExportModule m')->   | m == m' = (if m `elemSet` ms then expandModule tcEnv tyEnv m else [])+>   | m == m' = (if m `Set.member` ms then expandModule tcEnv tyEnv m else []) >               ++ expandLocalModule tcEnv tyEnv->   | m' `elemSet` ms = expandModule tcEnv tyEnv m'+>   | m' `Set.member` ms = expandModule tcEnv tyEnv m' >   | otherwise = errorAt' (moduleNotImported m')  > expandThing :: ModuleIdent -> TCEnv -> ValueEnv -> QualIdent@@ -168,16 +168,16 @@  > joinExports :: [Export] -> [Export] > joinExports es =->   [ExportTypeWith tc cs | (tc,cs) <- toListFM (foldr joinType zeroFM es)] ++->   [Export f | f <- toListSet (foldr joinFun zeroSet es)]+>   [ExportTypeWith tc cs | (tc,cs) <- Map.toList (foldr joinType Map.empty es)] +++>   [Export f | f <- Set.toList (foldr joinFun Set.empty es)] -> joinType :: Export -> FM QualIdent [Ident] -> FM QualIdent [Ident]+> joinType :: Export -> Map.Map QualIdent [Ident] -> Map.Map QualIdent [Ident] > joinType (Export _) tcs = tcs > joinType (ExportTypeWith tc cs) tcs =->   addToFM tc (cs `union` fromMaybe [] (lookupFM tc tcs)) tcs+>   Map.insertWith union tc cs tcs -> joinFun :: Export -> Set QualIdent -> Set QualIdent-> joinFun (Export f) fs = f `addToSet` fs+> joinFun :: Export -> Set.Set QualIdent -> Set.Set QualIdent+> joinFun (Export f) fs = f `Set.insert` fs > joinFun (ExportTypeWith _ _) fs = fs  \end{verbatim}@@ -287,7 +287,7 @@  > usedModules :: [IDecl] -> [ModuleIdent] > usedModules ds = nub (catMaybes (map modul (foldr identsDecl [] ds)))->   where nub = toListSet . fromListSet+>   where nub = Set.toList . Set.fromList >         modul = fst . splitQualIdent  > identsDecl :: IDecl -> [QualIdent] -> [QualIdent]@@ -332,8 +332,8 @@ >           HidingDataDecl noPos (unqualify tc) (take n nameSupply)  > hiddenTypes :: [IDecl] -> [QualIdent]-> hiddenTypes ds = [tc | tc <- toListSet tcs, not (isQualified tc)]->   where tcs = foldr deleteFromSet (fromListSet (usedTypes ds))+> hiddenTypes ds = [tc | tc <- Set.toList tcs, not (isQualified tc)]+>   where tcs = foldr Set.delete (Set.fromList (usedTypes ds)) >                     (definedTypes ds)  > usedTypes :: [IDecl] -> [QualIdent]
src/ExtendedFlat.hs view
@@ -24,7 +24,7 @@                   CaseType(..), CombType(..), Expr(..), BranchExpr(..),                   Pattern(..), Literal(..),  		  readFlatCurry, readFlatInterface, readFlat, -		  writeFlatCurry,gshowsPrec,+		  writeFlatCurry,writeExtendedFlat,gshowsPrec,                   qnOf,mkQName,                   mkIdx,idxOf) where @@ -33,6 +33,7 @@ import Control.Monad (liftM) import Data.Generics hiding (Fixity) import Position (SrcRef)+import System.FilePath   ------------------------------------------------------------------------------@@ -428,12 +429,12 @@ -- Writes a FlatCurry program term into a file. writeFlatCurry :: String -> Prog -> IO () writeFlatCurry filename prog-   = writeModule filename (showFlatCurry' prog)+   = writeModule filename (showFlatCurry' False prog)  -- Writes a FlatCurry program term with source references into a file.-writeFlatWithSrcRefs :: String -> Prog -> IO ()-writeFlatWithSrcRefs filename prog-   = writeModule filename (showFlatCurry prog)+writeExtendedFlat :: String -> Prog -> IO ()+writeExtendedFlat filename prog =+  writeModule (replaceExtension filename ".efc") (showFlatCurry' True prog)  -- Shows FlatCurry program in a more nicely way. showFlatCurry :: Prog -> String@@ -454,31 +455,34 @@    | otherwise      = fn ++ ext -showFlatCurry' :: Prog -> String-showFlatCurry' x = gshowsPrec False x ""-+showFlatCurry' :: Bool -> Prog -> String+showFlatCurry' b x = gshowsPrec b False x "" -gshowsPrec :: Data a => Bool -> a -> ShowS-gshowsPrec d = +gshowsPrec :: Data a => Bool -> Bool -> a -> ShowS+gshowsPrec showType d =    genericShowsPrec d `ext1Q` showsList                      `ext2Q` showsTuple                      `extQ`  (const id :: SrcRef -> ShowS)                      `extQ`  (const id :: [SrcRef] -> ShowS)                      `extQ`  (shows :: String -> ShowS)                      `extQ`  (shows :: Char -> ShowS)-                     `extQ`  showsQName-                     `extQ`  showsVarIndex+                     `extQ`  showsQName d+                     `extQ`  showsVarIndex d                                              where-        showsQName :: QName -> ShowS-        showsQName QName{modName=m,localName=n} = shows (m,n)+        showsQName :: Bool -> QName -> ShowS+        showsQName d qn@QName{modName=m,localName=n,typeofQName=t} = +          if showType then showParen d (shows qn{srcRef=Nothing})+                      else shows (m,n) -        showsVarIndex :: VarIndex -> ShowS-        showsVarIndex VarIndex{index=i} = shows i+        showsVarIndex :: Bool -> VarIndex -> ShowS+        showsVarIndex d v@VarIndex{index=i} = +          if showType then showParen d (shows v)+                      else shows i          genericShowsPrec :: Data a => Bool -> a -> ShowS         genericShowsPrec d t = let args = intersperse (showChar ' ') $-                                          gmapQ (gshowsPrec True) t in+                                          gmapQ (gshowsPrec showType True) t in                                showParen (d && not (null args)) $                                showString (showConstr (toConstr t)) .                                (if null args then id else showChar ' ') .@@ -488,14 +492,14 @@         showsList xs = showChar '[' .                         foldr (.) (showChar ']')                               (intersperse (showChar ',') $ -                              map (gshowsPrec False) xs)+                              map (gshowsPrec showType False) xs)                                  showsTuple :: (Data a,Data b) => (a,b) -> ShowS         showsTuple (x,y) = showChar '(' . -                           gshowsPrec False x . +                           gshowsPrec showType False x .                             showChar ',' .-                           gshowsPrec False y .+                           gshowsPrec showType False y .                            showChar ')'
src/Frontend.hs view
@@ -203,8 +203,8 @@   flatInterface deps mod      = case (lookup mod deps) of-        Just (Source file _)  -> Just (flatIntName (rootname file))-	Just (Interface file) -> Just (flatIntName (rootname file))+        Just (Source file _)  -> Just (flatIntName (dropExtension file))+	Just (Interface file) -> Just (flatIntName (dropExtension file)) 	_                     -> Nothing  -- Declares the filename as module name, if the module name is not@@ -212,7 +212,7 @@ patchModuleId :: FilePath -> CS.Module -> CS.Module patchModuleId fn (CS.Module mid mexports decls)    | (moduleName mid) == "main"-     = CS.Module (mkMIdent [basename (rootname fn)]) mexports decls+     = CS.Module (mkMIdent [takeBaseName fn]) mexports decls    | otherwise      = CS.Module mid mexports decls @@ -233,7 +233,7 @@ -- Returns 'True', if file name and module name are equal. isValidModuleId :: FilePath -> ModuleIdent -> Bool isValidModuleId fn mid-   = last (moduleQualifiers mid) == basename (rootname fn)+   = last (moduleQualifiers mid) == takeBaseName fn   -- Converts a literate source program to a non-literate source program
src/GenFlatCurry.hs view
@@ -10,13 +10,11 @@ module GenFlatCurry (genFlatCurry, 		     genFlatInterface) where -import Debug.Trace- import Control.Monad.State import Control.Monad import Data.Maybe import Data.List-+import qualified Data.Map as Map import Base (ArityEnv, ArityInfo(..), ModuleEnv, PEnv, PrecInfo(..),  	     OpPrec(..), TCEnv, TypeInfo(..), ValueEnv, ValueInfo(..), 	     lookupValue, qualLookupTC,@@ -41,9 +39,11 @@ import PatchPrelude import Ident as Id import Env-import Map +--import Debug.Trace +trace _ x = x+ -------------------------------------------------------------------------------  -- transforms intermediate language code (IL) to FlatCurry code@@ -649,12 +649,12 @@   	   [Label _ record _] -> 	     case (qualLookupTC record tcEnv) of 	       [AliasType _ n (TypeRecord fs' _)] ->-	         let ms = foldl (matchTypeVars fs) zeroFM fs'+	         let ms = foldl (matchTypeVars fs) Map.empty fs' 		     types = map (\i -> maybe  			 	          (CS.VariableType  					     (mkIdent ("#tvar" ++ show i))) 				          (elimRecordTypes tyEnv tcEnv)-				          (lookupFM i ms))+				          (Map.lookup i ms)) 			         [0 .. n-1] 	         in  CS.ConstructorType record types 	       _ -> internalError ("GenFlatCurry.elimRecordTypes: "@@ -662,12 +662,12 @@ 	   _ -> internalError ("GenFlatCurry.elimRecordTypes: " 			       ++ "no label") -matchTypeVars :: [(Ident,CS.TypeExpr)] -> FM Int CS.TypeExpr-	      -> (Ident, Type) -> FM Int CS.TypeExpr+matchTypeVars :: [(Ident,CS.TypeExpr)] -> Map.Map Int CS.TypeExpr+	      -> (Ident, Type) -> Map.Map Int CS.TypeExpr matchTypeVars fs ms (l,ty)    = maybe ms (match ms ty) (lookup l fs)   where-  match ms (TypeVariable i) typeexpr = addToFM i typeexpr ms+  match ms (TypeVariable i) typeexpr = Map.insert i typeexpr ms   match ms (TypeConstructor _ tys) (CS.ConstructorType _ typeexprs)      = matchList ms tys typeexprs   match ms (TypeConstructor _ tys) (CS.ListType typeexpr)
src/ILTrans.lhs view
@@ -23,16 +23,17 @@  > import Data.Maybe > import Data.List+> import qualified Data.Set as Set+> import qualified Data.Map as Map  > import Base > import qualified IL > import Utils > import Env-> import Set-> import Map   + \end{verbatim} \paragraph{Modules} At the top-level, the compiler has to translate data type, newtype,@@ -185,22 +186,22 @@ >           [AliasType _ n' (TypeRecord fs' _)] -> >	      let is = [0 .. n'-1] >                 vs = foldl (matchTypeVars fs)->			     zeroFM+>			     Map.empty >			     fs' >		  tys = map (\i -> maybe (TypeVariable (i+n)) >			                 (elimRecordTypes m tyEnv tcEnv n)->		                         (lookupFM i vs))+>		                         (Map.lookup i vs)) >		            is  >	      in  TypeConstructor r tys >	    _ -> internalError "elimRecordTypes: no record type" >       _ -> internalError "elimRecordTypes: no label" -> matchTypeVars :: [(Ident,Type)] -> FM Int Type -> (Ident,Type) ->	           -> FM Int Type+> matchTypeVars :: [(Ident,Type)] -> Map.Map Int Type -> (Ident,Type) +>	           -> Map.Map Int Type > matchTypeVars fs vs (l,ty) = >   maybe vs (match vs ty) (lookup l fs) >   where->   match vs (TypeVariable i) ty' = addToFM i ty' vs+>   match vs (TypeVariable i) ty' = Map.insert i ty' vs >   match vs (TypeConstructor _ tys) (TypeConstructor _ tys') = >     matchList vs tys tys' >   match vs (TypeConstrained tys _) (TypeConstrained tys' _) =@@ -555,7 +556,7 @@ \begin{verbatim}  > imports :: ModuleIdent -> [IL.Decl] -> [ModuleIdent]-> imports m = toListSet . deleteFromSet m . fromListSet . foldr modulesDecl []+> imports m = Set.toList . Set.delete m . Set.fromList . foldr modulesDecl []  > modulesDecl :: IL.Decl -> [ModuleIdent] -> [ModuleIdent] > modulesDecl (IL.DataDecl _ _ cs) ms = foldr modulesConstrDecl ms cs
src/Imports.lhs view
@@ -13,13 +13,14 @@ > module Imports(importInterface,importInterfaceIntf,importUnifyData) where  > import Data.Maybe+> import qualified Data.Set as Set+> import qualified Data.Map as Map  > import Base > import Env > import TopEnv-> import Map-> import Set + \end{verbatim} Four kinds of environments are computed from the interface, one containing the operator precedences, another for the type@@ -58,13 +59,13 @@ >         mTyEnv = intfEnv bindTy i >         mAEnv  = intfEnv bindA i >         is' = maybe [] (expandSpecs m mTCEnv mTyEnv) is->         ts  = isVisible is (fromListSet (foldr addType [] is'))->         vs  = isVisible is (fromListSet (foldr addValue [] is'))->         as  = isVisible is (fromListSet (foldr addArity [] is'))+>         ts  = isVisible is (Set.fromList (foldr addType [] is'))+>         vs  = isVisible is (Set.fromList (foldr addValue [] is'))+>         as  = isVisible is (Set.fromList (foldr addArity [] is')) -> isVisible :: Maybe ImportSpec -> Set Ident -> Ident -> Bool-> isVisible (Just (Importing _ _)) xs = (`elemSet` xs)-> isVisible (Just (Hiding _ _)) xs = (`notElemSet` xs)+> isVisible :: Maybe ImportSpec -> Set.Set Ident -> Ident -> Bool+> isVisible (Just (Importing _ _)) xs = (`Set.member` xs)+> isVisible (Just (Hiding _ _)) xs = (`Set.notMember` xs) > isVisible _ _ = const True  > importEntities :: Entity a => ModuleIdent -> Bool -> (Ident -> Bool)@@ -320,10 +321,10 @@  > importUnifyData :: TCEnv -> TCEnv > importUnifyData tcEnv =->   fmap (setInfo (foldr (mergeData . snd) zeroFM (allImports tcEnv))) tcEnv->   where setInfo tcs t = fromJust (lookupFM (origName t) tcs)+>   fmap (setInfo (foldr (mergeData . snd) Map.empty (allImports tcEnv))) tcEnv+>   where setInfo tcs t = fromJust (Map.lookup (origName t) tcs) >         mergeData t tcs =->           addToFM tc (maybe t (fromJust . merge t) (lookupFM tc tcs)) tcs+>           Map.insert tc (maybe t (fromJust . merge t) (Map.lookup tc tcs)) tcs >           where tc = origName t  \end{verbatim}
src/LLParseComb.lhs view
@@ -27,12 +27,15 @@ >                    many,many1, sepBy,sepBy1, chainr,chainr1,chainl,chainl1, >                    bracket,ops, layoutOn,layoutOff,layoutEnd) where -> import Data.Maybe > import Control.Monad+> import Data.Maybe+> import qualified Data.Set as Set+> import qualified Data.Map as Map + > import Position-> import Set-> import Map++ > import Error > import LexComb @@ -56,12 +59,12 @@ >                     -> SuccessCont s b  > data Parser s a b = Parser (Maybe (ParseFun s a b))->                            (FM s (Lexer s b -> ParseFun s a b))+>                            (Map.Map s (Lexer s b -> ParseFun s a b))  > instance Symbol s => Show (Parser s a b) where >   showsPrec p (Parser e ps) = showParen (p >= 10) $                      -- $ >     showString "Parser " . shows (isJust e) .->     showChar ' ' . shows (domainFM ps)+>     showChar ' ' . shows (Map.keysSet ps)  > applyParser :: Symbol s => Parser s a a -> Lexer s a -> FilePath -> String >             -> Error a@@ -77,7 +80,7 @@  > choose :: Symbol s => Parser s a b -> Lexer s b -> ParseFun s a b > choose (Parser e ps) lexer success fail pos s =->   case lookupFM s ps of+>   case Map.lookup s ps of >     Just p -> p lexer success fail pos s >     Nothing -> >       case e of@@ -94,27 +97,27 @@ \begin{verbatim}  > position :: Symbol s => Parser s Position b-> position = Parser (Just p) zeroFM+> position = Parser (Just p) Map.empty >   where p success _ pos = success pos pos  > succeed :: Symbol s => a -> Parser s a b-> succeed x = Parser (Just p) zeroFM+> succeed x = Parser (Just p) Map.empty >   where p success _ = success x  > symbol :: Symbol s => s -> Parser s s a-> symbol s = Parser Nothing (addToFM s p zeroFM)+> symbol s = Parser Nothing (Map.singleton s p) >   where p lexer success fail pos s = lexer (success s) fail  > (<?>) :: Symbol s => Parser s a b -> String -> Parser s a b-> p <?> msg = p <|> Parser (Just pfail) zeroFM+> p <?> msg = p <|> Parser (Just pfail) Map.empty >   where pfail _ fail pos _ = fail pos msg  > (<|>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b > Parser e1 ps1 <|> Parser e2 ps2 >   | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"->   | not (nullSet common) = error ("Ambiguous parser for " ++ show common)->   | otherwise = Parser (e1 `mplus` e2) (insertIntoFM ps1 ps2)->   where common = domainFM ps1 `intersectionSet` domainFM ps2+>   | not (Set.null common) = error ("Ambiguous parser for " ++ show common)+>   | otherwise = Parser (e1 `mplus` e2) (Map.union ps1 ps2)+>   where common = Map.keysSet ps1 `Set.intersection` Map.keysSet ps2  \end{verbatim} The parsing combinators presented so far require that the grammar@@ -133,9 +136,9 @@ > (<|?>) :: Symbol s => Parser s a b -> Parser s a b -> Parser s a b > Parser e1 ps1 <|?> Parser e2 ps2 >   | isJust e1 && isJust e2 = error "Ambiguous parser for empty word"->   | otherwise = Parser (e1 `mplus` e2) (insertIntoFM ps1' ps2)->   where ps1' = fromListFM [(s,maybe p (try p) (lookupFM s ps2))->                           | (s,p) <- toListFM ps1]+>   | otherwise = Parser (e1 `mplus` e2) (Map.union ps1' ps2)+>   where ps1' = Map.fromList [(s,maybe p (try p) (Map.lookup s ps2))+>                           | (s,p) <- Map.toList ps1] >         try p1 p2 lexer success fail pos s = >           closeP1 p2s `thenP` \p2s' -> >           closeP1 p2f `thenP` \p2f' ->@@ -158,7 +161,7 @@ > (<*>) :: Symbol s => Parser s (a -> b) c -> Parser s a c -> Parser s b c > Parser (Just p1) ps1 <*> ~p2@(Parser e2 ps2) = >   Parser (fmap (seqEE p1) e2)->          (insertIntoFM (fmap (flip seqPP p2) ps1) (fmap (seqEP p1) ps2))+>          (Map.union (fmap (flip seqPP p2) ps1) (fmap (seqEP p1) ps2)) > Parser Nothing ps1 <*> p2 = Parser Nothing (fmap (flip seqPP p2) ps1)  > seqEE :: Symbol s => ParseFun s (a -> b) c -> ParseFun s a c@@ -174,9 +177,6 @@ > seqPP p1 p2 lexer success fail = >   p1 lexer (\f -> choose p2 lexer (success . f) fail) fail -> insertIntoFM :: Ord a => FM a b -> FM a b -> FM a b-> insertIntoFM map1 map2 = foldr (uncurry addToFM) map2 (toListFM map1)- \end{verbatim} The combinators \verb|<\\>| and \verb|<\>| can be used to restrict the first set of a parser. This is useful for combining two parsers@@ -184,10 +184,10 @@ \begin{verbatim}  > (<\>) :: Symbol s => Parser s a c -> Parser s b c -> Parser s a c-> p <\> Parser _ ps = p <\\> map fst (toListFM ps)+> p <\> Parser _ ps = p <\\> Map.keys ps  > (<\\>) :: Symbol s => Parser s a b -> [s] -> Parser s a b-> Parser e ps <\\> xs = Parser e (foldr deleteFromFM ps xs)+> Parser e ps <\\> xs = Parser e (foldr Map.delete ps xs)  \end{verbatim} \paragraph{Other combinators.}@@ -278,15 +278,15 @@ \begin{verbatim}  > layoutOn :: Symbol s => Parser s a b-> layoutOn = Parser (Just on) zeroFM+> layoutOn = Parser (Just on) Map.empty >   where on success _ pos = pushContext (column pos) . success undefined pos  > layoutOff :: Symbol s => Parser s a b-> layoutOff = Parser (Just off) zeroFM+> layoutOff = Parser (Just off) Map.empty >   where off success _ pos = pushContext (-1) . success undefined pos  > layoutEnd :: Symbol s => Parser s a b-> layoutEnd = Parser (Just end) zeroFM+> layoutEnd = Parser (Just end) Map.empty >   where end success _ pos = popContext . success undefined pos  \end{verbatim}
src/Lift.lhs view
@@ -21,13 +21,14 @@  > import Control.Monad > import Data.List+> import qualified Data.Set as Set  > import Base > import Env > import TopEnv-> import Set  + > import Combined > import SCC @@ -48,7 +49,7 @@ i.e. the function applied to its free variables. \begin{verbatim} -> type AbstractState a = StateT ValueEnv (StateT EvalEnv Id) a+> type AbstractState a = StateT ValueEnv (St EvalEnv) a > type AbstractEnv = Env Ident Expression  > abstractModule :: ModuleIdent -> [Decl]@@ -156,10 +157,10 @@ >     e' <- abstractFunDecls m pre lvs env' fdss vds e >     return (Let fds' e') >   where fs = bv fds->         fvs = filter (`elem` lvs) (toListSet fvsRhs)+>         fvs = filter (`elem` lvs) (Set.toList fvsRhs) >         env' = foldr (bindF (map mkVar fvs)) env fs->         fvsRhs = unionSets->           [fromListSet (maybe [v] (qfv m) (lookupEnv v env)) | v <- qfv m fds]+>         fvsRhs = Set.unions+>           [Set.fromList (maybe [v] (qfv m) (lookupEnv v env)) | v <- qfv m fds] >         bindF fvs f = bindEnv f (apply (mkFun m pre f) fvs) >         isLifted tyEnv f = null (lookupValue f tyEnv)
− src/Map.lhs 
@@ -1,225 +0,0 @@-% -*- LaTeX -*--% $Id: Map.lhs,v 1.6 2003/04/24 08:02:39 wlux Exp $-%-% Copyright (c) 1999-2002, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Map.lhs}-\section{Maps}-The module \texttt{Map} implements finite maps using 2-3 trees.-\begin{verbatim}--> module Map(FM, nullFM, zeroFM, unitFM, addToFM, deleteFromFM,->            lookupFM, fromListFM, toListFM) where-> import Data.List--\end{verbatim}-A 2-3 tree is either empty or a node with either two or three children-that are themselves 2-3 trees of the same height. Thus, a 2-3 is-always balanced.-\begin{verbatim}--> data FM a b =->     Empty->   | Node2 (FM a b) (a,b) (FM a b)->   | Node3 (FM a b) (a,b) (FM a b) (a,b) (FM a b)--> nullFM :: Ord a => FM a b -> Bool-> nullFM Empty = True-> nullFM _ = False--> zeroFM :: Ord a => FM a b-> zeroFM = Empty--> unitFM :: Ord a => a -> b -> FM a b-> unitFM x y = Node2 Empty (x,y) Empty--\end{verbatim}-Insertion into the map is performed with the help of an auxiliary-function. This function returns either the updated node or a triple of-a left and right subtree together with the element between them-if the height of the tree must be changed.-\begin{verbatim}--> addToFM :: Ord a => a -> b -> FM a b -> FM a b-> addToFM x y xys =->   case insertNode x y xys of->     Left xys' -> xys'->     Right (l,x,r) -> Node2 l x r--> fromListFM :: Ord a => [(a,b)] -> FM a b-> fromListFM = foldr (uncurry addToFM) zeroFM--> insertNode :: Ord a => a -> b -> FM a b->            -> Either (FM a b) ((FM a b),(a,b),(FM a b))-> insertNode k x Empty = Right (Empty,(k,x),Empty)-> insertNode k x (Node2 a y b) =->   Left (case compareKey k y of->           LT -> balanceL (insertNode k x a) y b->           EQ -> Node2 a (k,x) b->           GT -> balanceR a y (insertNode k x b))->   where balanceL (Left a) x b = Node2 a x b->         balanceL (Right (a,x,b)) y c = Node3 a x b y c->         balanceR a x (Left b) = Node2 a x b->         balanceR a x (Right (b,y,c)) = Node3 a x b y c-> insertNode k x (Node3 a y b z c) =->   case compareKey k y of->     LT -> balanceL (insertNode k x a) y b z c->     EQ -> Left (Node3 a (k,x) b z c)->     GT ->->       case compareKey k z of->         LT -> balanceM a y (insertNode k x b) z c->         EQ -> Left (Node3 a y b (k,x) c)->         GT -> balanceR a y b z (insertNode k x c)->   where balanceL (Left a) x b y c = Left (Node3 a x b y c)->         balanceL (Right (a,x,b)) y c z d = Right (Node2 a x b,y,Node2 c z d)->         balanceM a x (Left b) y c = Left (Node3 a x b y c)->         balanceM a x (Right (b,y,c)) z d = Right (Node2 a x b,y,Node2 c z d)->         balanceR a x b y (Left c) = Left (Node3 a x b y c)->         balanceR a x b y (Right (c,z,d)) = Right (Node2 a x b,y,Node2 c z d)--> compareKey :: Ord a => a -> (a,b) -> Ordering-> compareKey k1 (k2,_) = compare k1 k2--\end{verbatim}-Deletion also uses an auxiliary function. This function returns the-new node after the element has been deleted together with a boolean-flag that indicates whether the height was decremented.-\begin{verbatim}--> deleteFromFM :: Ord a => a -> FM a b -> FM a b-> deleteFromFM x xys = snd (deleteNode x xys)--> deleteNode :: Ord a => a -> FM a b -> (Bool,FM a b)-> deleteNode _ Empty = (False,Empty)-> deleteNode x (Node2 a y b) =->   case compareKey x y of->     LT -> balanceL (deleteNode x a) y b->     EQ->       | nullFM a -> (True,b)->       | otherwise -> balanceR a u (deleteNode (fst u) b)->       where u = findMin b->     GT -> balanceR a y (deleteNode x b)->   where balanceL (False,a) x b = (False,Node2 a x b)->         balanceL (True,a) x (Node2 b y c) = (True,Node3 a x b y c)->         balanceL (True,a) x (Node3 b y c z d) =->           (False,Node2 (Node2 a x b) y (Node2 c z d))->         balanceR a x (False,b) = (False,Node2 a x b)->         balanceR (Node2 a x b) y (True,c) = (True,Node3 a x b y c)->         balanceR (Node3 a x b y c) z (True,d) =->           (False,Node2 (Node2 a x b) y (Node2 c z d))-> deleteNode x (Node3 a y b z c) =->   (False,->    case compareKey x y of->      LT -> balanceL (deleteNode x a) y b z c->      EQ->        | nullFM a -> Node2 b z c->        | otherwise -> balanceM a u (deleteNode (fst u) b) z c->        where u = findMin b->      GT ->->        case compareKey x z of->          LT -> balanceM a y (deleteNode x b) z c->          EQ->            | nullFM c -> Node2 a y b->            | otherwise -> balanceR a y b u (deleteNode (fst u) c)->            where u = findMin c->          GT -> balanceR a y b z (deleteNode x c))->   where balanceL (False,a) x b y c = Node3 a x b y c->         balanceL (True,a) x (Node2 b y c) z d = Node2 (Node3 a x b y c) z d->         balanceL (True,a) w (Node3 b x c y d) z e =->           Node3 (Node2 a w b) x (Node2 c y d) z e->         balanceM a x (False,b) y c = Node3 a x b y c->         balanceM a x (True,b) y (Node2 c z d) = Node2 a x (Node3 b y c z d)->         balanceM a w (True,b) x (Node3 c y d z e) =->           Node3 a w (Node2 b x c) y (Node2 d z e)->         balanceR a x b y (False,c) = Node3 a x b y c->         balanceR a x (Node2 b y c) z (True,d) = Node2 a x (Node3 b y c z d)->         balanceR a w (Node3 b x c y d) z (True,e) =->           Node3 a w (Node2 b x c) y (Node2 d z e)--> findMin :: Ord a => FM a b -> (a,b)-> findMin (Node2 a x _)->   | nullFM a = x->   | otherwise = findMin a-> findMin (Node3 a x _ _ _)->   | nullFM a = x->   | otherwise = findMin a--\end{verbatim}-Looking up an element is trivial.-\begin{verbatim}--> lookupFM :: Ord a => a -> FM a b -> Maybe b-> lookupFM _ Empty = Nothing-> lookupFM x (Node2 a y b) =->   case compareKey x y of->     LT -> lookupFM x a->     EQ -> Just (snd y)->     GT -> lookupFM x b-> lookupFM x (Node3 a y b z c) =->   case compareKey x y of->     LT -> lookupFM x a->     EQ -> Just (snd y)->     GT -> lookupFM x (Node2 b z c)--\end{verbatim}-The function \texttt{toListFM} returns an association list of all-elements in the map. We use a functional difference list approach-similar to \texttt{show} in order to achieve an efficiency which is-linear in the number of elements in the finite map.-\begin{verbatim}--> toListFM :: Ord a => FM a b -> [(a,b)]-> toListFM = flip elems []->   where elems Empty xs = xs->         elems (Node2 a x b) xs = elems a (x : elems b xs)->         elems (Node3 a x b y c) xs = elems a (x : elems b (y : elems c xs))--\end{verbatim}-Two finite maps are considered equal if they contain the same-elements. Note that the representation trees of the two maps may be-different. Therefore we must use the list of elements in order to-compare the maps.-\begin{verbatim}--> instance (Ord a,Eq b) => Eq (FM a b) where->   xys1 == xys2 = toListFM xys1 == toListFM xys2--\end{verbatim}-When we display a finite map we will show only its semantic-information not the underlying tree representation.-\begin{verbatim}--> instance (Ord a,Show a,Show b) => Show (FM a b) where->   showsPrec p xys =->     showChar '{' . showList (map showAssoc (toListFM xys)) . showChar '}'->     where showList = flip (foldr ($)) . intersperse (showChar ',')       -- $->           showAssoc (x,y) = showsPrec 0 x . showString "|->" . showsPrec 0 y--\end{verbatim}-A finite map is a functor with respect to its data argument.-\begin{verbatim}--> instance Ord a => Functor (FM a) where->   fmap f Empty = Empty->   fmap f (Node2 a (k,x) b) = Node2 (fmap f a) (k,f x) (fmap f b)->   fmap f (Node3 a (k,x) b (l,y) c) =->     Node3 (fmap f a) (k,f x) (fmap f b) (l,f y) (fmap f c)--\end{verbatim}-The function \texttt{checkTree} verifies that a 2-3 tree is actually-balanced. The function returns the height of the tree.-\begin{verbatim}--> checkTree :: Ord a => FM a b -> Int-> checkTree Empty = 0-> checkTree (Node2 a _ b)->   | h == checkTree b = h + 1->   | otherwise = error "checkTree: unbalanced 2-3 tree"->   where h = checkTree a-> checkTree (Node3 a _ b _ c)->   | h == checkTree b && h == checkTree c = h + 1->   | otherwise = error "checkTree: unbalanced 2-3 tree"->   where h = checkTree a--\end{verbatim}
src/Modules.lhs view
@@ -103,7 +103,7 @@ >          do (tyEnv, tcEnv, aEnv, m', intf, _) <- simpleCheckModule opts mEnv m >             if uacy then genAbstract opts fn tyEnv tcEnv m' >                     else do->                       let outputFile = maybe (rootname fn ++ sourceRepExt) +>                       let outputFile = maybe (replaceExtension fn sourceRepExt)  >                                              id  >                                              (output opts) >                           outputMod = showModule m'@@ -138,7 +138,7 @@  > checkModuleId :: Monad m => FilePath -> Module -> m () > checkModuleId fn (Module mid _ _)->    | last (moduleQualifiers mid) == basename (rootname fn)+>    | last (moduleQualifiers mid) == takeBaseName fn >      = return () >    | otherwise >      = error ("module \"" ++ moduleName mid @@ -243,25 +243,27 @@  > writeXML :: Maybe FilePath -> FilePath -> CurryEnv -> IL.Module -> IO () > writeXML tfn sfn cEnv il = writeModule ofn (showln code)->   where ofn  = fromMaybe (rootname sfn ++ xmlExt) tfn+>   where ofn  = fromMaybe (replaceExtension sfn xmlExt) tfn >         code = (xmlModule cEnv il)  > writeFlat :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv  >              -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog > writeFlat opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il >   = writeFlatFile opts (genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv il)->                        (fromMaybe (rootname sfn ++ flatExt) tfn)+>                        (fromMaybe (replaceExtension sfn flatExt) tfn)  > writeFInt :: Options -> Maybe FilePath -> FilePath -> CurryEnv -> ModuleEnv >              -> ValueEnv -> TCEnv -> ArityEnv -> IL.Module -> IO Prog > writeFInt opts tfn sfn cEnv mEnv tyEnv tcEnv aEnv il ->   = writeFlatFile opts (genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il)->                        (fromMaybe (rootname sfn ++ fintExt) tfn)+>   = writeFlatFile opts{extendedFlat=False}+>                  (genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il)+>                  (fromMaybe (takeBaseName sfn ++ fintExt) tfn)  > writeFlatFile :: (Show a) => Options -> (Prog, [a]) -> String -> IO Prog-> writeFlatFile opts (res,msgs) fname = do+> writeFlatFile opts@Options{extendedFlat=ext} (res,msgs) fname = do >         unless (noWarn opts) (printMessages msgs)->	  writeFlatCurry fname res+>	  if ext then writeExtendedFlat fname res+>                else writeFlatCurry fname res >         return res  @@ -269,23 +271,13 @@ >	           -> IO () > writeTypedAbs tfn sfn tyEnv tcEnv mod >    = writeCurry fname (genTypedAbstract tyEnv tcEnv mod)->  where fname = fromMaybe (rootname sfn ++ acyExt) tfn+>  where fname = fromMaybe (replaceExtension sfn acyExt) tfn  > writeUntypedAbs :: Maybe FilePath -> FilePath -> ValueEnv -> TCEnv   >	             -> Module -> IO () > writeUntypedAbs tfn sfn tyEnv tcEnv mod >    = writeCurry fname (genUntypedAbstract tyEnv tcEnv mod)->  where fname = fromMaybe (rootname sfn ++ uacyExt) tfn--> --writeCode :: Maybe FilePath -> FilePath -> Either CFile [CFile] -> IO ()-> --writeCode tfn sfn (Left cfile) = writeCCode ofn cfile-> --  where ofn = fromMaybe (rootname sfn ++ cExt) tfn-> --writeCode tfn sfn (Right cfiles) = zipWithM_ (writeCCode . mkFn) [1..] cfiles-> --  where prefix = fromMaybe (rootname sfn) tfn-> --        mkFn i = prefix ++ show i ++ cExt--> --writeCCode :: FilePath -> CFile -> IO ()-> --writeCCode fn = writeFile fn . showln . ppCFile+>  where fname = fromMaybe (replaceExtension sfn uacyExt) tfn  > showln :: Show a => a -> String > showln x = shows x "\n"@@ -614,7 +606,7 @@ > --  do > --    eq <- catch (matchInterface ifn i) (const (return False)) > --    unless eq (writeInterface ifn i)-> --  where ifn = rootname sfn ++ intfExt+> --  where ifn = dropExtension sfn ++ intfExt  > --matchInterface :: FilePath -> Interface -> IO Bool > --matchInterface ifn i =@@ -635,8 +627,8 @@ \begin{verbatim}  > lookupInterface :: [FilePath] -> ModuleIdent -> IO (Maybe FilePath)-> lookupInterface paths m = lookupFile (ifn : [catPath p ifn | p <- paths])->   where ifn = foldr1 catPath (moduleQualifiers m) ++ fintExt+> lookupInterface paths m = lookupFile ("":paths) [fintExt] ifn+>   where ifn = foldr1 catPath (moduleQualifiers m)  \end{verbatim} Literate source files use the extension \texttt{".lcurry"}.@@ -709,7 +701,7 @@ >   | otherwise >     = internalError "@Modules.genFlat: illegal option" >  where->    fintName = rootname fname ++ fintExt+>    fintName = replaceExtension fname fintExt >    cEnv = curryEnv mEnv tcEnv intf mod >    emptyIntf = Prog "" [] [] [] [] >    writeInterface intf msgs = do@@ -758,7 +750,7 @@ > patchModuleId :: FilePath -> Module -> Module > patchModuleId fn (Module mid mexports decls) >    | (moduleName mid) == "main"->      = Module (mkMIdent [basename (rootname fn)]) mexports decls+>      = Module (mkMIdent [takeBaseName fn]) mexports decls >    | otherwise >      = Module mid mexports decls
+ src/PathUtils.hs view
@@ -0,0 +1,95 @@+{-+  $Id: PathUtils.lhs,v 1.5 2003/05/04 16:12:35 wlux Exp $++  Copyright (c) 1999-2003, Wolfgang Lux+  See LICENSE for the full license.+-}++module PathUtils(-- re-exports from System.FilePath:+                 takeBaseName, replaceExtension, dropExtension,+                 takeDirectory, takeExtension, +                 pathSeparator,+                 catPath,++                 lookupFile,+                 writeModule,readModule,+                 doesModuleExist,maybeReadModule,getModuleModTime) where++import System.FilePath+import System.Directory+import System.Time (ClockTime)++import Control.Monad (unless)+++catPath :: FilePath -> FilePath -> FilePath+catPath = combine++lookupFile :: [FilePath] -> [String] -> String -> IO (Maybe FilePath)+lookupFile paths exts file = lookupFile' paths'+    where+      paths' = do p <- paths+                  e <- exts+                  let fn = p `combine` replaceExtension file e+                  [fn, inCurrySubdir fn]+      lookupFile' [] = return Nothing+      lookupFile' (fn:paths)+          = do so <- doesFileExist fn+               if so then return (Just fn) else lookupFile' paths++++-- add a subdirectory to a given filename +-- if it is not already present+--+-- inSubdir ""++inSubdir :: FilePath -> FilePath -> FilePath+inSubdir sub fn = joinPath $ add (splitDirectories fn) +  where+    add ps@[n] = sub:ps+    add ps@[p,n] | p==sub = ps+    add (p:ps) = p:add ps++--The sub directory to hide files in:++currySubdir :: String +currySubdir = ".curry"++inCurrySubdir :: FilePath -> FilePath+inCurrySubdir = inSubdir currySubdir++--write a file to curry subdirectory++writeModule :: FilePath -> String -> IO ()+writeModule filename contents = do+  let filename' = inCurrySubdir filename+      subdir = takeDirectory filename'+  ensureDirectoryExists (takeDirectory filename')+  writeFile filename' contents++ensureDirectoryExists :: FilePath -> IO ()+ensureDirectoryExists dir+    = do ex <- doesDirectoryExist dir+         unless ex (createDirectory dir)++-- do things with file in subdir++onExistingFileDo :: (FilePath -> IO a) -> FilePath -> IO a+onExistingFileDo act filename = do+  ex <- doesFileExist filename+  if ex then act filename +        else act $ inCurrySubdir filename++readModule :: FilePath -> IO String+readModule = onExistingFileDo readFile++maybeReadModule :: FilePath -> IO (Maybe String)+maybeReadModule filename = +  catch (readModule filename >>= return . Just) (\_ -> return Nothing)++doesModuleExist :: FilePath -> IO Bool+doesModuleExist = onExistingFileDo doesFileExist++getModuleModTime :: FilePath -> IO ClockTime+getModuleModTime = onExistingFileDo getModificationTime
− src/PathUtils.lhs 
@@ -1,60 +0,0 @@--% $Id: PathUtils.lhs,v 1.5 2003/05/04 16:12:35 wlux Exp $-%-% Copyright (c) 1999-2003, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{PathUtils.lhs}-\section{Pathnames}-This module implements some utility functions for manipulating path-names and finding files.-\begin{verbatim}--> module PathUtils(basename, rootname,extension, catPath,->                  lookupFile,->                  currySubdir,writeModule,readModule,->                  doesModuleExist,maybeReadModule,getModuleModTime) where--> import System.FilePath-> import System.Directory-> import CurrySubdir--\end{verbatim}--Most of this module is superseded by System.FilePath from package filepath.--Within this module we assume Unix style path semantics, i.e.\ -components of a path name are separated by forward slash characters-(\texttt{/}) and file extensions are separated with a dot character-(\texttt{.}).--\end{verbatim}--> catPath :: FilePath -> FilePath -> FilePath-> catPath = combine->-> rootname, extension :: FilePath -> FilePath-> rootname = dropExtension-> extension = takeExtension--\end{verbatim}--The function \texttt{lookupFile} can be used to search for files. It-returns the first name from the argument list for which a regular file-exists in the file system.-\begin{verbatim}--> lookupFile :: [FilePath] -> IO (Maybe FilePath)-> lookupFile fns = lookupFile' (concatMap (\ fn -> [inCurrySubdir fn,fn]) fns)->   where->     lookupFile' [] = return Nothing->     lookupFile' (fn:fns) =->      do->       so <- doesFileExist fn->       if so then return (Just fn) else lookupFile' fns--\end{verbatim}----
src/Position.lhs view
@@ -45,7 +45,6 @@ > incPosition :: Position -> Int -> Position > incPosition p j = p{ast=incSrcRef (ast p) j} - > instance Read Position where >   readsPrec p s =  >     [ (Position{file="",line=i,column=j,ast=noRef},s')  | ((i,j),s') <- readsPrec p s]
src/SCC.lhs view
@@ -22,8 +22,9 @@ \begin{verbatim}  > module SCC(scc) where-> import Set +> import qualified Data.Set as Set+ > data Node a b = Node{ key::Int, bvs::[b], fvs::[b], node::a }  > instance Eq (Node a b) where@@ -39,21 +40,21 @@ >   where wrap i n = Node i (bvs n) (fvs n) n  > tsort :: Eq b => [Node a b] -> [Node a b]-> tsort xs = snd (dfs xs zeroSet [])+> tsort xs = snd (dfs xs Set.empty []) >   where dfs [] marks stack = (marks,stack) >         dfs (x:xs) marks stack->           | x `elemSet` marks = dfs xs marks stack+>           | x `Set.member` marks = dfs xs marks stack >           | otherwise = dfs xs marks' (x:stack')->           where (marks',stack') = dfs (defs x) (x `addToSet` marks) stack+>           where (marks',stack') = dfs (defs x) (x `Set.insert` marks) stack >         defs x = filter (any (`elem` fvs x) . bvs) xs  > tsort' :: Eq b => [Node a b] -> [[Node a b]]-> tsort' xs = snd (dfs xs zeroSet [])+> tsort' xs = snd (dfs xs Set.empty []) >   where dfs [] marks stack = (marks,stack) >         dfs (x:xs) marks stack->           | x `elemSet` marks = dfs xs marks stack+>           | x `Set.member` marks = dfs xs marks stack >           | otherwise = dfs xs marks' ((x:concat stack'):stack)->           where (marks',stack') = dfs (uses x) (x `addToSet` marks) []+>           where (marks',stack') = dfs (uses x) (x `Set.insert` marks) [] >         uses x = filter (any (`elem` bvs x) . fvs) xs  \end{verbatim}
− src/Set.lhs 
@@ -1,91 +0,0 @@-% -*- LaTeX -*--% $Id: Set.lhs,v 1.6 2002/12/20 14:58:46 lux Exp $-%-% Copyright (c) 2002, Wolfgang Lux-% See LICENSE for the full license.-%-\nwfilename{Set.lhs}-\section{Sets}-The module \texttt{Set} implements sets as a special case of finite-maps.-\begin{verbatim}--> module Set where--> import Data.List-> import Data.Maybe--> import Map--> infixl 8 `addToSet`, `deleteFromSet`-> infixl 7 `unionSet`, `intersectionSet`-> infixl 6 `diffSet`, `symDiffSet`-> infix  4 `subsetSet`, `elemSet`, `notElemSet`--> newtype Set a = Set (FM a ())--\end{verbatim}-Two sets are equal if both contain the same elements.-\begin{verbatim}--> instance Ord a => Eq (Set a) where->   xs == ys = toListSet xs == toListSet ys--> instance (Ord a, Show a) => Show (Set a) where->   showsPrec p set =->     showChar '{' . showElems (map shows (toListSet set)) . showChar '}'->     where showElems = flip (foldr ($)) . intersperse (showChar ',')      -- $--> nullSet :: Ord a => Set a -> Bool-> nullSet = null . toListSet--> zeroSet :: Ord a => Set a-> zeroSet = Set zeroFM--> unitSet :: Ord a => a -> Set a-> unitSet x = Set (unitFM x ())--> addToSet :: Ord a => a -> Set a -> Set a-> addToSet x (Set xs) = Set (addToFM x () xs)--> deleteFromSet :: Ord a => a -> Set a -> Set a-> deleteFromSet x (Set xs) = Set (deleteFromFM x xs)--> elemSet :: Ord a => a -> Set a -> Bool-> elemSet x (Set xs) = isJust (lookupFM x xs)--> notElemSet :: Ord a => a -> Set a -> Bool-> notElemSet x set = not (elemSet x set)--> subsetSet :: Ord a => Set a -> Set a -> Bool-> subsetSet xs ys = all (`elemSet` ys) (toListSet xs)--> fromListSet :: Ord a => [a] -> Set a-> fromListSet = foldr addToSet zeroSet--> toListSet :: Ord a => Set a -> [a]-> toListSet (Set xs) = map fst (toListFM xs)--> unionSet :: Ord a => Set a -> Set a -> Set a-> unionSet xs ys = foldr addToSet xs (toListSet ys)--> unionSets :: Ord a => [Set a] -> Set a-> unionSets = foldr unionSet zeroSet--> intersectionSet :: Ord a => Set a -> Set a -> Set a-> intersectionSet xs ys =->   foldr addToSet zeroSet [y | y <- toListSet ys, y `elemSet` xs]--> diffSet :: Ord a => Set a -> Set a -> Set a-> diffSet xs ys = foldr deleteFromSet xs (toListSet ys)--> symDiffSet :: Ord a => Set a -> Set a -> Set a-> symDiffSet xs ys = unionSet (diffSet xs ys) (diffSet ys xs)--> mapSet :: (Ord a, Ord b) => (a -> b) -> Set a -> Set b-> mapSet f = fromListSet . map f . toListSet--> domainFM :: Ord a => FM a b -> Set a-> domainFM = Set . fmap (const ())--\end{verbatim}
src/Simplify.lhs view
@@ -33,7 +33,7 @@ > import Typing  -> type SimplifyState a = StateT ValueEnv (ReaderT EvalEnv (StateT Int Id)) a+> type SimplifyState a = StateT ValueEnv (ReaderT EvalEnv (St Int)) a > type InlineEnv = Env Ident Expression > type SimplifyFlags = Bool
src/Subst.lhs view
@@ -17,21 +17,21 @@  > module Subst where -> import Map+> import qualified Data.Map as Map -> data Subst a b = Subst Bool (FM a b) deriving Show+> data Subst a b = Subst Bool (Map.Map a b) deriving Show  > idSubst :: Ord a => Subst a b-> idSubst = Subst False zeroFM+> idSubst = Subst False Map.empty  > substToList :: Ord v => Subst v e -> [(v,e)]-> substToList (Subst _ sigma) = toListFM sigma+> substToList (Subst _ sigma) = Map.toList sigma  > bindSubst :: Ord v => v -> e -> Subst v e -> Subst v e-> bindSubst v e (Subst comp sigma) = Subst comp (addToFM v e sigma)+> bindSubst v e (Subst comp sigma) = Subst comp (Map.insert v e sigma)  > unbindSubst :: Ord v => v -> Subst v e -> Subst v e-> unbindSubst v (Subst comp sigma) = Subst comp (deleteFromFM v sigma)+> unbindSubst v (Subst comp sigma) = Subst comp (Map.delete v sigma)  \end{verbatim} For any substitution we have the following definitions:@@ -80,7 +80,7 @@ \begin{verbatim}  substVar :: Subst v e => Subst v e -> v -> e-substVar (Subst comp sigma) v = maybe (var v) subst' (lookupFM v sigma)+substVar (Subst comp sigma) v = maybe (var v) subst' (Map.lookup v sigma)   where subst' = if comp then subst (Subst comp sigma) else id  > compose :: (Show v,Ord v,Show e) => Subst v e -> Subst v e -> Subst v e@@ -104,7 +104,7 @@ > substVar' :: Ord v => (v -> e) -> (Subst v e -> e -> e) >           -> Subst v e -> v -> e > substVar' var subst (Subst comp sigma) v =->   maybe (var v) subst' (lookupFM v sigma)+>   maybe (var v) subst' (Map.lookup v sigma) >   where subst' = if comp then subst (Subst comp sigma) else id  > class IntSubst e where@@ -121,7 +121,7 @@  > restrictSubstTo :: Ord v => [v] -> Subst v e -> Subst v e > restrictSubstTo vs (Subst comp sigma) =->   foldr (uncurry bindSubst) (Subst comp zeroFM)->         (filter ((`elem` vs) . fst) (toListFM sigma))+>   foldr (uncurry bindSubst) (Subst comp Map.empty)+>         (filter ((`elem` vs) . fst) (Map.toList sigma))  \end{verbatim}
src/SyntaxCheck.lhs view
@@ -68,7 +68,7 @@ by which the variables get renamed. \begin{verbatim} -> type RenameState a = StateT Int Id a+> type RenameState a = St Int a  > run :: RenameState a -> a > run m = runSt m (globalKey + 1)
src/TypeCheck.lhs view
@@ -26,6 +26,7 @@ > import Control.Monad > import Data.List > import Data.Maybe+> import qualified Data.Set as Set  > import Base > import Pretty@@ -33,7 +34,7 @@ > import CurryPP > import Env > import TopEnv-> import Set+ > import Combined > import SCC > import TypeSubst@@ -82,7 +83,7 @@ which is used for generating fresh type variables. \begin{verbatim} -> type TcState a = StateT ValueEnv (StateT TypeSubst (StateT Int Id)) a+> type TcState a = StateT ValueEnv (StateT TypeSubst (St Int)) a  > run :: TcState a -> ValueEnv -> a > run m tyEnv = runSt (callSt (callSt m tyEnv) idSubst) 0@@ -400,14 +401,14 @@ signature the declared type must be too general. \begin{verbatim} -> genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set Int -> TypeSubst -> Decl+> genDecl :: ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst -> Decl >         -> TcState () > genDecl m tcEnv sigs lvs theta (FunctionDecl _ f _) = >   updateSt_ (genVar True m tcEnv sigs lvs theta f) > genDecl m tcEnv sigs lvs theta (PatternDecl p t _) = >   mapM_ (updateSt_ . genVar False m tcEnv sigs lvs theta ) (bv t) -> genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set Int -> TypeSubst+> genVar :: Bool -> ModuleIdent -> TCEnv -> SigEnv -> Set.Set Int -> TypeSubst >        -> Ident -> ValueEnv -> ValueEnv > genVar poly m tcEnv sigs lvs theta v tyEnv = >   case lookupTypeSig v sigs of@@ -1088,7 +1089,7 @@ >     theta <- liftSt fetchSt >     let ty' = subst theta ty >         fs = fsEnv (subst theta tyEnv)->     unless (all (`elemSet` fs) (typeSkolems ty'))+>     unless (all (`Set.member` fs) (typeSkolems ty')) >            (errorAt p (skolemEscapingScope m what ty')) >     --error (show ty ++ " ## " ++ show (subst theta ty)) >     return ty'@@ -1132,10 +1133,10 @@ >     tys' <- replicateM n' freshSkolem >     return (expandAliasType (tys ++ tys') ty) -> gen :: Set Int -> Type -> TypeScheme+> gen :: Set.Set Int -> Type -> TypeScheme > gen gvs ty = >   ForAll (length tvs) (subst (foldr2 bindSubst idSubst tvs tvs') ty)->   where tvs = [tv | tv <- nub (typeVars ty), tv `notElemSet` gvs]+>   where tvs = [tv | tv <- nub (typeVars ty), tv `Set.notMember` gvs] >         tvs' = map TypeVariable [0..]  \end{verbatim}@@ -1247,12 +1248,12 @@ know that they are closed. \begin{verbatim} -> fvEnv :: ValueEnv -> Set Int+> fvEnv :: ValueEnv -> Set.Set Int > fvEnv tyEnv =->   fromListSet [tv | ty <- localTypes tyEnv, tv <- typeVars ty, tv < 0]+>   Set.fromList [tv | ty <- localTypes tyEnv, tv <- typeVars ty, tv < 0] -> fsEnv :: ValueEnv -> Set Int-> fsEnv tyEnv = unionSets (map (fromListSet . typeSkolems) (localTypes tyEnv))+> fsEnv :: ValueEnv -> Set.Set Int+> fsEnv tyEnv = Set.unions (map (Set.fromList . typeSkolems) (localTypes tyEnv))  > localTypes :: ValueEnv -> [Type] > localTypes tyEnv = [ty | (_,Value _ (ForAll _ ty)) <- localBindings tyEnv]
src/Typing.lhs view
@@ -84,7 +84,7 @@ environment.} \begin{verbatim} -> type TyState a = StateT TypeSubst (StateT Int Id) a+> type TyState a = StateT TypeSubst (St Int) a  > run :: TyState a -> ValueEnv -> a > run m tyEnv = runSt (callSt m idSubst) 0
src/cymake.hs view
@@ -44,8 +44,8 @@    | null files     = badUsage prog ["no files"]    | null errs' && not (elem Html opts)    = do        unless (noVerb options') -              (putStrLn  $ "This is cymake, version 1.1." -                         ++ filter isDigit "$Revision: 3620 $")+              (putStrLn  $ "This is cymake, version 0.1." +                         ++ filter isDigit "$Revision: 3624 $")        mapM_ (buildCurry options') files    | null errs' = do       let importFiles = nub $ importPaths opts'