...
 
Commits (2)
  • Fredrik Wieczerkowski's avatar
  • Fredrik Wieczerkowski's avatar
    Re-apply 'explicit-layout-info' · a4c373d8
    Fredrik Wieczerkowski authored
    - (WIP) Include information about Layout in SpanInfo
    - Add LayoutInfo while parsing, but don't print it on file export (yet)
    - Parse QualTypeExprs again
    - Add Binary instances for AST (WIP)
    - Fix parsing issues with empty where clauses (WIP)
    - Do not insert a virtual semicolon when it is followed by a where
    - Fixes failure on where-blocks that are immediately after do-blocks with the same indentation
    - Add even more binary instances
    - Properly add already available test cases
    - Use Pretty class from Curry.Base.Pretty (WIP)
    - Merge remote-tracking branch 'origin/data-class' into version3
    - Fix haddoc comment
    - Fix SpanInfos for Idents and where-clauses
    - Merge branch 'explicit-layout-info'
    - Fix remaining compilation issues
    Co-Authored-By: default avatarKai Prott <kai.prott@hotmail.de>
    a4c373d8
......@@ -4,10 +4,7 @@ Change log for curry-base
Version (1.2.0) (WIP)
=====================
* Added support for the `ExplicitForAll` language extension
* Added support for the `RankNTypes` language extension
* Added support for latex-style in literate curry
* Removed support for existential quantified type variables in data type declarations
Version (1.1.0)
===============
......
......@@ -23,7 +23,7 @@ module Curry.AbstractCurry.Type
( CurryProg (..), MName, QName, CVisibility (..), CTVarIName
, CDefaultDecl (..), CClassDecl (..), CInstanceDecl (..)
, CTypeDecl (..), CConsDecl (..), CFieldDecl (..)
, CConstraint, CContext (..), CTypeExpr (..)
, CConstraint, CContext (..), CTypeExpr (..), CQualTypeExpr (..)
, COpDecl (..), CFixity (..), Arity, CFuncDecl (..), CRhs (..), CRule (..)
, CLocalDecl (..), CVarIName, CExpr (..), CCaseType (..), CStatement (..)
, CPattern (..), CLiteral (..), CField, version
......@@ -35,7 +35,7 @@ module Curry.AbstractCurry.Type
-- |Current version of AbstractCurry
version :: String
version = "AbstractCurry 2.1"
version = "AbstractCurry 2.0"
-- |A module name.
type MName = String
......@@ -147,7 +147,6 @@ data CTypeDecl
-- the name written in the source program).
type CTVarIName = (Int, String)
-- TODO: Remove context and existential quantified type variables.
-- |A constructor declaration consists of a list of existentially
-- quantified type variables, a context, the name of the constructor
-- and a list of the argument types of the constructor.
......@@ -181,10 +180,10 @@ data CTypeExpr
| CTCons QName
-- |Type application
| CTApply CTypeExpr CTypeExpr
-- |A type with a type context
| CContextType CContext CTypeExpr
-- |Forall type
| CForallType [CTVarIName] CTypeExpr
deriving (Eq, Read, Show)
-- |Qualified type expression.
data CQualTypeExpr = CQualType CContext CTypeExpr
deriving (Eq, Read, Show)
-- |Labeled record fields
......@@ -228,7 +227,7 @@ type Arity = Int
-- a list of rules.
-- If the list of rules is empty, the function is considered
-- to be externally defined.
data CFuncDecl = CFunc QName Arity CVisibility CTypeExpr [CRule]
data CFuncDecl = CFunc QName Arity CVisibility CQualTypeExpr [CRule]
deriving (Eq, Read, Show)
-- |The general form of a function rule. It consists of a list of patterns
......@@ -296,7 +295,7 @@ data CExpr
-- |case expression
| CCase CCaseType CExpr [(CPattern, CRhs)]
-- |typed expression
| CTyped CExpr CTypeExpr
| CTyped CExpr CQualTypeExpr
-- |record construction (extended Curry)
| CRecConstr QName [CField CExpr]
-- |record update (extended Curry)
......
......@@ -109,8 +109,8 @@ getSrcInfoPoints a = case getSpanInfo a of
setSrcInfoPoints :: HasSpanInfo a => [Span] -> a -> a
setSrcInfoPoints inf a = case getSpanInfo a of
NoSpanInfo -> setSpanInfo (SpanInfo NoSpan inf) a
SpanInfo s _ -> setSpanInfo (SpanInfo s inf) a
NoSpanInfo -> setSpanInfo (SpanInfo NoSpan inf) a
SpanInfo s _ -> setSpanInfo (SpanInfo s inf) a
getStartPosition :: HasSpanInfo a => a -> Position
getStartPosition a = case getSrcSpan a of
......
......@@ -22,7 +22,7 @@ import Control.Monad
import Curry.FlatCurry.Typeable
import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex
, TypeDecl (..), Kind (..), OpDecl (..), Fixity (..)
, TypeDecl (..), OpDecl (..), Fixity (..)
, TypeExpr (..), ConsDecl (..), NewConsDecl (..)
, Literal (..), CombType (..), CaseType (..)
)
......
......@@ -370,7 +370,7 @@ tConsArgs _ = error $ "Curry.FlatCurry.Goodies.tConsArgs: " ++
trTypeExpr :: (TVarIndex -> a) ->
(QName -> [a] -> a) ->
(a -> a -> a) ->
([(TVarIndex, Kind)] -> a -> a) -> TypeExpr -> a
([TVarIndex] -> a -> a) -> TypeExpr -> a
trTypeExpr tvar _ _ _ (TVar n) = tvar n
trTypeExpr tvar tcons functype foralltype (TCons name args)
= tcons name (map (trTypeExpr tvar tcons functype foralltype) args)
......@@ -417,7 +417,7 @@ updFuncTypes :: (TypeExpr -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
updFuncTypes functype = trTypeExpr TVar TCons functype ForallType
-- |update all forall types
updForallTypes :: ([(TVarIndex, Kind)] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
updForallTypes :: ([TVarIndex] -> TypeExpr -> TypeExpr) -> TypeExpr -> TypeExpr
updForallTypes = trTypeExpr TVar TCons FuncType
-- Auxiliary Functions
......@@ -442,7 +442,7 @@ resultType (ForallType ns t) = ForallType ns t
-- |get indexes of all type variables
allVarsInTypeExpr :: TypeExpr -> [TVarIndex]
allVarsInTypeExpr = trTypeExpr (:[]) (const concat) (++) ((++) . map fst)
allVarsInTypeExpr = trTypeExpr (:[]) (const concat) (++) (++)
-- |yield the list of all contained type constructors
allTypeCons :: TypeExpr -> [QName]
......
......@@ -100,14 +100,11 @@ instance Pretty TypeExpr where
| null vs = pPrintPrec p ty
| otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty
-- |pretty-print explicitly quantified type variables (without kinds)
ppQuantifiedVars :: [(TVarIndex, Kind)] -> Doc
-- |pretty-print explicitly quantified type variables
ppQuantifiedVars :: [TVarIndex] -> Doc
ppQuantifiedVars vs
| null vs = empty
| otherwise = text "forall" <+> hsep (map ppTVar vs) <> char '.'
ppTVar :: (TVarIndex, Kind) -> Doc
ppTVar (i, _) = ppTVarIndex i
| otherwise = text "forall" <+> hsep (map ppTVarIndex vs) <+> char '.'
-- |pretty-print a type variable
ppTVarIndex :: TVarIndex -> Doc
......
......@@ -18,7 +18,7 @@ module Curry.FlatCurry.Type
( -- * Representation of qualified names and (type) variables
QName, VarIndex, TVarIndex
-- * Data types for FlatCurry
, Visibility (..), Prog (..), TypeDecl (..), TypeExpr (..), Kind (..)
, Visibility (..), Prog (..), TypeDecl (..), TypeExpr (..)
, ConsDecl (..), NewConsDecl(..), OpDecl (..), Fixity (..)
, FuncDecl (..), Rule (..), Expr (..), Literal (..)
, CombType (..), CaseType (..), BranchExpr (..), Pattern (..)
......@@ -118,20 +118,12 @@ data NewConsDecl = NewCons QName Visibility TypeExpr
-- @Int@, @Float@, @Bool@, @Char@, @IO@, @Success@,
-- @()@ (unit type), @(,...,)@ (tuple types), @[]@ (list type)
data TypeExpr
= TVar TVarIndex -- ^ type variable
| FuncType TypeExpr TypeExpr -- ^ function type @t1 -> t2@
| TCons QName [TypeExpr] -- ^ type constructor application
| ForallType [(TVarIndex, Kind)] TypeExpr -- ^ forall type
= TVar TVarIndex -- ^ type variable
| FuncType TypeExpr TypeExpr -- ^ function type @t1 -> t2@
| TCons QName [TypeExpr] -- ^ type constructor application
| ForallType [TVarIndex] TypeExpr -- ^ forall type
deriving (Eq, Read, Show)
-- |Kinds.
--
-- A kind is either * or k_1 -> k_2 where k_1 and k_2 are kinds.
data Kind
= KStar -- ^ star kind
| KArrow Kind Kind -- ^ arrow kind
deriving (Eq, Ord, Read, Show)
-- |Operator declarations.
--
-- An operator declaration @fix p n@ in Curry corresponds to the
......@@ -395,16 +387,6 @@ instance Binary TypeExpr where
3 -> liftM2 ForallType get get
_ -> fail "Invalid encoding for TypeExpr"
instance Binary Kind where
put KStar = putWord8 0
put (KArrow k1 k2) = putWord8 1 >> put k1 >> put k2
get = do
x <- getWord8
case x of
0 -> return KStar
1 -> liftM2 KArrow get get
_ -> fail "Invalid encoding for Kind"
instance Binary OpDecl where
put (Op qid fix pr) = put qid >> put fix >> put pr
get = liftM3 Op get get get
......
......@@ -27,7 +27,7 @@ import Control.Monad
import Curry.FlatCurry.Typeable
import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex
, TypeDecl (..), Kind (..), OpDecl (..), Fixity (..)
, TypeDecl (..), OpDecl (..), Fixity (..)
, TypeExpr (..), ConsDecl (..), NewConsDecl (..)
, Literal (..), CombType (..), CaseType (..)
)
......
......@@ -56,8 +56,6 @@ instance Binary KnownExtension where
put FunctionalPatterns = putWord8 2
put NegativeLiterals = putWord8 3
put NoImplicitPrelude = putWord8 4
put RankNTypes = putWord8 5
put ExplicitForAll = putWord8 6
get = do
x <- getWord8
......@@ -67,19 +65,16 @@ instance Binary KnownExtension where
2 -> return FunctionalPatterns
3 -> return NegativeLiterals
4 -> return NoImplicitPrelude
5 -> return RankNTypes
6 -> return ExplicitForAll
_ -> fail "Invalid encoding for KnownExtension"
-- |Known language extensions of Curry.
data KnownExtension
= AnonFreeVars -- ^ anonymous free variables
| CPP -- ^ C preprocessor
| ExistentialQuantification -- ^ existential quantification
| FunctionalPatterns -- ^ functional patterns
| NegativeLiterals -- ^ negative literals
| NoImplicitPrelude -- ^ no implicit import of the prelude
| RankNTypes -- ^ arbitrary-rank polymorphism
| ExplicitForAll -- ^ explicit forall
deriving (Eq, Read, Show, Enum, Bounded)
-- |Classifies a 'String' as an 'Extension'
......
......@@ -99,12 +99,12 @@ instance Equiv IDecl where
_ =~= _ = False
instance Equiv ConstrDecl where
ConstrDecl _ c1 tys1 =~= ConstrDecl _ c2 tys2
= c1 == c2 && tys1 == tys2
ConOpDecl _ ty11 op1 ty12 =~= ConOpDecl _ ty21 op2 ty22
= op1 == op2 && ty11 == ty21 && ty12 == ty22
RecordDecl _ c1 fs1 =~= RecordDecl _ c2 fs2
= c1 == c2 && fs1 `eqvList` fs2
ConstrDecl _ evs1 cx1 c1 tys1 =~= ConstrDecl _ evs2 cx2 c2 tys2
= c1 == c2 && evs1 == evs2 && cx1 == cx2 && tys1 == tys2
ConOpDecl _ evs1 cx1 ty11 op1 ty12 =~= ConOpDecl _ evs2 cx2 ty21 op2 ty22
= op1 == op2 && evs1 == evs2 && cx1 == cx2 && ty11 == ty21 && ty12 == ty22
RecordDecl _ evs1 cx1 c1 fs1 =~= RecordDecl _ evs2 cx2 c2 fs2
= c1 == c2 && evs1 == evs2 && cx1 == cx2 && fs1 `eqvList` fs2
_ =~= _ = False
instance Equiv FieldDecl where
......@@ -159,10 +159,10 @@ instance FixInterface IDecl where
fix _ d = d
instance FixInterface ConstrDecl where
fix tcs (ConstrDecl p c tys) = ConstrDecl p c (fix tcs tys)
fix tcs (ConOpDecl p ty1 op ty2) = ConOpDecl p (fix tcs ty1)
op (fix tcs ty2)
fix tcs (RecordDecl p c fs) = RecordDecl p c (fix tcs fs)
fix tcs (ConstrDecl p evs cx c tys) = ConstrDecl p evs cx c (fix tcs tys)
fix tcs (ConOpDecl p evs cx ty1 op ty2) = ConOpDecl p evs cx (fix tcs ty1)
op (fix tcs ty2)
fix tcs (RecordDecl p evs cx c fs) = RecordDecl p evs cx c (fix tcs fs)
instance FixInterface FieldDecl where
fix tcs (FieldDecl p ls ty) = FieldDecl p ls (fix tcs ty)
......@@ -174,6 +174,9 @@ instance FixInterface NewConstrDecl where
instance FixInterface IMethodDecl where
fix tcs (IMethodDecl p f a qty) = IMethodDecl p f a (fix tcs qty)
instance FixInterface QualTypeExpr where
fix tcs (QualTypeExpr spi cx ty) = QualTypeExpr spi (fix tcs cx) (fix tcs ty)
instance FixInterface Constraint where
fix tcs (Constraint spi qcls ty) = Constraint spi qcls (fix tcs ty)
......@@ -191,7 +194,6 @@ instance FixInterface TypeExpr where
fix tcs (ListType spi ty) = ListType spi (fix tcs ty)
fix tcs (ArrowType spi ty1 ty2) = ArrowType spi (fix tcs ty1) (fix tcs ty2)
fix tcs (ParenType spi ty) = ParenType spi (fix tcs ty)
fix tcs (ContextType spi cx ty) = ContextType spi (fix tcs cx) (fix tcs ty)
fix tcs (ForallType spi vs ty) = ForallType spi vs (fix tcs ty)
typeConstructors :: [IDecl] -> [Ident]
......
......@@ -242,7 +242,7 @@ iHiddenPragma = token PragmaHiding
-- |Parser for an interface function declaration
iFunctionDecl :: Parser a Token IDecl
iFunctionDecl = IFunctionDecl <$> position <*> qfun <*> option iMethodPragma
<*> arity <*-> token DoubleColon <*> type0
<*> arity <*-> token DoubleColon <*> qualType
-- |Parser for an interface method pragma
iMethodPragma :: Parser a Token Ident
......@@ -268,7 +268,7 @@ iClassDecl = (\(sp, _, cx, (qcls, k), tv) ->
-- |Parser for an interface method declaration
iMethod :: Parser a Token IMethodDecl
iMethod = IMethodDecl <$> position
<*> fun <*> option int <*-> token DoubleColon <*> type0
<*> fun <*> option int <*-> token DoubleColon <*> qualType
-- |Parser for an interface hiding pragma
iClassHidden :: Parser a Token [Ident]
......@@ -340,7 +340,8 @@ typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category
typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar
constrDecl :: Parser a Token ConstrDecl
constrDecl = spanPosition <**> constr
constrDecl = spanPosition <**> (existVars
<**> optContext (\cx sp f -> f sp cx) constr)
where
constr = conId <**> identDecl
<|> tokenSpan LeftParen <**> parenDecl
......@@ -356,16 +357,16 @@ constrDecl = spanPosition <**> constr
conType f tys c = f $ foldl mkApply (mkConstructorType $ qualify c) tys
mkApply t1 t2 = updateEndPos $ ApplyType (fromSrcSpan (getSrcSpan t1)) t1 t2
mkConstructorType qid = ConstructorType (fromSrcSpan (getSrcSpan qid)) qid
conDecl tys c sp = updateEndPos $
ConstrDecl (spanInfo sp []) c tys
conOpDecl op ty2 ty1 sp = updateEndPos $
ConOpDecl (spanInfo sp []) ty1 op ty2
conOpDeclParen op ty2 sp1 ty1 sp2 sp5 = updateEndPos $
ConOpDecl (spanInfo sp5 [sp2, sp1]) ty1 op ty2
conOpDeclPrefix op sp1 ty1 ty2 sp2 sp3 = updateEndPos $
ConOpDecl (spanInfo sp3 [sp2, sp1]) ty1 op ty2
recDecl ((fs, ss), sp1, sp2) c sp3 = updateEndPos $
RecordDecl (spanInfo sp3 (sp1 : ss ++ [sp2])) c fs
conDecl tys c ss1 cx (ss2, tvs) sp = updateEndPos $
ConstrDecl (spanInfo sp (ss2 ++ ss1)) tvs cx c tys
conOpDecl op ty2 ty1 ss1 cx (ss2, tvs) sp = updateEndPos $
ConOpDecl (spanInfo sp (ss2 ++ ss1)) tvs cx ty1 op ty2
conOpDeclParen op ty2 sp1 ty1 sp2 ss1 cx (ss2, tvs) sp5 = updateEndPos $
ConOpDecl (spanInfo sp5 (ss2 ++ ss1 ++ [sp2, sp1])) tvs cx ty1 op ty2
conOpDeclPrefix op sp1 ty1 ty2 sp2 ss1 cx (ss2, tvs) sp3 = updateEndPos $
ConOpDecl (spanInfo sp3 (ss2 ++ ss1 ++ [sp2,sp1])) tvs cx ty1 op ty2
recDecl ((fs, ss), sp1, sp2) c ss1 cx (ss2, tvs) sp3 = updateEndPos $
RecordDecl (spanInfo sp3 (ss2 ++ ss1 ++ (sp1: (ss ++ [sp2])))) tvs cx c fs
fieldDecl :: Parser a Token FieldDecl
fieldDecl = mkFieldDecl <$> spanPosition <*> labels
......@@ -394,6 +395,13 @@ deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], [])
<*> (qtycls `sepBySp` comma)
<*> tokenSpan RightParen)
-- Parsing of existential variables
existVars :: Parser a Token ([Span], [Ident])
existVars = mk <$> tokenSpan Id_forall <*> many1 tyvar <*>
tokenSpan SymDot
`opt` ([],[])
where mk sp1 a sp2 = ([sp1,sp2], a)
functionDecl :: Parser a Token (Decl ())
functionDecl = spanPosition <**> decl
where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule
......@@ -411,7 +419,7 @@ funListDecl = typeSig <|> mkExtFun <$> tokenSpan KW_external
typeSig :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())
typeSig = sig <$> tokenSpan DoubleColon <*> type0
typeSig = sig <$> tokenSpan DoubleColon <*> qualType
where sig sp1 qty (vs,ss) sp2 = updateEndPos $
TypeSig (spanInfo sp2 (ss++[sp1])) vs qty
......@@ -618,32 +626,16 @@ kind1 = Star <$-> token SymStar
-- Types
-- ---------------------------------------------------------------------------
-- qualType ::= [context '=>'] arrowType
qualType :: Parser a Token TypeExpr
qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) arrowType
where
mkQualTypeExpr _ ([], [], ty) = ty
mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $
ContextType (spanInfo sp ss) cx ty
-- forallVars ::= 'forall' (tyvar {tyvar}) '.'
forallVars :: Parser a Token ([Span], [Ident])
forallVars = mk <$> tokenSpan Id_forall <*> many1 tyvar <*> tokenSpan SymDot
where mk sp1 tvs sp2 = ([sp1, sp2], tvs)
-- qualType ::= [context '=>'] type0
qualType :: Parser a Token QualTypeExpr
qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) type0
where mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $
QualTypeExpr (spanInfo sp ss) cx ty
-- type0 ::= {forallVars} qualType
-- type0 ::= type1 ['->' type0]
type0 :: Parser a Token TypeExpr
type0 = mk <$> many forallVars <*> qualType
where
mk [] te = te
mk ((sps, tvs):xs) te = updateEndPos $
ForallType (spanInfo (head sps) sps) tvs (mk xs te)
-- arrowType ::= type1 ['->' type0]
arrowType :: Parser a Token TypeExpr
arrowType =
type1 <**> ((mkArrowType <$> tokenSpan RightArrow <*> type0) `opt` id)
where mkArrowType sp ty2 ty1 = updateEndPos $
type0 = type1 `chainr1` (mkArrowType <$> tokenSpan RightArrow)
where mkArrowType sp ty1 ty2 = updateEndPos $
ArrowType (spanInfo (getSrcSpan ty1) [sp]) ty1 ty2
-- type1 ::= [type1] type2
......@@ -905,7 +897,7 @@ condExpr eq = mkCondExpr <$> spanPosition <*-> bar <*> expr0
-- expr ::= expr0 [ '::' type0 ]
expr :: Parser a Token (Expression ())
expr = expr0 <??> (mkTyped <$> tokenSpan DoubleColon <*> type0)
expr = expr0 <??> (mkTyped <$> tokenSpan DoubleColon <*> qualType)
where mkTyped sp qty e = updateEndPos $ setSrcSpan (getSrcSpan e) $
Typed (fromSrcInfoPoints [sp]) e qty
......@@ -976,7 +968,7 @@ parenExpr = fmap updateSpanWithBrackets (parensSp pExpr)
<|> (.) <$> (optType <.> tupleExpr)
leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')
`opt` leftSection
optType = mkTyped <$> tokenSpan DoubleColon <*> type0 `opt` id
optType = mkTyped <$> tokenSpan DoubleColon <*> qualType `opt` id
tupleExpr = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> expr)
`opt` Paren NoSpanInfo
opOrRightSection = qFunSym <**> optRightSection
......@@ -1378,6 +1370,9 @@ parensSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<*> p
<*> tokenSpan RightParen
backquotes :: Parser a Token b -> Parser a Token b
backquotes p = between backquote p expectBackquote
backquotesSp :: Parser a Token b -> Parser a Token (b, Span, Span)
backquotesSp p = (\sp1 b sp2 -> (b, sp1, sp2))
<$> tokenSpan Backquote
......
......@@ -148,12 +148,18 @@ ppTypeDeclLhs :: String -> Ident -> [Ident] -> Doc
ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs)
instance Pretty ConstrDecl where
pPrint (ConstrDecl _ c tys) =
sep [ ppIdent c <+> fsep (map (pPrintPrec 2) tys) ]
pPrint (ConOpDecl _ ty1 op ty2) =
sep [ pPrintPrec 1 ty1, ppInfixOp op <+> pPrintPrec 1 ty2 ]
pPrint (RecordDecl _ c fs) =
sep [ ppIdent c <+> record (list (map pPrint fs)) ]
pPrint (ConstrDecl _ tvs cx c tys) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, ppIdent c <+> fsep (map (pPrintPrec 2) tys)
]
pPrint (ConOpDecl _ tvs cx ty1 op ty2) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, pPrintPrec 1 ty1, ppInfixOp op <+> pPrintPrec 1 ty2
]
pPrint (RecordDecl _ tvs cx c fs) =
sep [ ppQuantifiedVars tvs <+> ppContext cx
, ppIdent c <+> record (list (map pPrint fs))
]
instance Pretty FieldDecl where
pPrint (FieldDecl _ ls ty) = list (map ppIdent ls)
......@@ -167,7 +173,7 @@ instance Pretty NewConstrDecl where
ppQuantifiedVars :: [Ident] -> Doc
ppQuantifiedVars tvs
| null tvs = empty
| otherwise = text "forall" <+> hsep (map ppIdent tvs) <> char '.'
| otherwise = text "forall" <+> hsep (map ppIdent tvs) <+> char '.'
instance Pretty (Equation a) where
pPrint (Equation _ lhs rhs) = ppRule (pPrint lhs) equals rhs
......@@ -240,8 +246,8 @@ ppITypeDeclLhs kw tc k tvs =
text kw <+> ppQIdentWithKind tc k <+> hsep (map ppIdent tvs)
instance Pretty IMethodDecl where
pPrint (IMethodDecl _ f a ty) =
ppIdent f <+> maybePP int a <+> text "::" <+> pPrintPrec 0 ty
pPrint (IMethodDecl _ f a qty) =
ppIdent f <+> maybePP int a <+> text "::" <+> pPrintPrec 0 qty
ppIMethodImpl :: IMethodImpl -> Doc
ppIMethodImpl (f, a) = ppIdent f <+> int a
......@@ -274,10 +280,13 @@ instance Pretty KindExpr where
-- Types
-- ---------------------------------------------------------------------------
instance Pretty QualTypeExpr where
pPrint (QualTypeExpr _ cx ty) = ppContext cx <+> pPrintPrec 0 ty
instance Pretty TypeExpr where
pPrintPrec _ (ConstructorType _ tc) = ppQIdent tc
pPrintPrec p (ApplyType _ ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])
where
where
ppApplyType (ApplyType _ ty1' ty2') tys =
ppApplyType ty1' (ty2' : tys)
ppApplyType ty tys =
......@@ -293,9 +302,6 @@ instance Pretty TypeExpr where
ppArrowType ty =
[pPrintPrec 0 ty]
pPrintPrec _ (ParenType _ ty) = parens (pPrintPrec 0 ty)
pPrintPrec p (ContextType _ cx ty)
| null cx = pPrintPrec p ty
| otherwise = parenIf (p > 0) $ ppContext cx <+> pPrintPrec 0 ty
pPrintPrec p (ForallType _ vs ty)
| null vs = pPrintPrec p ty
| otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> pPrintPrec 0 ty
......
......@@ -170,11 +170,11 @@ showsDecl (TypeDecl spi ident idents typ)
. showsList showsIdent idents . space
. showsTypeExpr typ
. showsString ")"
showsDecl (TypeSig spi idents ty)
showsDecl (TypeSig spi idents qtype)
= showsString "(TypeSig "
. showsSpanInfo spi . space
. showsList showsIdent idents . space
. showsTypeExpr ty
. showsQualTypeExpr qtype
. showsString ")"
showsDecl (FunctionDecl spi a ident eqs)
= showsString "(FunctionDecl "
......@@ -238,22 +238,28 @@ showsInstanceType :: InstanceType -> ShowS
showsInstanceType = showsTypeExpr
showsConsDecl :: ConstrDecl -> ShowS
showsConsDecl (ConstrDecl spi ident types)
showsConsDecl (ConstrDecl spi idents context ident types)
= showsString "(ConstrDecl "
. showsSpanInfo spi . space
. showsList showsIdent idents . space
. showsContext context . space
. showsIdent ident . space
. showsList showsTypeExpr types
. showsString ")"
showsConsDecl (ConOpDecl spi ty1 ident ty2)
showsConsDecl (ConOpDecl spi idents context ty1 ident ty2)
= showsString "(ConOpDecl "
. showsSpanInfo spi . space
. showsList showsIdent idents . space
. showsContext context . space
. showsTypeExpr ty1 . space
. showsIdent ident . space
. showsTypeExpr ty2
. showsString ")"
showsConsDecl (RecordDecl spi ident fs)
showsConsDecl (RecordDecl spi idents context ident fs)
= showsString "(RecordDecl "
. showsSpanInfo spi . space
. showsList showsIdent idents . space
. showsContext context . space
. showsIdent ident . space
. showsList showsFieldDecl fs
. showsString ")"
......@@ -280,6 +286,14 @@ showsNewConsDecl (NewRecordDecl spi ident fld)
. showsPair showsIdent showsTypeExpr fld
. showsString ")"
showsQualTypeExpr :: QualTypeExpr -> ShowS
showsQualTypeExpr (QualTypeExpr spi context typ)
= showsString "(QualTypeExpr "
. showsSpanInfo spi . space
. showsContext context . space
. showsTypeExpr typ
. showsString ")"
showsTypeExpr :: TypeExpr -> ShowS
showsTypeExpr (ConstructorType spi qident)
= showsString "(ConstructorType "
......@@ -318,12 +332,6 @@ showsTypeExpr (ParenType spi ty)
. showsSpanInfo spi . space
. showsTypeExpr ty
. showsString ")"
showsTypeExpr (ContextType spi cx ty)
= showsString "(ContextType "
. showsSpanInfo spi . space
. showsContext cx . space
. showsTypeExpr ty
. showsString ")"
showsTypeExpr (ForallType spi vars ty)
= showsString "(ForallType "
. showsSpanInfo spi . space
......@@ -510,11 +518,11 @@ showsExpression (Paren spi expr)
. showsSpanInfo spi . space
. showsExpression expr
. showsString ")"
showsExpression (Typed spi expr ty)
showsExpression (Typed spi expr qtype)
= showsString "(Typed "
. showsSpanInfo spi . space
. showsExpression expr . space
. showsTypeExpr ty
. showsQualTypeExpr qtype
. showsString ")"
showsExpression (Tuple spi exps)
= showsString "(Tuple "
......
......@@ -31,7 +31,7 @@ module Curry.Syntax.Type
-- * Declarations
, Decl (..), Precedence, Infix (..), ConstrDecl (..), NewConstrDecl (..)
, FieldDecl (..)
, TypeExpr (..)
, TypeExpr (..), QualTypeExpr (..)
, Equation (..), Lhs (..), Rhs (..), CondExpr (..)
, Literal (..), Pattern (..), Expression (..), InfixOp (..)
, Statement (..), CaseType (..), Alt (..), Field (..), Var (..)
......@@ -129,14 +129,14 @@ data IDecl
| IDataDecl Position QualIdent (Maybe KindExpr) [Ident] [ConstrDecl] [Ident]
| INewtypeDecl Position QualIdent (Maybe KindExpr) [Ident] NewConstrDecl [Ident]
| ITypeDecl Position QualIdent (Maybe KindExpr) [Ident] TypeExpr
| IFunctionDecl Position QualIdent (Maybe Ident) Arity TypeExpr
| IFunctionDecl Position QualIdent (Maybe Ident) Arity QualTypeExpr
| HidingClassDecl Position Context QualIdent (Maybe KindExpr) Ident
| IClassDecl Position Context QualIdent (Maybe KindExpr) Ident [IMethodDecl] [Ident]
| IInstanceDecl Position Context QualIdent InstanceType [IMethodImpl] (Maybe ModuleIdent)
deriving (Eq, Read, Show)
-- |Class methods
data IMethodDecl = IMethodDecl Position Ident (Maybe Arity) TypeExpr
data IMethodDecl = IMethodDecl Position Ident (Maybe Arity) QualTypeExpr
deriving (Eq, Read, Show)
-- |Class method implementations
......@@ -159,7 +159,7 @@ data Decl a
| ExternalDataDecl SpanInfo Ident [Ident] -- external data C a b
| NewtypeDecl SpanInfo Ident [Ident] NewConstrDecl [QualIdent] -- newtype C a b = C a b deriving (D, ...)
| TypeDecl SpanInfo Ident [Ident] TypeExpr -- type C a b = D a b
| TypeSig SpanInfo [Ident] TypeExpr -- f, g :: Bool
| TypeSig SpanInfo [Ident] QualTypeExpr -- f, g :: Bool
| FunctionDecl SpanInfo a Ident [Equation a] -- f True = 1 ; f False = 0
| ExternalDecl SpanInfo [Var a] -- f, g external
| PatternDecl SpanInfo (Pattern a) (Rhs a) -- Just x = ...
......@@ -185,9 +185,9 @@ data Infix
-- |Constructor declaration for algebraic data types
data ConstrDecl
= ConstrDecl SpanInfo Ident [TypeExpr]
| ConOpDecl SpanInfo TypeExpr Ident TypeExpr
| RecordDecl SpanInfo Ident [FieldDecl]
= ConstrDecl SpanInfo [Ident] Context Ident [TypeExpr]
| ConOpDecl SpanInfo [Ident] Context TypeExpr Ident TypeExpr
| RecordDecl SpanInfo [Ident] Context Ident [FieldDecl]
deriving (Eq, Read, Show)
-- |Constructor declaration for renaming types (newtypes)
......@@ -209,10 +209,13 @@ data TypeExpr
| ListType SpanInfo TypeExpr
| ArrowType SpanInfo TypeExpr TypeExpr
| ParenType SpanInfo TypeExpr
| ContextType SpanInfo Context TypeExpr
| ForallType SpanInfo [Ident] TypeExpr
deriving (Eq, Read, Show)
-- |Qualified type expressions
data QualTypeExpr = QualTypeExpr SpanInfo Context TypeExpr
deriving (Eq, Read, Show)
-- ---------------------------------------------------------------------------
-- Type classes
-- ---------------------------------------------------------------------------
......@@ -280,7 +283,7 @@ data Expression a
| Variable SpanInfo a QualIdent
| Constructor SpanInfo a QualIdent
| Paren SpanInfo (Expression a)
| Typed SpanInfo (Expression a) TypeExpr
| Typed SpanInfo (Expression a) QualTypeExpr
| Record SpanInfo a QualIdent [Field (Expression a)] -- C {l1 = e1,..., ln = en}
| RecordUpdate SpanInfo (Expression a) [Field (Expression a)] -- e {l1 = e1,..., ln = en}
| Tuple SpanInfo [Expression a]
......@@ -650,23 +653,23 @@ instance HasSpanInfo Import where
updateEndPos i@(ImportTypeAll _ _) = i
instance HasSpanInfo ConstrDecl where
getSpanInfo (ConstrDecl sp _ _) = sp
getSpanInfo (ConOpDecl sp _ _ _) = sp
getSpanInfo (RecordDecl sp _ _) = sp
getSpanInfo (ConstrDecl sp _ _ _ _) = sp
getSpanInfo (ConOpDecl sp _ _ _ _ _) = sp
getSpanInfo (RecordDecl sp _ _ _ _) = sp
setSpanInfo sp (ConstrDecl _ idt ty) = ConstrDecl sp idt ty
setSpanInfo sp (ConOpDecl _ ty1 idt ty2) = ConOpDecl sp ty1 idt ty2
setSpanInfo sp (RecordDecl _ idt fd) = RecordDecl sp idt fd
setSpanInfo sp (ConstrDecl _ tvar ctx idt ty) = ConstrDecl sp tvar ctx idt ty
setSpanInfo sp (ConOpDecl _ tvar ctx ty1 idt ty2) = ConOpDecl sp tvar ctx ty1 idt ty2
setSpanInfo sp (RecordDecl _ tvar ctx idt fd) = RecordDecl sp tvar ctx idt fd
updateEndPos c@(ConstrDecl _ _ (t:ts)) =
updateEndPos c@(ConstrDecl _ _ _ _ (t:ts)) =
setEndPosition (getSrcSpanEnd (last (t:ts))) c
updateEndPos c@(ConstrDecl _ idt _) =
updateEndPos c@(ConstrDecl _ _ _ idt _) =
setEndPosition (incr (getPosition idt) (identLength idt - 1)) c
updateEndPos c@(ConOpDecl _ _ _ ty) =
updateEndPos c@(ConOpDecl _ _ _ _ _ ty) =
setEndPosition (getSrcSpanEnd ty) c
updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _) =
updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _ _ _) =
setEndPosition (end (last ss)) c
updateEndPos c@(RecordDecl _ _ _) = c
updateEndPos c@(RecordDecl _ _ _ _ _) = c
instance HasSpanInfo NewConstrDecl where
getSpanInfo (NewConstrDecl sp _ _) = sp
......@@ -695,7 +698,6 @@ instance HasSpanInfo TypeExpr where
getSpanInfo (ListType sp _) = sp
getSpanInfo (ArrowType sp _ _) = sp
getSpanInfo (ParenType sp _) = sp
getSpanInfo (ContextType sp _ _) = sp
getSpanInfo (ForallType sp _ _) = sp
setSpanInfo sp (ConstructorType _ qid) = ConstructorType sp qid
......@@ -705,7 +707,6 @@ instance HasSpanInfo TypeExpr where
setSpanInfo sp (ListType _ ty) = ListType sp ty
setSpanInfo sp (ArrowType _ ty1 ty2) = ArrowType sp ty1 ty2
setSpanInfo sp (ParenType _ ty) = ParenType sp ty
setSpanInfo sp (ContextType _ cx ty) = ContextType sp cx ty
setSpanInfo sp (ForallType _ idt ty) = ForallType sp idt ty
updateEndPos t@(ConstructorType _ qid) =
......@@ -724,10 +725,13 @@ instance HasSpanInfo TypeExpr where
updateEndPos t@(ParenType (SpanInfo _ (s:ss)) _) =
setEndPosition (end (last (s:ss))) t
updateEndPos t@(ParenType _ _) = t
updateEndPos t@(ContextType _ _ te) =
setEndPosition (getSrcSpanEnd te) t
updateEndPos t@(ForallType _ _ te) =
setEndPosition (getSrcSpanEnd te) t
updateEndPos t@(ForallType _ _ _) = t -- not a parseable type
instance HasSpanInfo QualTypeExpr where
getSpanInfo (QualTypeExpr sp _ _) = sp
setSpanInfo sp (QualTypeExpr _ cx ty) = QualTypeExpr sp cx ty
updateEndPos t@(QualTypeExpr _ _ ty) =
setEndPosition (getSrcSpanEnd ty) t
instance HasSpanInfo Constraint where
getSpanInfo (Constraint sp _ _) = sp
......@@ -1056,6 +1060,10 @@ instance HasPosition TypeExpr where
getPosition = getStartPosition
setPosition = setStartPosition
instance HasPosition QualTypeExpr where
getPosition = getStartPosition
setPosition = setStartPosition
instance HasPosition NewConstrDecl where
getPosition = getStartPosition
setPosition = setStartPosition
......@@ -1234,19 +1242,19 @@ instance Binary Infix where
_ -> fail "Invalid encoding for Infix"
instance Binary ConstrDecl where
put (ConstrDecl spi idt tys) =
putWord8 0 >> put spi >> put idt >> put tys
put (ConOpDecl spi ty1 idt ty2) =
putWord8 1 >> put spi >> put ty1 >> put idt >> put ty2
put (RecordDecl spi idt fs) =
putWord8 2 >> put spi >> put idt >> put fs
put (ConstrDecl spi tvar ctx idt ty) =
putWord8 0 >> put spi >> put tvar >> put ctx >> put idt >> put ty
put (ConOpDecl spi tvar ctx ty1 idt ty2) =
putWord8 1 >> put spi >> put tvar >> put ctx >> put ty1 >> put idt >> put ty2
put (RecordDecl spi tvar ctx idt fs) =
putWord8 2 >> put spi >> put tvar >> put ctx >> put idt >> put fs
get = do
x <- getWord8
case x of
0 -> liftM3 ConstrDecl get get get
1 -> ConOpDecl <$> get <*> get <*> get <*> get
2 -> liftM3 RecordDecl get get get
0 -> ConstrDecl <$> get <*> get <*> get <*> get <*> get
1 -> ConOpDecl <$> get <*> get <*> get <*> get <*> get <*> get
2 -> RecordDecl <$> get <*> get <*> get <*> get <*> get
_ -> fail "Invalid encoding for ConstrDecl"
instance Binary NewConstrDecl where
......@@ -1266,6 +1274,10 @@ instance Binary FieldDecl where
put (FieldDecl spi is ty) = put spi >> put is >> put ty
get = liftM3 FieldDecl get get get
instance Binary QualTypeExpr where
put (QualTypeExpr spi ctx te) = put spi >> put ctx >> put te
get = liftM3 QualTypeExpr get get get
instance Binary TypeExpr where
put (ConstructorType spi qid) =
putWord8 0 >> put spi >> put qid
......@@ -1281,10 +1293,8 @@ instance Binary TypeExpr where
putWord8 5 >> put spi >> put ty1 >> put ty2
put (ParenType spi ty) =
putWord8 6 >> put spi >> put ty
put (ContextType spi cx ty) =
putWord8 7 >> put spi >> put cx >> put ty
put (ForallType spi is ty) =
putWord8 8 >> put spi >> put is >> put ty
putWord8 7 >> put spi >> put is >> put ty
get = do
x <- getWord8
......@@ -1296,8 +1306,7 @@ instance Binary TypeExpr where
4 -> liftM2 ListType get get
5 -> liftM3 ArrowType get get get
6 -> liftM2 ParenType get get
7 -> liftM3 ContextType get get get
8 -> liftM3 ForallType get get get
7 -> liftM3 ForallType get get get
_ -> fail "Invalid encoding for TypeExpr"
instance Binary Constraint where
......
......@@ -39,6 +39,7 @@ module Curry.Syntax.Utils
import Control.Monad.State
import Curry.Base.Ident
import Curry.Base.Position
import Curry.Base.SpanInfo
import Curry.Files.Filenames (takeBaseName)
import Curry.Syntax.Extension
......@@ -146,7 +147,6 @@ isSimpleType (TupleType _ tys) = all isVariableType tys
isSimpleType (ListType _ ty) = isVariableType ty
isSimpleType (ArrowType _ ty1 ty2) = isVariableType ty1 && isVariableType ty2
isSimpleType (ParenType _ ty) = isSimpleType ty
isSimpleType (ContextType _ _ _) = False
isSimpleType (ForallType _ _ _) = False
-- |Return the qualified type constructor of a type expression.
......@@ -159,8 +159,6 @@ typeConstr (ArrowType _ _ _) = qArrowId
typeConstr (ParenType _ ty) = typeConstr ty
typeConstr (VariableType _ _) =
error "Curry.Syntax.Utils.typeConstr: variable type"
typeConstr (ContextType _ _ _) =
error "Curry.Syntax.Utils.typeConstr: context type"
typeConstr (ForallType _ _ _) =
error "Curry.Syntax.Utils.typeConstr: forall type"
......@@ -173,7 +171,6 @@ typeVariables (TupleType _ tys) = concatMap typeVariables tys
typeVariables (ListType _ ty) = typeVariables ty
typeVariables (ArrowType _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2
typeVariables (ParenType _ ty) = typeVariables ty
typeVariables (ContextType _ _ ty) = typeVariables ty
typeVariables (ForallType _ vs ty) = vs ++ typeVariables ty
-- |Return the identifier of a variable.
......@@ -215,9 +212,9 @@ opName (InfixConstr _ c ) = c
-- | Get the identifier of a constructor declaration
constrId :: ConstrDecl -> Ident
constrId (ConstrDecl _ c _) = c
constrId (ConOpDecl _ _ op _) = op
constrId (RecordDecl _ c _) = c
constrId (ConstrDecl _ _ _ c _) = c
constrId (ConOpDecl _ _ _ _ op _) = op
constrId (RecordDecl _ _ _ c _) = c
-- | Get the identifier of a newtype constructor declaration
nconstrId :: NewConstrDecl -> Ident
......@@ -231,9 +228,9 @@ nconstrType (NewRecordDecl _ _ (_, ty)) = ty
-- | Get record label identifiers of a constructor declaration
recordLabels :: ConstrDecl -> [Ident]
recordLabels (ConstrDecl _ _ _) = []
recordLabels (ConOpDecl _ _ _ _) = []
recordLabels (RecordDecl _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls]
recordLabels (ConstrDecl _ _ _ _ _) = []
recordLabels (ConOpDecl _ _ _ _ _ _) = []
recordLabels (RecordDecl _ _ _ _ fs) = [l | FieldDecl _ ls _ <- fs, l <- ls]
-- | Get record label identifier of a newtype constructor declaration
nrecordLabels :: NewConstrDecl -> [Ident]
......