Commit 54dcdba2 authored by Björn Peemöller 's avatar Björn Peemöller
Browse files

Compilation errors removed

parent 7e5d0d97
......@@ -149,11 +149,11 @@ visitExpr _ aEnv _ = aEnv
visitStatement :: ModuleIdent -> ArityEnv -> Statement -> ArityEnv
visitStatement mid aEnv (StmtExpr _ expr)
= visitExpression mid aEnv expr
= visitExpr mid aEnv expr
visitStatement mid aEnv (StmtDecl decls)
= foldl (visitDecl mid) aEnv decls
visitStatement mid aEnv (StmtBind _ _ expr)
= visitExpression mid aEnv expr
= visitExpr mid aEnv expr
visitAlt :: ModuleIdent -> ArityEnv -> Alt -> ArityEnv
visitAlt mid aEnv (Alt _ _ rhs) = visitRhs mid aEnv rhs
......
......@@ -8,7 +8,6 @@
module CompilerOpts
( Options (..), Verbosity (..), TargetType (..), Extension (..)
, DumpLevel (..), defaultOptions, compilerOpts, usage
, implicitPrelude
) where
import Data.List (nub)
......@@ -29,7 +28,7 @@ data Options = Options
, optForce :: Bool -- ^ force compilation
, optImportPaths :: [FilePath] -- ^ directories for imports
, optOutput :: Maybe FilePath -- ^ name of output file
, optUseSubdir :: Bool -- use subdir for output?
, optUseSubdir :: Bool -- ^ use subdir for output?
, optInterface :: Bool -- ^ do not create an interface file
, optWarn :: Bool -- ^ warnings on/off
, optOverlapWarn :: Bool -- ^ "overlap" warnings on/off
......
......@@ -23,9 +23,7 @@ In this section a lexer for Curry is implemented.
> import Data.Char (chr, ord, isAlpha, isAlphaNum, isSpace, isUpper
> , isDigit, isOctDigit, isHexDigit)
> import Data.List (intercalate)
> import qualified Data.Map as Map (Map, union, lookup, fromList
> , findWithDefault)
> import Data.Maybe (fromMaybe)
> import qualified Data.Map as Map (Map, union, lookup, fromList)
> import Curry.Base.LexComb
> import Curry.Base.LLParseComb (Symbol (..))
......@@ -236,9 +234,6 @@ all tokens in their source representation.
-- Helper for showing
> showsQualified :: [String] -> String -> ShowS
> showsQualified modul ident = showsEscaped $ intercalate "." $ modul ++ [ident]
> showsEscaped :: String -> ShowS
> showsEscaped s = showChar '`' . showString s . showChar '\''
......@@ -540,7 +535,7 @@ Lexing functions
> lexSymbol :: (Token -> P a) -> P a
> lexSymbol cont p s =
> cont (idTok (maybe Sym id (Map.lookup sym keywordsSpecialIds)) [] sym)
> cont (idTok (maybe Sym id (Map.lookup sym reservedSpecialOps)) [] sym)
> (incr p (length sym)) rest
> where (sym,rest) = span isSymbol s
......
......@@ -726,7 +726,7 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected")
> sym :: Parser Token Ident a
> sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*>
> tokens [Sym,Sym_Dot,Sym_Minus,Sym_MinusDot]
> tokens [Sym, SymColon, SymDot, SymMinus, SymMinusDot]
> qSym :: Parser Token QualIdent a
> qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym
......@@ -735,15 +735,15 @@ qconop = qConSym <|> backquotes (qConId <?> "operator name expected")
> colon :: Parser Token QualIdent a
> colon = (\ p _ -> qualify $ addPositionIdent p consId) <$>
> position <*> token Colon
> position <*> token SymColon
> minus :: Parser Token Ident a
> minus = (\ p _ -> addPositionIdent p minusId) <$>
> position <*> token Sym_Minus
> position <*> token SymMinus
> fminus :: Parser Token Ident a
> fminus = (\ p _ -> addPositionIdent p fminusId) <$>
> position <*> token Sym_MinusDot
> position <*> token SymMinusDot
> tupleCommas :: Parser Token QualIdent a
> tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length )
......
......@@ -16,7 +16,7 @@ import Curry.Files.Filenames
import Curry.Files.PathUtils ( dropExtension, doesModuleExist, lookupCurryFile
, getModuleModTime, tryGetModuleModTime)
import CompilerOpts (Options (..), Extension (..), TargetType (..))
import CompilerOpts (Options (..), TargetType (..))
import CurryDeps (Source (..), flatDeps)
import Messages (status, abortWith)
import Modules (compileModule)
......@@ -27,7 +27,7 @@ import Modules (compileModule)
-}
buildCurry :: Options -> FilePath -> IO ()
buildCurry opts file = do
mbFile <- lookupCurryFile importPaths file
mbFile <- lookupCurryFile (optImportPaths opts) file
case mbFile of
Nothing -> abortWith [missingModule file]
Just f -> do
......@@ -85,13 +85,13 @@ makeCurry opts deps1 targetFile = mapM_ (compile . snd) deps1 where
compileFile f = do
status opts $ "compiling " ++ f
compileModule (compOpts True) f >> return ()
compileModule (compOpts True) f
skipFile f = status opts $ "skipping " ++ f
generateFile f = do
status opts $ "generating " ++ head (targetNames f)
compileModule (compOpts False) f >> return ()
compileModule (compOpts False) f
compOpts isImport
| isImport = opts { optTargetTypes = [FlatCurry], optDumps = [] }
......
......@@ -42,7 +42,7 @@ dependencies and to update programs composed of multiple modules.
> mEnv <- deps implicitPrelude [] libPaths Map.empty fn
> return $ flattenDeps mEnv
> where
> implicitPrelude = NoImplicitPrelude `notElem` optExtensions otps
> implicitPrelude = NoImplicitPrelude `notElem` optExtensions opts
> libPaths = optImportPaths opts
> deps :: Bool -> [FilePath] -> [FilePath] -> SourceEnv -> FilePath
......
......@@ -87,12 +87,11 @@ makeInterfaces paths (CS.Module mid _ decls) = do
when (null errs) (mapM_ (compile deps1 . snd) deps1)
return errs
where
compile deps' (Source file' mods) = do
_ <- smake [flatName file', flatIntName file']
compile deps' (Source file' mods) = smake
[flatName file', flatIntName file']
(file':mapMaybe (flatInterface deps') mods)
(compileModule (opts paths) file')
(return Nothing)
return ()
(return ())
compile _ _ = return ()
flatInterface deps' mod1 = case (lookup mod1 deps') of
......
......@@ -109,7 +109,7 @@ partitionDecl parts (FlatExternalDecl pos ids)
= partitionFuncDecls (\ident -> FlatExternalDecl pos [ident]) parts ids
-- op decls
partitionDecl parts (InfixDecl pos fix prec idents)
= partitions {opDecls = map (\ident -> (InfixDecl pos fix prec [ident])) idents ++ opDecls parts }
= parts {opDecls = map (\ident -> (InfixDecl pos fix prec [ident])) idents ++ opDecls parts }
-- default
partitionDecl parts _ = parts
......
......@@ -58,8 +58,8 @@ genFlatCurry opts cEnv mEnv tyEnv tcEnv aEnv modul
-- transforms intermediate language code (IL) to FlatCurry interfaces
genFlatInterface :: Options -> CurryEnv -> ModuleEnv -> ValueEnv -> TCEnv
-> ArityEnv -> IL.Module -> (Prog, [WarnMsg])
genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv modul
= (patchPreludeFCY intf, messages)
genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv modul =
(patchPreludeFCY intf, messages)
where (intf, messages)
= run opts cEnv mEnv tyEnv tcEnv aEnv True (visitModule modul)
......
......@@ -427,7 +427,7 @@ token2code tok@(Token cat _)
= Keyword (token2string tok)
| elem cat [LeftParen,RightParen,Semicolon,LeftBrace,RightBrace,LeftBracket,
RightBracket,Comma,Underscore,Backquote,
At,Colon,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow,
At,DotDot,DoubleColon,Equals,Backslash,Bar,LeftArrow,RightArrow,
Tilde]
= Symbol (token2string tok)
| elem cat [LineComment, NestedComment]
......@@ -443,7 +443,7 @@ token2code tok@(Token cat _)
isTokenIdentifier :: Token -> Bool
isTokenIdentifier (Token cat _) =
elem cat [Id,QId,Sym,QSym,Sym_Dot,Sym_Minus,Sym_MinusDot]
elem cat [Id, QId, Sym, QSym, SymColon, SymDot, SymMinus, SymMinusDot]
-- DECL Position
......@@ -714,7 +714,6 @@ token2string (Token Backquote _) = "`"
token2string (Token VSemicolon _) = ""
token2string (Token VRightBrace _) = ""
token2string (Token At _) = "@"
token2string (Token Colon _) = ":"
token2string (Token DotDot _) = ".."
token2string (Token DoubleColon _) = "::"
token2string (Token Equals _) = "="
......@@ -723,9 +722,10 @@ token2string (Token Bar _) = "|"
token2string (Token LeftArrow _) = "<-"
token2string (Token RightArrow _) = "->"
token2string (Token Tilde _) = "~"
token2string (Token Sym_Dot _) = "."
token2string (Token Sym_Minus _) = "-"
token2string (Token Sym_MinusDot _) = "-."
token2string (Token SymColon _) = ":"
token2string (Token SymDot _) = "."
token2string (Token SymMinus _) = "-"
token2string (Token SymMinusDot _) = "-."
token2string (Token KW_case _) = "case"
token2string (Token KW_choice _) = "choice"
token2string (Token KW_data _) = "data"
......
......@@ -20,7 +20,6 @@ This module controls the compilation of modules.
> import Data.List (find, isPrefixOf, partition)
> import qualified Data.Map as Map (Map, empty, insert, insertWith, lookup, toList)
> import Data.Maybe (fromMaybe)
> import System.IO (stderr, hPutStrLn)
> import Text.PrettyPrint.HughesPJ (Doc, ($$), text, vcat)
> import qualified Curry.AbstractCurry as AC
......@@ -34,14 +33,14 @@ This module controls the compilation of modules.
> import qualified Curry.IL as IL
> import Curry.Syntax
> import Base.Arity (ArityEnv, initAEnv, bindArities)
> import Base.Eval (evalEnv)
> import Base.Import (bindAlias, initIEnv, fromDeclList)
> import Base.Module (ModuleEnv)
> import Base.OpPrec (PEnv, initPEnv)
> import Base.TypeConstructors (TCEnv, TypeInfo (..), initTCEnv, qualLookupTC)
> import Base.Types (toType, fromQualType)
> import Base.Value (ValueEnv, ValueInfo (..), initDCEnv)
> import Base.Arity (ArityEnv, initAEnv, bindArities)
> import Base.Import (bindAlias, initIEnv)
> import Check.InterfaceCheck (interfaceCheck)
> import Check.KindCheck (kindCheck)
> import Check.SyntaxCheck (syntaxCheck)
......@@ -66,7 +65,7 @@ This module controls the compilation of modules.
> import CurryToIL (ilTrans)
> import Exports (expandInterface, exportInterface)
> import Imports (importInterface, importInterfaceIntf, importUnifyData)
> import Messages (errorAt, internalError)
> import Messages (errorAt, internalError, putErrsLn)
> import Types
> import TypeSubst
......@@ -94,7 +93,7 @@ as a frontend for PAKCS, all functions for evaluating goals and generating C
code are obsolete and commented out.
\begin{verbatim}
> compileModule :: Options -> FilePath -> IO (Maybe FilePath)
> compileModule :: Options -> FilePath -> IO ()
> compileModule opts fn = do
> -- read and parse module
> parsed <- (ok . parseModule likeFlat fn) `liftM` readModule fn
......@@ -110,7 +109,7 @@ code are obsolete and commented out.
> then do
> (tyEnv, tcEnv, _, m', _, _) <- simpleCheckModule opts mEnv m
> -- generate untyped AbstractCurry
> when uacy $ genAbstract opts fn tyEnv tcEnv m' >> return ()
> when uacy $ genAbstract opts fn tyEnv tcEnv m'
> -- output the parsed source
> when src $ genParsed opts fn m'
> else do
......@@ -123,8 +122,8 @@ code are obsolete and commented out.
> -- dump intermediate results
> mapM_ (doDump opts) dumps
> -- generate target code
> when (acy || uacy) $ genAbstract opts fn tyEnv tcEnv m' >> return ()
> when (fcy || xml) $ genFlat opts fn mEnv tyEnv tcEnv aEnv' intf m' il >> return ()
> when (acy || uacy) $ genAbstract opts fn tyEnv tcEnv m'
> when (fcy || xml) $ genFlat opts fn mEnv tyEnv tcEnv aEnv' intf m' il
> when src $ genParsed opts fn m'
> where
> acy = AbstractCurry `elem` optTargetTypes opts
......@@ -168,7 +167,7 @@ only a qualified import is added.
\begin{verbatim}
> importPrelude :: Options -> FilePath -> Module -> Module
> importPrelude opts fn m(Module mid es ds)
> importPrelude opts fn m@(Module mid es ds)
> -- the Prelude itself
> | mid == preludeMIdent = m
> -- disabled by option
......@@ -183,15 +182,15 @@ only a qualified import is added.
> False -- qualified
> Nothing -- no alias
> Nothing -- no selection of types, functions, etc.
> imported = [imp | decl@(ImportDecl _ imp _ _ _) <- ds]
> imported = [imp | (ImportDecl _ imp _ _ _) <- ds]
> -- |
> simpleCheckModule :: Options -> ModuleEnv -> Module
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg])
> simpleCheckModule opts mEnv (Module m es ds) = do
> showWarnings warnMsgs
> return (tyEnv'', tcEnv, aEnv'', modul, intf, msgs)
> showWarnings opts warnMsgs
> return (tyEnv'', tcEnv, aEnv'', modul, intf, warnMsgs)
> where
> -- split import declarations
> (impDs, topDs) = partition isImportDecl ds
......@@ -215,9 +214,9 @@ only a qualified import is added.
> checkModule :: Options -> ModuleEnv -> Module
> -> IO (ValueEnv, TCEnv, ArityEnv, Module, Interface, [WarnMsg])
> checkModule opts mEnv (Module m es ds) = do
> showWarnings warnMsgs
> showWarnings opts warnMsgs
> when (m == mkMIdent ["field114..."]) (error (show es))
> return (tyEnv''', tcEnv', aEnv'', modul, intf, msgs)
> return (tyEnv''', tcEnv', aEnv'', modul, intf, warnMsgs)
> where
> (impDs, topDs) = partition isImportDecl ds
> iEnv = foldr bindAlias initIEnv impDs
......@@ -484,7 +483,7 @@ Interface files are updated by the Curry builder when necessary.
> writeFlatFile :: Options -> (Prog, [WarnMsg]) -> String -> IO Prog
> writeFlatFile opts (res, msgs) fname = do
> showWarnings msgs
> showWarnings opts msgs
> when extended $ writeExtendedFlat sub fname res
> when flat $ writeFlatCurry sub fname res
> return res
......@@ -535,51 +534,43 @@ be dependent on it any longer.
\begin{verbatim}
> genFlat :: Options -> FilePath -> ModuleEnv -> ValueEnv -> TCEnv -> ArityEnv
> -> Interface -> Module -> IL.Module -> IO (Maybe FilePath)
> genFlat opts fname mEnv tyEnv tcEnv aEnv intf modul il
> | FlatCurry `elem` optTargetTypes opts
> = do _ <- writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il
> -> Interface -> Module -> IL.Module -> IO ()
> genFlat opts fname mEnv tyEnv tcEnv aEnv intf modul il = do
> when fcy $ do
> _ <- writeFlat opts Nothing fname cEnv mEnv tyEnv tcEnv aEnv il
> let (flatInterface,intMsgs) = genFlatInterface opts cEnv mEnv tyEnv tcEnv aEnv il
> if optForce opts
> then
> do writeInterface flatInterface intMsgs
> return Nothing
> else
> do mfint <- readFlatInterface fintName
> then writeInterface flatInterface intMsgs
> else do
> mfint <- readFlatInterface fintName
> let flatIntf = fromMaybe emptyIntf mfint
> if mfint == mfint -- necessary to close the file 'fintName'
> && not (interfaceCheck flatIntf flatInterface)
> then
> do writeInterface flatInterface intMsgs
> return Nothing
> else return Nothing
> | FlatXml `elem` optTargetTypes opts
> = writeXML (optUseSubdir opts) (optOutput opts) fname cEnv il >>
> return Nothing
> | otherwise
> = internalError "@Modules.genFlat: illegal option"
> when (mfint == mfint -- necessary to close the file 'fintName'
> && not (interfaceCheck flatIntf flatInterface)) $
> writeInterface flatInterface intMsgs
> when xml $ writeXML (optUseSubdir opts) (optOutput opts) fname cEnv il
> where
> fcy = FlatCurry `elem` optTargetTypes opts
> xml = FlatXml `elem` optTargetTypes opts
> fintName = flatIntName fname
> cEnv = curryEnv mEnv tcEnv intf modul
> emptyIntf = Prog "" [] [] [] []
> writeInterface intf' msgs = do
> when (optWarn opts) (printMessages msgs)
> showWarnings opts msgs
> writeFlatCurry (optUseSubdir opts) fintName intf'
> genAbstract :: Options -> FilePath -> ValueEnv -> TCEnv -> Module -> IO (Maybe FilePath)
> genAbstract opts@Options{optUseSubdir=sub} fname tyEnv tcEnv modul
> | AbstractCurry `elem` optTargetTypes opts
> = do writeTypedAbs sub Nothing fname tyEnv tcEnv modul
> return Nothing
> | UntypedAbstractCurry `elem` optTargetTypes opts
> = do writeUntypedAbs sub Nothing fname tyEnv tcEnv modul
> return Nothing
> | otherwise
> = internalError "@Modules.genAbstract: illegal option"
> genAbstract :: Options -> FilePath -> ValueEnv -> TCEnv -> Module -> IO ()
> genAbstract opts fname tyEnv tcEnv modul = do
> when acy $ writeTypedAbs subdir Nothing fname tyEnv tcEnv modul
> when uacy $ writeUntypedAbs subdir Nothing fname tyEnv tcEnv modul
> where
> subdir = optUseSubdir opts
> acy = AbstractCurry `elem` optTargetTypes opts
> uacy = UntypedAbstractCurry `elem` optTargetTypes opts
> genParsed :: Options -> FilePath -> Module -> IO ()
> getParsed opts fn modul = writeModule intoSubdir outputFile modString
> genParsed opts fn modul = writeModule intoSubdir outputFile modString
> where
> intoSubdir = optUseSubdir opts
> outputFile = fromMaybe (sourceRepName fn) (optOutput opts)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment