From 94ed5858afcf501c952f90a9fc9aab101cbf6d73 Mon Sep 17 00:00:00 2001
From: Finn Teegen <fte@informatik.uni-kiel.de>
Date: Sat, 11 Jun 2016 20:27:46 +0200
Subject: [PATCH] Remove explicit overloading of numeric literals
---
src/Curry/Syntax/Lexer.hs | 3 --
src/Curry/Syntax/Parser.hs | 59 +++++++++++++---------------------
src/Curry/Syntax/Pretty.hs | 7 ++--
src/Curry/Syntax/ShowModule.hs | 9 ++----
src/Curry/Syntax/Type.hs | 21 +++++-------
src/Curry/Syntax/Utils.hs | 6 +---
6 files changed, 39 insertions(+), 66 deletions(-)
diff --git a/src/Curry/Syntax/Lexer.hs b/src/Curry/Syntax/Lexer.hs
index bb19ea1..66a3f64 100644
--- a/src/Curry/Syntax/Lexer.hs
+++ b/src/Curry/Syntax/Lexer.hs
@@ -131,7 +131,6 @@ data Category
-- special operators
| SymDot -- .
| SymMinus -- -
- | SymMinusDot -- -.
-- special symbols
| SymStar -- *
@@ -239,7 +238,6 @@ instance Show Token where
showsPrec _ (Token Tilde _) = showsEscaped "~"
showsPrec _ (Token SymDot _) = showsSpecialOperator "."
showsPrec _ (Token SymMinus _) = showsSpecialOperator "-"
- showsPrec _ (Token SymMinusDot _) = showsSpecialOperator "-."
showsPrec _ (Token SymStar _) = showsEscaped "*"
showsPrec _ (Token KW_case _) = showsEscaped "case"
showsPrec _ (Token KW_class _) = showsEscaped "class"
@@ -354,7 +352,6 @@ reservedSpecialOps :: Map.Map String Category
reservedSpecialOps = Map.union reservedOps $ Map.fromList
[ ("." , SymDot )
, ("-" , SymMinus )
- , ("-.", SymMinusDot)
, ("*" , SymStar )
]
diff --git a/src/Curry/Syntax/Parser.hs b/src/Curry/Syntax/Parser.hs
index 909a163..e1327ba 100644
--- a/src/Curry/Syntax/Parser.hs
+++ b/src/Curry/Syntax/Parser.hs
@@ -26,7 +26,7 @@ import Curry.Base.LLParseComb
import Curry.Syntax.Extension
import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)
import Curry.Syntax.Type
-import Curry.Syntax.Utils (mkInt, addSrcRefs)
+import Curry.Syntax.Utils (addSrcRefs)
-- |Parse a 'Module'
parseSource :: FilePath -> String -> CYM (Module ())
@@ -512,7 +512,7 @@ listType = ListType <$> type0 `opt` (ConstructorType qListId)
-- | '"' <escaped string> '"'
literal :: Parser a Token Literal
literal = mk Char <$> char
- <|> mkInt <$> integer
+ <|> mk Int <$> integer
<|> mk Float <$> float
<|> mk String <$> string
@@ -533,8 +533,7 @@ pattern0 = pattern1 `chainr1` (flip (InfixPattern ()) <$> gconop)
pattern1 :: Parser a Token (Pattern ())
pattern1 = varId <**> identPattern' -- unqualified
<|> qConId <\> varId <**> constrPattern -- qualified
- <|> minus <**> negNum
- <|> fminus <**> negFloat
+ <|> minus <-*> negNum
<|> leftParen <-*> parenPattern'
<|> pattern2 <\> qConId <\> leftParen
where
@@ -546,14 +545,12 @@ pattern1 = varId <**> identPattern' -- unqualified
mkConsPattern f ts c = ConstructorPattern () (f c) ts
- parenPattern' = minus <**> minusPattern negNum
- <|> fminus <**> minusPattern negFloat
+ parenPattern' = minus <**> minusPattern
<|> gconPattern
- <|> funSym <\> minus <\> fminus <*-> rightParen
- <**> identPattern'
- <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen
- minusPattern p = rightParen <-*> identPattern' -- (-) and (-.) as variables
- <|> parenMinusPattern p <*-> rightParen
+ <|> funSym <\> minus <*-> rightParen <**> identPattern'
+ <|> parenTuplePattern <\> minus <*-> rightParen
+ minusPattern = rightParen <-*> identPattern'
+ <|> parenMinusPattern <*-> rightParen
gconPattern = ConstructorPattern () <$> gconId <*-> rightParen
<*> many pattern2
@@ -579,14 +576,12 @@ identPattern = varId <**> optAsRecPattern -- unqualified
parenPattern :: Parser a Token (Pattern ())
parenPattern = leftParen <-*> parenPattern'
where
- parenPattern' = minus <**> minusPattern negNum
- <|> fminus <**> minusPattern negFloat
+ parenPattern' = minus <**> minusPattern
<|> flip (ConstructorPattern ()) [] <$> gconId <*-> rightParen
- <|> funSym <\> minus <\> fminus <*-> rightParen
- <**> optAsRecPattern
- <|> parenTuplePattern <\> minus <\> fminus <*-> rightParen
- minusPattern p = rightParen <-*> optAsRecPattern
- <|> parenMinusPattern p <*-> rightParen
+ <|> funSym <\> minus <*-> rightParen <**> optAsRecPattern
+ <|> parenTuplePattern <\> minus <*-> rightParen
+ minusPattern = rightParen <-*> optAsRecPattern
+ <|> parenMinusPattern <*-> rightParen
-- listPattern ::= '[' pattern0s ']'
-- pattern0s ::= {- empty -}
@@ -613,13 +608,9 @@ optRecPattern = mkRecPattern <$> fields pattern0 `opt` mkConPattern
gconId :: Parser a Token QualIdent
gconId = colon <|> tupleCommas
-negNum :: Parser a Token (Ident -> Pattern ())
-negNum = flip (NegativePattern ())
- <$> (mkInt <$> integer <|> mk Float <$> float)
-
-negFloat :: Parser a Token (Ident -> Pattern ())
-negFloat = flip (NegativePattern ()) . mk Float
- <$> (fromIntegral <$> integer <|> float)
+negNum :: Parser a Token (Pattern ())
+negNum = mk (NegativePattern ())
+ <$> (mk Int <$> integer <|> mk Float <$> float)
optAsRecPattern :: Parser a Token (Ident -> Pattern ())
optAsRecPattern = flip AsPattern <$-> token At <*> pattern2
@@ -638,8 +629,7 @@ optTuplePattern = tuple <$> many1 (comma <-*> pattern0)
where tuple ts t = mk TuplePattern (t:ts)
parenMinusPattern :: Parser a Token (Ident -> Pattern ())
- -> Parser a Token (Ident -> Pattern ())
-parenMinusPattern p = p <.> optInfixPattern <.> optTuplePattern
+parenMinusPattern = const <$> negNum <.> optInfixPattern <.> optTuplePattern
parenTuplePattern :: Parser a Token (Pattern ())
parenTuplePattern = pattern0 <**> optTuplePattern
@@ -670,7 +660,7 @@ expr0 = expr1 `chainr1` (flip InfixApply <$> infixOp)
-- expr1 ::= - expr2 | -. expr2 | expr2
expr1 :: Parser a Token (Expression ())
-expr1 = UnaryMinus <$> (minus <|> fminus) <*> expr2
+expr1 = mk UnaryMinus <$-> minus <*> expr2
<|> expr2
-- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3
@@ -701,12 +691,12 @@ variable = qFunId <**> optRecord
parenExpr :: Parser a Token (Expression ())
parenExpr = parens pExpr
where
- pExpr = (minus <|> fminus) <**> minusOrTuple
+ pExpr = minus <**> minusOrTuple
<|> Constructor () <$> tupleCommas
- <|> leftSectionOrTuple <\> minus <\> fminus
- <|> opOrRightSection <\> minus <\> fminus
+ <|> leftSectionOrTuple <\> minus
+ <|> opOrRightSection <\> minus
`opt` mk Tuple []
- minusOrTuple = flip UnaryMinus <$> expr1 <.> infixOrTuple
+ minusOrTuple = const . mk UnaryMinus <$> expr1 <.> infixOrTuple
`opt` Variable () . qualify
leftSectionOrTuple = expr1 <**> infixOrTuple
infixOrTuple = ($ id) <$> infixOrTuple'
@@ -945,7 +935,7 @@ qIdent = qualify <$> ident
sym :: Parser a Token Ident
sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*>
- tokens [Sym, SymDot, SymMinus, SymMinusDot, SymStar]
+ tokens [Sym, SymDot, SymMinus, SymStar]
qSym :: Parser a Token QualIdent
qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym
@@ -958,9 +948,6 @@ colon = (\ p -> qualify $ addPositionIdent p consId) <$> tokenPos Colon
minus :: Parser a Token Ident
minus = (\ p -> addPositionIdent p minusId) <$> tokenPos SymMinus
-fminus :: Parser a Token Ident
-fminus = (\ p -> addPositionIdent p fminusId) <$> tokenPos SymMinusDot
-
tupleCommas :: Parser a Token QualIdent
tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length)
<$> position <*> many1 comma
diff --git a/src/Curry/Syntax/Pretty.hs b/src/Curry/Syntax/Pretty.hs
index 8ab0ae1..b724c1e 100644
--- a/src/Curry/Syntax/Pretty.hs
+++ b/src/Curry/Syntax/Pretty.hs
@@ -315,8 +315,8 @@ ppPattern p (LiteralPattern _ l) = parenIf (p > 1 && isNegative l) (ppLiteral l)
isNegative (Int _ i) = i < 0
isNegative (Float _ f) = f < 0.0
isNegative (String _ _) = False
-ppPattern p (NegativePattern _ op l) = parenIf (p > 1)
- (ppInfixOp op <> ppLiteral l)
+ppPattern p (NegativePattern _ _ l) = parenIf (p > 1)
+ (ppInfixOp minusId <> ppLiteral l)
ppPattern _ (VariablePattern _ v) = ppIdent v
ppPattern p (ConstructorPattern _ c ts) = parenIf (p > 1 && not (null ts))
(ppQIdent c <+> fsep (map (ppPattern 2) ts))
@@ -366,7 +366,8 @@ ppExpr _ (EnumFromTo e1 e2) =
ppExpr _ (EnumFromThenTo e1 e2 e3) =
brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2
<+> text ".." <+> ppExpr 0 e3)
-ppExpr p (UnaryMinus op e) = parenIf (p > 1) (ppInfixOp op <> ppExpr 1 e)
+ppExpr p (UnaryMinus _ e) =
+ parenIf (p > 1) (ppInfixOp minusId <> ppExpr 1 e)
ppExpr p (Apply e1 e2) =
parenIf (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])
ppExpr p (InfixApply e1 op e2) =
diff --git a/src/Curry/Syntax/ShowModule.hs b/src/Curry/Syntax/ShowModule.hs
index f928f68..9489889 100644
--- a/src/Curry/Syntax/ShowModule.hs
+++ b/src/Curry/Syntax/ShowModule.hs
@@ -351,9 +351,8 @@ showsLiteral (Char _ c)
= showsString "(Char "
. shows c
. showsString ")"
-showsLiteral (Int ident n)
+showsLiteral (Int _ n)
= showsString "(Int "
- . showsIdent ident . space
. shows n
. showsString ")"
showsLiteral (Float _ x)
@@ -370,9 +369,8 @@ showsConsTerm (LiteralPattern _ lit)
= showsString "(LiteralPattern "
. showsLiteral lit
. showsString ")"
-showsConsTerm (NegativePattern _ ident lit)
+showsConsTerm (NegativePattern _ _ lit)
= showsString "(NegativePattern "
- . showsIdent ident . space
. showsLiteral lit
. showsString ")"
showsConsTerm (VariablePattern _ ident)
@@ -483,9 +481,8 @@ showsExpression (EnumFromThenTo exp1 exp2 exp3)
. showsExpression exp2 . space
. showsExpression exp3
. showsString ")"
-showsExpression (UnaryMinus ident expr)
+showsExpression (UnaryMinus _ expr)
= showsString "(UnaryMinus "
- . showsIdent ident . space
. showsExpression expr
. showsString ")"
showsExpression (Apply exp1 exp2)
diff --git a/src/Curry/Syntax/Type.hs b/src/Curry/Syntax/Type.hs
index 4577767..799f152 100644
--- a/src/Curry/Syntax/Type.hs
+++ b/src/Curry/Syntax/Type.hs
@@ -251,14 +251,9 @@ data CondExpr a = CondExpr Position (Expression a) (Expression a)
deriving (Eq, Read, Show, Data, Typeable)
-- |Literal
--- The 'Ident' argument of an @Int@ literal is used for supporting ad-hoc
--- polymorphism on integer numbers. An integer literal can be used either as
--- an integer number or as a floating-point number depending on its context.
--- The compiler uses the identifier of the @Int@ literal for maintaining its
--- type.
data Literal
= Char SrcRef Char
- | Int Ident Integer
+ | Int SrcRef Integer
| Float SrcRef Double
| String SrcRef String
deriving (Eq, Read, Show, Data, Typeable)
@@ -266,7 +261,7 @@ data Literal
-- |Constructor term (used for patterns)
data Pattern a
= LiteralPattern a Literal
- | NegativePattern a Ident Literal
+ | NegativePattern a SrcRef Literal
| VariablePattern a Ident
| ConstructorPattern a QualIdent [Pattern a]
| InfixPattern a (Pattern a) QualIdent (Pattern a)
@@ -296,7 +291,7 @@ data Expression a
| EnumFromThen (Expression a) (Expression a)
| EnumFromTo (Expression a) (Expression a)
| EnumFromThenTo (Expression a) (Expression a) (Expression a)
- | UnaryMinus Ident (Expression a)
+ | UnaryMinus SrcRef (Expression a)
| Apply (Expression a) (Expression a)
| InfixApply (Expression a) (InfixOp a) (Expression a)
| LeftSection (Expression a) (InfixOp a)
@@ -388,7 +383,7 @@ instance Functor CondExpr where
instance Functor Pattern where
fmap f (LiteralPattern a l) = LiteralPattern (f a) l
- fmap f (NegativePattern a i l) = NegativePattern (f a) i l
+ fmap f (NegativePattern a ref l) = NegativePattern (f a) ref l
fmap f (VariablePattern a v) = VariablePattern (f a) v
fmap f (ConstructorPattern a c ts) =
ConstructorPattern (f a) c (map (fmap f) ts)
@@ -422,7 +417,7 @@ instance Functor Expression where
fmap f (EnumFromTo e1 e2) = EnumFromTo (fmap f e1) (fmap f e2)
fmap f (EnumFromThenTo e1 e2 e3) =
EnumFromThenTo (fmap f e1) (fmap f e2) (fmap f e3)
- fmap f (UnaryMinus i e) = UnaryMinus i (fmap f e)
+ fmap f (UnaryMinus ref e) = UnaryMinus ref (fmap f e)
fmap f (Apply e1 e2) = Apply (fmap f e1) (fmap f e2)
fmap f (InfixApply e1 op e2) =
InfixApply (fmap f e1) (fmap f op) (fmap f e2)
@@ -457,8 +452,8 @@ instance Functor Goal where
fmap f (Goal p e ds) = Goal p (fmap f e) (map (fmap f) ds)
instance SrcRefOf (Pattern a) where
- srcRefOf (LiteralPattern _ l) = srcRefOf l
- srcRefOf (NegativePattern _ i _) = srcRefOf i
+ srcRefOf (LiteralPattern _ l) = srcRefOf l
+ srcRefOf (NegativePattern _ s _) = s
srcRefOf (VariablePattern _ i) = srcRefOf i
srcRefOf (ConstructorPattern _ i _) = srcRefOf i
srcRefOf (InfixPattern _ _ i _) = srcRefOf i
@@ -474,6 +469,6 @@ instance SrcRefOf (Pattern a) where
instance SrcRefOf Literal where
srcRefOf (Char s _) = s
- srcRefOf (Int i _) = srcRefOf i
+ srcRefOf (Int s _) = s
srcRefOf (Float s _) = s
srcRefOf (String s _) = s
diff --git a/src/Curry/Syntax/Utils.hs b/src/Curry/Syntax/Utils.hs
index 033a740..a2edbea 100644
--- a/src/Curry/Syntax/Utils.hs
+++ b/src/Curry/Syntax/Utils.hs
@@ -22,7 +22,7 @@ module Curry.Syntax.Utils
, isClassDecl, isTypeOrClassDecl, isInstanceDecl
, isFunctionDecl, isExternalDecl, patchModuleId
, isVariableType, isSimpleType
- , flatLhs, mkInt, fieldLabel, fieldTerm, field2Tuple, opName
+ , flatLhs, fieldLabel, fieldTerm, field2Tuple, opName
, addSrcRefs
, constrId, nconstrId
, recordLabels, nrecordLabels
@@ -134,10 +134,6 @@ flatLhs lhs = flat lhs []
flat (OpLhs t1 op t2) ts' = (op, t1 : t2 : ts')
flat (ApLhs lhs' ts) ts' = flat lhs' (ts ++ ts')
--- |Construct an Integer literal
-mkInt :: Integer -> Literal
-mkInt i = mk (\r -> Int (addPositionIdent (AST r) anonId) i)
-
-- |Select the label of a field
fieldLabel :: Field a -> QualIdent
fieldLabel (Field _ l _) = l
--
GitLab