diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,8 +1,13 @@ Change log for curry-base ========================= +Version (1.2.0) (WIP) +===================== + + * Added support for latex-style in literate curry + Version (1.1.0) -=================================== +=============== * Added SpanInfos to AST diff --git a/curry-base.cabal b/curry-base.cabal --- a/curry-base.cabal +++ b/curry-base.cabal @@ -1,5 +1,5 @@ Name: curry-base -Version: 1.1.0 +Version: 1.1.1 Cabal-Version: >= 1.10 Synopsis: Functions for manipulating Curry programs Description: This package serves as a foundation for Curry compilers. diff --git a/src/Curry/AbstractCurry/Type.hs b/src/Curry/AbstractCurry/Type.hs --- a/src/Curry/AbstractCurry/Type.hs +++ b/src/Curry/AbstractCurry/Type.hs @@ -147,6 +147,7 @@ -- 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. diff --git a/src/Curry/Files/Unlit.hs b/src/Curry/Files/Unlit.hs --- a/src/Curry/Files/Unlit.hs +++ b/src/Curry/Files/Unlit.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ViewPatterns #-} {- | Module : $Header$ Description : Handling of literate Curry files @@ -16,12 +17,16 @@ literate programs, Curry requires at least one program line to be present in the file. In addition, every block of program code must be preceded by a blank line and followed by a blank line. + + It is also possible to use "\begin{code}" and "\end{code}" + to mark code segments. Both styles can be used in mixed fashion. -} module Curry.Files.Unlit (isLiterate, unlit) where -import Control.Monad (when, zipWithM) +import Control.Monad (when, unless, zipWithM) import Data.Char (isSpace) +import Data.List (stripPrefix) import Curry.Base.Monad (CYM, failMessageAt) import Curry.Base.Position (Position (..), first) @@ -33,38 +38,86 @@ -- |Data type representing different kind of lines in a literate source data Line - = Program !Int String -- ^ program line with a line number and content - | Blank -- ^ blank line - | Comment -- ^ comment line + = ProgramStart !Int -- ^ \begin{code} + | ProgramEnd !Int -- ^ \end{code} + | Program !Int String -- ^ program line with a line number and content + | Comment !Int String -- ^ comment line + | Blank !Int -- ^ blank line -- |Process a curry program into error messages (if any) and the -- corresponding non-literate program. unlit :: FilePath -> String -> CYM String unlit fn cy | isLiterate fn = do - ls <- progLines fn $ zipWith classify [1 .. ] $ lines cy + let cyl = lines cy + ls <- progLines fn =<< + normalize fn (length cyl) False (zipWith classify [1 .. ] cyl) when (all null ls) $ failMessageAt (first fn) "No code in literate script" return (unlines ls) | otherwise = return cy -- |Classification of a single program line classify :: Int -> String -> Line -classify l ('>' : cs) = Program l cs -classify _ cs | all isSpace cs = Blank - | otherwise = Comment +classify l s@('>' : _) = Program l s +classify l s@(stripPrefix "\\begin{code}" -> Just cs) + | all isSpace cs = ProgramStart l + | otherwise = Comment l s +classify l s@(stripPrefix "\\end{code}" -> Just cs) + | all isSpace cs = ProgramEnd l + | otherwise = Comment l s +classify l s + | all isSpace s = Blank l + | otherwise = Comment l s --- |Check that each program line is not adjacent to a comment line and there --- is at least one program line. +-- |Check that ProgramStart and ProgramEnd match and desugar them. +normalize :: FilePath -> Int -> Bool -> [Line] -> CYM [Line] +normalize _ _ False [] = return [] +normalize fn n True [] = reportMissingEnd fn n +normalize fn n b (ProgramStart l : rest) = do + when b $ reportSpurious fn l "\\begin{code}" + norm <- normalize fn n True rest + return (Blank l : norm) +normalize fn n b (ProgramEnd l : rest) = do + unless b $ reportSpurious fn l "\\end{code}" + norm <- normalize fn n False rest + return (Blank l : norm) +normalize fn n b (Comment l s : rest) = do + let cons = if b then Program l s else Comment l s + norm <- normalize fn n b rest + return (cons : norm) +normalize fn n b (Program l s : rest) = do + let cons = if b then Program l s else Program l (drop 1 s) + norm <- normalize fn n b rest + return (cons : norm) +normalize fn n b (Blank l : rest) = do + let cons = if b then Program l "" else Blank l + norm <- normalize fn n b rest + return (cons : norm) + +-- |Check that each program line is not adjacent to a comment line. progLines :: FilePath -> [Line] -> CYM [String] -progLines fn cs = zipWithM checkAdjacency (Blank : cs) cs where - checkAdjacency (Program p _) Comment = report fn p "followed" - checkAdjacency Comment (Program p _) = report fn p "preceded" +progLines fn cs = zipWithM checkAdjacency (Blank 0 : cs) cs where + checkAdjacency (Program p _) (Comment _ _) = reportBlank fn p "followed" + checkAdjacency (Comment _ _) (Program p _) = reportBlank fn p "preceded" checkAdjacency _ (Program _ s) = return s checkAdjacency _ _ = return "" -- |Compute an appropiate error message -report :: String -> Int -> String -> CYM a -report f l cause = failMessageAt (Position f l 1) msg +reportBlank :: FilePath -> Int -> String -> CYM a +reportBlank f l cause = failMessageAt (Position f l 1) msg where msg = concat [ "When reading literate source: " , "Program line is " ++ cause ++ " by comment line." + ] + +reportMissingEnd :: FilePath -> Int -> CYM a +reportMissingEnd f l = failMessageAt (Position f (l+1) 1) msg + where msg = concat [ "When reading literate source: " + , "Missing '\\end{code}' at the end of file." + ] + + +reportSpurious :: FilePath -> Int -> String -> CYM a +reportSpurious f l cause = failMessageAt (Position f l 1) msg + where msg = concat [ "When reading literate source: " + , "Spurious '" ++ cause ++ "'." ] diff --git a/src/Curry/Syntax/Extension.hs b/src/Curry/Syntax/Extension.hs --- a/src/Curry/Syntax/Extension.hs +++ b/src/Curry/Syntax/Extension.hs @@ -41,7 +41,6 @@ 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 diff --git a/src/Curry/Syntax/InterfaceEquivalence.hs b/src/Curry/Syntax/InterfaceEquivalence.hs --- a/src/Curry/Syntax/InterfaceEquivalence.hs +++ b/src/Curry/Syntax/InterfaceEquivalence.hs @@ -99,12 +99,12 @@ _ =~= _ = False instance Equiv ConstrDecl where - 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 + 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 _ =~= _ = False instance Equiv FieldDecl where @@ -159,10 +159,10 @@ fix _ d = d instance FixInterface ConstrDecl where - 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) + 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) instance FixInterface FieldDecl where fix tcs (FieldDecl p ls ty) = FieldDecl p ls (fix tcs ty) diff --git a/src/Curry/Syntax/Parser.hs b/src/Curry/Syntax/Parser.hs --- a/src/Curry/Syntax/Parser.hs +++ b/src/Curry/Syntax/Parser.hs @@ -119,7 +119,7 @@ updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $ spc (fromSrcSpan (getSrcSpan qtc)) qtc exportTypeWith' c spi qtc = ExportTypeWith spi qtc c - exportModule' sp = updateEndPos . ExportModule (SpanInfo sp []) + exportModule' sp = updateEndPos . ExportModule (SpanInfo sp [sp]) moduleDecls :: Parser a Token ([ImportDecl], [Decl ()]) moduleDecls = impDecl <$> importDecl @@ -331,8 +331,7 @@ typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar constrDecl :: Parser a Token ConstrDecl -constrDecl = spanPosition <**> (existVars - <**> optContext (\cx sp f -> f sp cx) constr) +constrDecl = spanPosition <**> constr where constr = conId <**> identDecl <|> tokenSpan LeftParen <**> parenDecl @@ -348,16 +347,16 @@ 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 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 + 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 fieldDecl :: Parser a Token FieldDecl fieldDecl = mkFieldDecl <$> spanPosition <*> labels @@ -386,13 +385,6 @@ <*> (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 @@ -1315,9 +1307,6 @@ <$> tokenSpan LeftParen <*> 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)) diff --git a/src/Curry/Syntax/Pretty.hs b/src/Curry/Syntax/Pretty.hs --- a/src/Curry/Syntax/Pretty.hs +++ b/src/Curry/Syntax/Pretty.hs @@ -155,18 +155,12 @@ ppTypeDeclLhs kw tc tvs = text kw <+> ppIdent tc <+> hsep (map ppIdent tvs) ppConstr :: ConstrDecl -> Doc -ppConstr (ConstrDecl _ tvs cx c tys) = - sep [ ppQuantifiedVars tvs <+> ppContext cx - , ppIdent c <+> fsep (map (ppTypeExpr 2) tys) - ] -ppConstr (ConOpDecl _ tvs cx ty1 op ty2) = - sep [ ppQuantifiedVars tvs <+> ppContext cx - , ppTypeExpr 1 ty1, ppInfixOp op <+> ppTypeExpr 1 ty2 - ] -ppConstr (RecordDecl _ tvs cx c fs) = - sep [ ppQuantifiedVars tvs <+> ppContext cx - , ppIdent c <+> record (list (map ppFieldDecl fs)) - ] +ppConstr (ConstrDecl _ c tys) = + sep [ ppIdent c <+> fsep (map (ppTypeExpr 2) tys) ] +ppConstr (ConOpDecl _ ty1 op ty2) = + sep [ ppTypeExpr 1 ty1, ppInfixOp op <+> ppTypeExpr 1 ty2 ] +ppConstr (RecordDecl _ c fs) = + sep [ ppIdent c <+> record (list (map ppFieldDecl fs)) ] ppFieldDecl :: FieldDecl -> Doc ppFieldDecl (FieldDecl _ ls ty) = list (map ppIdent ls) diff --git a/src/Curry/Syntax/ShowModule.hs b/src/Curry/Syntax/ShowModule.hs --- a/src/Curry/Syntax/ShowModule.hs +++ b/src/Curry/Syntax/ShowModule.hs @@ -235,28 +235,22 @@ showsInstanceType = showsTypeExpr showsConsDecl :: ConstrDecl -> ShowS -showsConsDecl (ConstrDecl spi idents context ident types) +showsConsDecl (ConstrDecl spi ident types) = showsString "(ConstrDecl " . showsSpanInfo spi . space - . showsList showsIdent idents . space - . showsContext context . space . showsIdent ident . space . showsList showsTypeExpr types . showsString ")" -showsConsDecl (ConOpDecl spi idents context ty1 ident ty2) +showsConsDecl (ConOpDecl spi 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 idents context ident fs) +showsConsDecl (RecordDecl spi ident fs) = showsString "(RecordDecl " . showsSpanInfo spi . space - . showsList showsIdent idents . space - . showsContext context . space . showsIdent ident . space . showsList showsFieldDecl fs . showsString ")" diff --git a/src/Curry/Syntax/Type.hs b/src/Curry/Syntax/Type.hs --- a/src/Curry/Syntax/Type.hs +++ b/src/Curry/Syntax/Type.hs @@ -182,9 +182,9 @@ -- |Constructor declaration for algebraic data types data ConstrDecl - = ConstrDecl SpanInfo [Ident] Context Ident [TypeExpr] - | ConOpDecl SpanInfo [Ident] Context TypeExpr Ident TypeExpr - | RecordDecl SpanInfo [Ident] Context Ident [FieldDecl] + = ConstrDecl SpanInfo Ident [TypeExpr] + | ConOpDecl SpanInfo TypeExpr Ident TypeExpr + | RecordDecl SpanInfo Ident [FieldDecl] deriving (Eq, Read, Show) -- |Constructor declaration for renaming types (newtypes) @@ -644,23 +644,23 @@ 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 _ 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 + 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 - 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 diff --git a/src/Curry/Syntax/Utils.hs b/src/Curry/Syntax/Utils.hs --- a/src/Curry/Syntax/Utils.hs +++ b/src/Curry/Syntax/Utils.hs @@ -39,7 +39,6 @@ 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 @@ -212,9 +211,9 @@ -- | 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 @@ -228,9 +227,9 @@ -- | 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]