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

Integration of language pragmas

parent 07a4de3f
......@@ -53,11 +53,10 @@ kindCheck _ env (Module ps m es is ds)
-- disambiguated, variables are renamed
-- * Environment: remains unchanged
syntaxCheck :: Monad m => Check m Module
syntaxCheck opts env (Module ps m es is ds)
| null msgs = right (env, Module ps m es is ds')
syntaxCheck opts env mdl
| null msgs = right (env, mdl')
| otherwise = left msgs
where (ds', msgs) = SC.syntaxCheck opts (moduleIdent env)
(valueEnv env) (tyConsEnv env) ds
where (mdl', msgs) = SC.syntaxCheck opts (valueEnv env) (tyConsEnv env) mdl
-- |Check the precedences of infix operators.
--
......
......@@ -56,14 +56,13 @@ generated. Finally, all declarations are checked within the resulting
environment. In addition, this process will also rename the local variables.
\begin{verbatim}
> syntaxCheck :: Options -> ModuleIdent -> ValueEnv -> TCEnv -> [Decl]
> -> ([Decl], [Message])
> syntaxCheck opts m tyEnv tcEnv decls =
> syntaxCheck :: Options -> ValueEnv -> TCEnv -> Module -> (Module, [Message])
> syntaxCheck opts tyEnv tcEnv mdl@(Module _ m _ _ ds) =
> case findMultiples $ concatMap constrs typeDecls of
> [] -> runSC (checkModule decls) state
> css -> (decls, map errMultipleDataConstructor css)
> [] -> runSC (checkModule mdl) state
> css -> (mdl, map errMultipleDataConstructor css)
> where
> typeDecls = filter isTypeDecl decls
> typeDecls = filter isTypeDecl ds
> rEnv = globalEnv $ fmap (renameInfo tcEnv) tyEnv
> state = initState (optExtensions opts) m rEnv
......@@ -316,13 +315,23 @@ a goal. Note that all declarations in the goal must be considered as
local declarations.
\begin{verbatim}
> checkModule :: [Decl] -> SCM [Decl]
> checkModule decls = do
> checkModule :: Module -> SCM Module
> checkModule (Module ps m es is decls) = do
> mapM_ checkPragma ps
> mapM_ bindTypeDecl (rds ++ dds)
> liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
> decls' <- liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
> return $ Module ps m es is decls'
> where (tds, vds) = partition isTypeDecl decls
> (rds, dds) = partition isRecordDecl tds
> checkPragma :: ModulePragma -> SCM ()
> checkPragma (LanguagePragma _ exts) = mapM_ checkExtension exts
> checkPragma (OptionsPragma _ _ _) = ok
> checkExtension :: Extension -> SCM ()
> checkExtension (KnownExtension _ e) = enableExtension e
> checkExtension (UnknownExtension p e) = report $ errUnknownExtension p e
> checkTypeDecl :: Decl -> SCM Decl
> checkTypeDecl rec@(TypeDecl _ r _ (RecordType fs rty)) = do
> checkRecordExtension $ idPosition r
......@@ -980,22 +989,22 @@ Miscellaneous functions.
\begin{verbatim}
> checkFuncPatsExtension :: Position -> SCM ()
> checkFuncPatsExtension p = checkExtension p
> checkFuncPatsExtension p = checkUsedExtension p
> "Functional Patterns" FunctionalPatterns
> checkRecordExtension :: Position -> SCM ()
> checkRecordExtension p = checkExtension p "Records" Records
> checkRecordExtension p = checkUsedExtension p "Records" Records
> checkAnonFreeVarsExtension :: Position -> SCM ()
> checkAnonFreeVarsExtension p = checkExtension p
> checkAnonFreeVarsExtension p = checkUsedExtension p
> "Anonymous free variables" AnonFreeVars
> checkExtension :: Position -> String -> KnownExtension -> SCM ()
> checkExtension pos msg ext = do
> checkUsedExtension :: Position -> String -> KnownExtension -> SCM ()
> checkUsedExtension pos msg ext = do
> enabled <- hasExtension ext
> unless enabled $ do
> report $ errMissingLanguageExtension pos msg ext
> enableExtension ext
> enableExtension ext -- to avoid multiple warnings
> typeArity :: TypeExpr -> Int
> typeArity (ArrowType _ t2) = 1 + typeArity t2
......@@ -1122,6 +1131,10 @@ Error messages.
> [ "Expexting", escName anonId, "after", escName (mkIdent "|")
> , "in the record pattern" ]
> errUnknownExtension :: Position -> String -> Message
> errUnknownExtension p e = posMessage p $
> text "Unknown language extension:" <+> text e
> errMissingLanguageExtension :: Position -> String -> KnownExtension -> Message
> errMissingLanguageExtension p what ext = posMessage p $
> text what <+> text "are not supported in standard Curry." $+$
......
......@@ -29,7 +29,8 @@ import Curry.Base.Pretty
import Curry.Files.Filenames
import Curry.Files.PathUtils
import Curry.Syntax
(Module (..), ImportDecl (..), parseHeader, patchModuleId)
( Module (..), ImportDecl (..), parseHeader, patchModuleId
, hasLanguageExtension)
import Base.Messages
import Base.SCC (scc)
......@@ -90,20 +91,21 @@ sourceDeps opts sEnv fn = readHeader fn >>= moduleDeps opts sEnv fn
-- |Retrieve the dependencies of a given module
moduleDeps :: Options -> SourceEnv -> FilePath -> Module -> CYIO SourceEnv
moduleDeps opts sEnv fn (Module _ m _ is _) = case Map.lookup m sEnv of
moduleDeps opts sEnv fn mdl@(Module _ m _ _ _) = case Map.lookup m sEnv of
Just _ -> return sEnv
Nothing -> do
let imps = imports opts m is
let imps = imports opts mdl
sEnv' = Map.insert m (Source fn imps) sEnv
foldM (moduleIdentDeps opts) sEnv' imps
-- |Retrieve the imported modules and add the import of the Prelude
-- according to the compiler options.
imports :: Options -> ModuleIdent -> [ImportDecl] -> [ModuleIdent]
imports opts m ds = nub $
[preludeMIdent | m /= preludeMIdent && implicitPrelude]
++ [m' | ImportDecl _ m' _ _ _ <- ds]
where implicitPrelude = NoImplicitPrelude `notElem` optExtensions opts
imports :: Options -> Module -> [ModuleIdent]
imports opts mdl@(Module _ m _ is _) = nub $
[preludeMIdent | m /= preludeMIdent && not noImplicitPrelude]
++ [m' | ImportDecl _ m' _ _ _ <- is]
where noImplicitPrelude = NoImplicitPrelude `elem` optExtensions opts
|| mdl `hasLanguageExtension` NoImplicitPrelude
-- |Retrieve the dependencies for a given 'ModuleIdent'
moduleIdentDeps :: Options -> SourceEnv -> ModuleIdent -> CYIO SourceEnv
......
{-# LANGUAGE ERROR #-}
module PragmaError where
{-# LANGUAGE Records #-}
module PragmaRecords where
type Rec = { bool :: Bool, int :: Int }
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