Added language extension NegativeLiterals

CHANGELOG.md

@@ -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}

src/Checks.hs

@@ -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.
 --

src/Checks/SyntaxCheck.lhs

@@ -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
 

src/CompilerOpts.hs

@@ -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"

src/Transformations.hs

@@ -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)

src/Transformations/Desugar.lhs

@@ -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

test/NegLit.curry

+{-# LANGUAGE NegativeLiterals #-}
+module NegLit where
+
+f (-1) = -2354843759837495739457394