Commit ab75f16d authored by Björn Peemöller 's avatar Björn Peemöller

Added language extension NegativeLiterals

parent 6367e2f3
......@@ -4,6 +4,10 @@ Change log for curry-frontend
Under development
=================
* Added syntax extension `NegativeLiterals` to translate negated literals
into negative literals instead of a call to `Prelude.negate` and
`Prelude.negateFloat`, respectively.
* The frontend now considers options pragmas of the following form:
~~~ {.curry}
......
......@@ -54,9 +54,10 @@ kindCheck _ env (Module ps m es is ds)
-- * Environment: remains unchanged
syntaxCheck :: Monad m => Check m Module
syntaxCheck opts env mdl
| null msgs = right (env, mdl')
| null msgs = right (env { extensions = exts }, mdl')
| otherwise = left msgs
where (mdl', msgs) = SC.syntaxCheck opts (valueEnv env) (tyConsEnv env) mdl
where ((mdl', exts), msgs) = SC.syntaxCheck opts (valueEnv env)
(tyConsEnv env) mdl
-- |Check the precedences of infix operators.
--
......
......@@ -56,15 +56,17 @@ generated. Finally, all declarations are checked within the resulting
environment. In addition, this process will also rename the local variables.
\begin{verbatim}
> syntaxCheck :: Options -> ValueEnv -> TCEnv -> Module -> (Module, [Message])
> syntaxCheck :: Options -> ValueEnv -> TCEnv -> Module
> -> ((Module, [KnownExtension]), [Message])
> syntaxCheck opts tyEnv tcEnv mdl@(Module _ m _ _ ds) =
> case findMultiples $ concatMap constrs typeDecls of
> [] -> runSC (checkModule mdl) state
> css -> (mdl, map errMultipleDataConstructor css)
> css -> ((mdl, exts), map errMultipleDataConstructor css)
> where
> typeDecls = filter isTypeDecl ds
> rEnv = globalEnv $ fmap (renameInfo tcEnv) tyEnv
> state = initState (optExtensions opts) m rEnv
> state = initState exts m rEnv
> exts = optExtensions opts
\end{verbatim}
A global state transformer is used for generating fresh integer keys with
......@@ -108,6 +110,10 @@ renaming literals and underscore to disambiguate them.
> enableExtension :: KnownExtension -> SCM ()
> enableExtension e = S.modify $ \ s -> s { extensions = e : extensions s }
> -- |Retrieve all enabled extensions
> getExtensions :: SCM [KnownExtension]
> getExtensions = S.gets extensions
> -- |Retrieve the 'ModuleIdent' of the current module
> getModuleIdent :: SCM ModuleIdent
> getModuleIdent = S.gets moduleIdent
......@@ -315,12 +321,13 @@ a goal. Note that all declarations in the goal must be considered as
local declarations.
\begin{verbatim}
> checkModule :: Module -> SCM Module
> checkModule :: Module -> SCM (Module, [KnownExtension])
> checkModule (Module ps m es is decls) = do
> mapM_ checkPragma ps
> mapM_ bindTypeDecl (rds ++ dds)
> decls' <- liftM2 (++) (mapM checkTypeDecl tds) (checkTopDecls vds)
> return $ Module ps m es is decls'
> exts <- getExtensions
> return (Module ps m es is decls', exts)
> where (tds, vds) = partition isTypeDecl decls
> (rds, dds) = partition isRecordDecl tds
......
......@@ -225,6 +225,8 @@ extensions =
, "enable anonymous free variables" )
, ( FunctionalPatterns, "FunctionalPatterns"
, "enable functional patterns" )
, ( NegativeLiterals , "NegativeLiterals"
, "desugar negated literals as negative literal")
, ( NoImplicitPrelude , "NoImplicitPrelude"
, "do not implicitly import the Prelude")
, ( Records , "Records"
......
......@@ -48,7 +48,8 @@ transType = IL.transType
-- |Remove syntactic sugar
desugar :: Module -> CompilerEnv -> (Module, CompilerEnv)
desugar mdl env = (mdl', env { valueEnv = tyEnv' })
where (mdl', tyEnv') = DS.desugar (valueEnv env) (tyConsEnv env) mdl
where (mdl', tyEnv') = DS.desugar (extensions env) (valueEnv env)
(tyConsEnv env) mdl
-- |Lift local declarations
lift :: Module -> CompilerEnv -> (Module, CompilerEnv)
......
......@@ -99,8 +99,9 @@ variables.
\begin{verbatim}
> data DesugarState = DesugarState
> { moduleIdent :: ModuleIdent -- read-only
> , tyConsEnv :: TCEnv -- read-only
> { moduleIdent :: ModuleIdent -- read-only
> , extensions :: [KnownExtension] -- read-only
> , tyConsEnv :: TCEnv -- read-only
> , valueEnv :: ValueEnv
> , nextId :: Integer -- counter
> }
......@@ -110,6 +111,9 @@ variables.
> getModuleIdent :: DsM ModuleIdent
> getModuleIdent = S.gets moduleIdent
> negativeLiterals :: DsM Bool
> negativeLiterals = S.gets (\s -> NegativeLiterals `elem` extensions s)
> getTyConsEnv :: DsM TCEnv
> getTyConsEnv = S.gets tyConsEnv
......@@ -159,10 +163,12 @@ Actually, the transformation is slightly more general than necessary
as it allows value declarations at the top-level of a module.
\begin{verbatim}
> desugar :: ValueEnv -> TCEnv -> Module -> (Module, ValueEnv)
> desugar tyEnv tcEnv (Module ps m es is ds) = (Module ps m es is ds', valueEnv s')
> desugar :: [KnownExtension] -> ValueEnv -> TCEnv -> Module
> -> (Module, ValueEnv)
> desugar xs tyEnv tcEnv (Module ps m es is ds)
> = (Module ps m es is ds', valueEnv s')
> where (ds', s') = S.runState (desugarModuleDecls ds)
> (DesugarState m tcEnv tyEnv 1)
> (DesugarState m xs tcEnv tyEnv 1)
> desugarModuleDecls :: [Decl] -> DsM [Decl]
> desugarModuleDecls ds = do
......@@ -454,7 +460,11 @@ type \texttt{Bool} of the guard because the guard's type defaults to
> apply prelEnumFromThenTo `liftM` mapM (dsExpr p) [e1, e2, e3]
> dsExpr p (UnaryMinus op e) = do
> ty <- getTypeOf e
> Apply (unaryMinus op ty) `liftM` dsExpr p e
> e' <- dsExpr p e
> negativeLits <- negativeLiterals
> case e' of
> Literal l | negativeLits -> return (Literal $ negateLiteral l)
> _ -> Apply (unaryMinus op ty) `liftM` dsExpr p e
> where
> unaryMinus op1 ty'
> | op1 == minusId = if ty' == floatType then prelNegateFloat else prelNegate
......
{-# LANGUAGE NegativeLiterals #-}
module NegLit where
f (-1) = -2354843759837495739457394
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