diff --git a/dist/build/Language/Haskell/Exts/InternalParser.hs b/dist/build/Language/Haskell/Exts/InternalParser.hs --- a/dist/build/Language/Haskell/Exts/InternalParser.hs +++ b/dist/build/Language/Haskell/Exts/InternalParser.hs @@ -2875,7 +2875,9 @@ let { (gs,ss,minf) = happy_var_4; l = ann happy_var_1 <+?> minf <+?> fmap ann happy_var_5 <** (snd happy_var_3 ++ ss)}; checkDataOrNew happy_var_1 gs; - return (GDataDecl l happy_var_1 cs dh (fst happy_var_3) (reverse gs) happy_var_5) })}}}}} + case (gs, fst happy_var_3) of + ([], Nothing) -> return (DataDecl l happy_var_1 cs dh [] happy_var_5) + _ -> checkEnabled GADTs >> return (GDataDecl l happy_var_1 cs dh (fst happy_var_3) (reverse gs) happy_var_5) })}}}}} ) (\r -> happyReturn (happyIn49 r)) happyReduce_97 = happyMonadReduce 4# 39# happyReduction_97 @@ -4106,7 +4108,7 @@ case happyOutTok happy_x_2 of { (Loc happy_var_2 LeftCurly) -> case happyOut98 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { (Loc happy_var_4 RightCurly) -> - ( checkEnabled GADTs >> return (fst happy_var_3, happy_var_1 : happy_var_2 : snd happy_var_3 ++ [happy_var_4], Just $ happy_var_1 <^^> happy_var_4))}}}} + ( return (fst happy_var_3, happy_var_1 : happy_var_2 : snd happy_var_3 ++ [happy_var_4], Just $ happy_var_1 <^^> happy_var_4))}}}} ) (\r -> happyReturn (happyIn97 r)) happyReduce_222 = happyMonadReduce 4# 87# happyReduction_222 @@ -4119,7 +4121,7 @@ case happyOut220 happy_x_2 of { happy_var_2 -> case happyOut98 happy_x_3 of { happy_var_3 -> case happyOut221 happy_x_4 of { happy_var_4 -> - ( checkEnabled GADTs >> return (fst happy_var_3, happy_var_1 : happy_var_2 : snd happy_var_3 ++ [happy_var_4], Just $ happy_var_1 <^^> happy_var_4))}}}} + ( return (fst happy_var_3, happy_var_1 : happy_var_2 : snd happy_var_3 ++ [happy_var_4], Just $ happy_var_1 <^^> happy_var_4))}}}} ) (\r -> happyReturn (happyIn97 r)) happyReduce_223 = happyMonadReduce 0# 87# happyReduction_223 @@ -7636,7 +7638,7 @@ type S = SrcSpan parseError :: Loc Token -> P a -parseError t = fail $ "Parse error: " ++ show (unLoc t) +parseError t = fail $ "Parse error: " ++ showToken (unLoc t) (<>) :: (Annotated a, Annotated b) => a SrcSpanInfo -> b SrcSpanInfo -> SrcSpanInfo a <> b = ann a <++> ann b diff --git a/haskell-src-exts.cabal b/haskell-src-exts.cabal --- a/haskell-src-exts.cabal +++ b/haskell-src-exts.cabal @@ -1,5 +1,5 @@ Name: haskell-src-exts -Version: 1.3.0 +Version: 1.3.1 License: BSD3 License-File: LICENSE Author: Niklas Broberg diff --git a/src/Language/Haskell/Exts/Annotated/ExactPrint.hs b/src/Language/Haskell/Exts/Annotated/ExactPrint.hs --- a/src/Language/Haskell/Exts/Annotated/ExactPrint.hs +++ b/src/Language/Haskell/Exts/Annotated/ExactPrint.hs @@ -113,6 +113,7 @@ ------------------------------------------------------------------------------ -- Printing of source elements +-- | Print an AST exactly as specified by the annotations on the nodes in the tree. exactPrint :: (ExactP ast) => ast SrcSpanInfo -> [Comment] -> String exactPrint ast cs = runEP (exactP ast) cs @@ -803,7 +804,9 @@ exactP (Deriving l ihs) = do let (x:pts) = srcInfoPoints l printString "deriving" - parenList pts ihs + case pts of + [] -> exactPC $ head ihs + _ -> parenList pts ihs instance ExactP ClassDecl where exactP cdecl = case cdecl of diff --git a/src/Language/Haskell/Exts/Annotated/Syntax.hs b/src/Language/Haskell/Exts/Annotated/Syntax.hs --- a/src/Language/Haskell/Exts/Annotated/Syntax.hs +++ b/src/Language/Haskell/Exts/Annotated/Syntax.hs @@ -1106,6 +1106,7 @@ ----------------------------------------------------------------------------- -- AST traversal, boiler-plate style +-- | Test if two AST elements are equal modulo annotations. (=~=) :: (Functor a, Eq (a ())) => a l1 -> a l2 -> Bool a =~= b = fmap (const ()) a == fmap (const ()) b @@ -1531,8 +1532,13 @@ ----------------------------------------------------------------------------- -- Reading annotations +-- | AST nodes are annotated, and this class allows manipulation of the annotations. class Functor ast => Annotated ast where + -- | Retrieve the annotation of an AST node. ann :: ast l -> l + -- | Change the annotation of an AST node. Note that only the annotation of + -- the node itself is affected, and not the annotations of any child nodes. + -- if all nodes in the AST tree are to be affected, use 'fmap'. amap :: (l -> l) -> ast l -> ast l instance Annotated ModuleName where diff --git a/src/Language/Haskell/Exts/Comments.hs b/src/Language/Haskell/Exts/Comments.hs --- a/src/Language/Haskell/Exts/Comments.hs +++ b/src/Language/Haskell/Exts/Comments.hs @@ -11,6 +11,7 @@ #endif #endif +-- | A Haskell comment. The 'Bool' is 'True' if the comment is multi-line, i.e. @{- -}@. data Comment = Comment Bool SrcSpan String #ifdef __GLASGOW_HASKELL__ deriving (Eq,Show,Typeable,Data) diff --git a/src/Language/Haskell/Exts/InternalParser.ly b/src/Language/Haskell/Exts/InternalParser.ly --- a/src/Language/Haskell/Exts/InternalParser.ly +++ b/src/Language/Haskell/Exts/InternalParser.ly @@ -520,7 +520,9 @@ > let { (gs,ss,minf) = $4; > l = ann $1 <+?> minf <+?> fmap ann $5 <** (snd $3 ++ ss)}; > checkDataOrNew $1 gs; -> return (GDataDecl l $1 cs dh (fst $3) (reverse gs) $5) } } +> case (gs, fst $3) of +> ([], Nothing) -> return (DataDecl l $1 cs dh [] $5) +> _ -> checkEnabled GADTs >> return (GDataDecl l $1 cs dh (fst $3) (reverse gs) $5) } } Same as above, lexer will handle it through the 'family' keyword. > | 'data' 'family' ctype optkind @@ -870,8 +872,8 @@ : gadtlist1 {% >> return $1 } > gadtlist :: { ([GadtDecl L],[S],Maybe L) } -> : 'where' '{' gadtconstrs1 '}' {% checkEnabled GADTs >> return (fst $3, $1 : $2 : snd $3 ++ [$4], Just $ $1 <^^> $4) } -> | 'where' open gadtconstrs1 close {% checkEnabled GADTs >> return (fst $3, $1 : $2 : snd $3 ++ [$4], Just $ $1 <^^> $4) } +> : 'where' '{' gadtconstrs1 '}' {% return (fst $3, $1 : $2 : snd $3 ++ [$4], Just $ $1 <^^> $4) } +> | 'where' open gadtconstrs1 close {% return (fst $3, $1 : $2 : snd $3 ++ [$4], Just $ $1 <^^> $4) } > | {- empty -} {% checkEnabled EmptyDataDecls >> return ([],[],Nothing) } > gadtconstrs1 :: { ([GadtDecl L],[S]) } @@ -1690,7 +1692,7 @@ > type S = SrcSpan > parseError :: Loc Token -> P a -> parseError t = fail $ "Parse error: " ++ show (unLoc t) +> parseError t = fail $ "Parse error: " ++ showToken (unLoc t) > (<>) :: (Annotated a, Annotated b) => a SrcSpanInfo -> b SrcSpanInfo -> SrcSpanInfo > a <> b = ann a <++> ann b diff --git a/src/Language/Haskell/Exts/Lexer.hs b/src/Language/Haskell/Exts/Lexer.hs --- a/src/Language/Haskell/Exts/Lexer.hs +++ b/src/Language/Haskell/Exts/Lexer.hs @@ -18,7 +18,7 @@ -- ToDo: FloatTok should have three parts (integer part, fraction, exponent) (?) -- ToDo: Use a lexical analyser generator (lx?) -module Language.Haskell.Exts.Lexer (Token(..), lexer) where +module Language.Haskell.Exts.Lexer (Token(..), showToken, lexer) where import Language.Haskell.Exts.ParseMonad import Language.Haskell.Exts.SrcLoc @@ -28,6 +28,7 @@ import Data.Char import Data.Ratio +import Data.List (intersperse) import Control.Monad (when) -- import Debug.Trace (trace) @@ -705,11 +706,22 @@ lexQQBody = do s <- getInput case s of - '\\':']':_ -> do str <- lexQQBody + '\\':']':_ -> do discard 2 + str <- lexQQBody return (']':str) - '\\':'|':_ -> do str <- lexQQBody + '\\':'|':_ -> do discard 2 + str <- lexQQBody return ('|':str) '|':']':_ -> discard 2 >> return "" + '|':_ -> do discard 1 + str <- lexQQBody + return ('|':str) + ']':_ -> do discard 1 + str <- lexQQBody + return (']':str) + '\\':_ -> do discard 1 + str <- lexQQBody + return ('\\':str) _ -> do str <- lexWhile (not . (`elem` "\\|")) rest <- lexQQBody return (str++rest) @@ -1064,3 +1076,143 @@ flagKW :: Token -> Lex a () flagKW t = when (t `elem` [KW_Do, KW_MDo]) flagDo + +------------------------------------------------------------------ +-- "Pretty" printing for tokens + +showToken :: Token -> String +showToken t = case t of + VarId s -> s + QVarId (q,s) -> q ++ '.':s + IDupVarId s -> '?':s + ILinVarId s -> '%':s + ConId s -> s + QConId (q,s) -> q ++ '.':s + DVarId ss -> concat $ intersperse "-" ss + VarSym s -> s + ConSym s -> s + QVarSym (q,s) -> q ++ '.':s + QConSym (q,s) -> q ++ '.':s + IntTok (_, s) -> s + FloatTok (_, s) -> s + Character (_, s) -> '\'':s ++ "'" + StringTok (_, s) -> '"':s ++ "\"" + IntTokHash (_, s) -> s ++ "#" + WordTokHash (_, s) -> s ++ "##" + FloatTokHash (_, s) -> s ++ "#" + DoubleTokHash (_, s) -> s ++ "##" + CharacterHash (_, s) -> '\'':s ++ "'#" + StringHash (_, s) -> '"':s ++ "\"#" + LeftParen -> "(" + RightParen -> ")" + LeftHashParen -> "(#" + RightHashParen -> "#)" + LeftCurlyBar -> "{|" + RightCurlyBar -> "|}" + SemiColon -> ";" + LeftCurly -> "{" + RightCurly -> "}" + VRightCurly -> "virtual }" + LeftSquare -> "[" + RightSquare -> "]" + Comma -> "," + Underscore -> "_" + BackQuote -> "`" + Dot -> "." + DotDot -> ".." + Colon -> ":" + DoubleColon -> "::" + Equals -> "=" + Backslash -> "\\" + Bar -> "|" + LeftArrow -> "->" + RightArrow -> "<-" + At -> "@" + Tilde -> "~" + DoubleArrow -> "=>" + Minus -> "-" + Exclamation -> "!" + Star -> "*" + LeftArrowTail -> ">-" + RightArrowTail -> "-<" + LeftDblArrowTail -> ">>-" + RightDblArrowTail -> "-<<" + THExpQuote -> "[|" + THPatQuote -> "[p|" + THDecQuote -> "[d|" + THTypQuote -> "[t|" + THCloseQuote -> "|]" + THIdEscape s -> '$':s + THParenEscape -> "$(" + THVarQuote -> "'" + THTyQuote -> "''" + THQuasiQuote (n,q) -> "[$" ++ n ++ "|" ++ q ++ "]" + RPGuardOpen -> "(|" + RPGuardClose -> "|)" + RPCAt -> "@:" + XCodeTagOpen -> "<%" + XCodeTagClose -> "%>" + XStdTagOpen -> "<" + XStdTagClose -> ">" + XCloseTagOpen -> " "/>" + XPCDATA s -> "PCDATA " ++ s + XRPatOpen -> "<[" + XRPatClose -> "]>" + PragmaEnd -> "#-}" + RULES -> "{-# RULES" + INLINE b -> "{-# " ++ if b then "INLINE" else "NOINLINE" + SPECIALISE -> "{-# SPECIALISE" + SPECIALISE_INLINE b -> "{-# SPECIALISE " ++ if b then "INLINE" else "NOINLINE" + SOURCE -> "{-# SOURCE" + DEPRECATED -> "{-# DEPRECATED" + WARNING -> "{-# WARNING" + SCC -> "{-# SCC" + GENERATED -> "{-# GENERATED" + CORE -> "{-# CORE" + UNPACK -> "{-# UNPACK" + OPTIONS (mt,s) -> "{-# OPTIONS" ++ maybe "" (':':) mt ++ " ..." + CFILES s -> "{-# CFILES ..." + LANGUAGE -> "{-# LANGUAGE" + INCLUDE s -> "{-# INCLUDE ..." + KW_As -> "as" + KW_By -> "by" + KW_Case -> "case" + KW_Class -> "class" + KW_Data -> "data" + KW_Default -> "default" + KW_Deriving -> "deriving" + KW_Do -> "do" + KW_MDo -> "mdo" + KW_Else -> "else" + KW_Family -> "family" + KW_Forall -> "forall" + KW_Group -> "group" + KW_Hiding -> "hiding" + KW_If -> "if" + KW_Import -> "import" + KW_In -> "in" + KW_Infix -> "infix" + KW_InfixL -> "infixl" + KW_InfixR -> "infixr" + KW_Instance -> "instance" + KW_Let -> "let" + KW_Module -> "module" + KW_NewType -> "newtype" + KW_Of -> "of" + KW_Proc -> "proc" + KW_Rec -> "rec" + KW_Then -> "then" + KW_Type -> "type" + KW_Using -> "using" + KW_Where -> "where" + KW_Qualified -> "qualified" + KW_Foreign -> "foreign" + KW_Export -> "export" + KW_Safe -> "safe" + KW_Unsafe -> "unsafe" + KW_Threadsafe -> "threadsafe" + KW_StdCall -> "stdcall" + KW_CCall -> "ccall" + + EOF -> "EOF" diff --git a/src/Language/Haskell/Exts/ParseUtils.hs b/src/Language/Haskell/Exts/ParseUtils.hs --- a/src/Language/Haskell/Exts/ParseUtils.hs +++ b/src/Language/Haskell/Exts/ParseUtils.hs @@ -779,6 +779,13 @@ -- `atSrcLoc` loc else mergeMatches (ms++ms') ds (loc <++> l) mergeMatches ms' ds l = mergeFunBinds (FunBind l ms':revDs) ds + mergeFunBinds revDs (FunBind l ims1@(InfixMatch _ _ name _ _ _:_):ds1) = + mergeInfix ims1 ds1 l + where + mergeInfix ims' (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_):ds) l + | name' =~= name = + mergeInfix (ims++ims') ds (loc <++> l) + mergeInfix ms' ds l = mergeFunBinds (FunBind l ms':revDs) ds mergeFunBinds revDs (d:ds) = mergeFunBinds (d:revDs) ds checkRevClsDecls :: [ClassDecl L] -> P [ClassDecl L] @@ -796,6 +803,13 @@ -- `atSrcLoc` loc else mergeMatches (ms++ms') ds (loc <++> l) mergeMatches ms' ds l = mergeClsFunBinds (ClsDecl l (FunBind l ms'):revDs) ds + mergeClsFunBinds revDs (ClsDecl l (FunBind _ ims1@(InfixMatch _ _ name _ _ _:_)):ds1) = + mergeInfix ims1 ds1 l + where + mergeInfix ims' (ClsDecl _ (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_)):ds) l + | name' =~= name = + mergeInfix (ims++ims') ds (loc <++> l) + mergeMatches ms' ds l = mergeClsFunBinds (ClsDecl l (FunBind l ms'):revDs) ds mergeClsFunBinds revDs (d:ds) = mergeClsFunBinds (d:revDs) ds checkRevInstDecls :: [InstDecl L] -> P [InstDecl L] @@ -813,6 +827,13 @@ then fail ("arity mismatch for '" ++ prettyPrint name ++ "'") -- `atSrcLoc` loc else mergeMatches (ms++ms') ds (loc <++> l) + mergeMatches ms' ds l = mergeInstFunBinds (InsDecl l (FunBind l ms'):revDs) ds + mergeInstFunBinds revDs (InsDecl l (FunBind _ ims1@(InfixMatch _ _ name _ _ _:_)):ds1) = + mergeInfix ims1 ds1 l + where + mergeInfix ims' (InsDecl _ (FunBind _ ims@(InfixMatch loc _ name' _ _ _:_)):ds) l + | name' =~= name = + mergeMatches (ims++ims') ds (loc <++> l) mergeMatches ms' ds l = mergeInstFunBinds (InsDecl l (FunBind l ms'):revDs) ds mergeInstFunBinds revDs (d:ds) = mergeInstFunBinds (d:revDs) ds diff --git a/src/Language/Haskell/Exts/SrcLoc.hs b/src/Language/Haskell/Exts/SrcLoc.hs --- a/src/Language/Haskell/Exts/SrcLoc.hs +++ b/src/Language/Haskell/Exts/SrcLoc.hs @@ -50,6 +50,16 @@ deriving (Eq,Ord,Show) #endif + +-- | Returns 'srcSpanStartLine' and 'srcSpanStartColumn' in a pair. +srcSpanStart :: SrcSpan -> (Int,Int) +srcSpanStart x = (srcSpanStartLine x, srcSpanStartColumn x) + +-- | Returns 'srcSpanEndLine' and 'srcSpanEndColumn' in a pair. +srcSpanEnd :: SrcSpan -> (Int,Int) +srcSpanEnd x = (srcSpanEndLine x, srcSpanEndColumn x) + + -- | Combine two locations in the source to denote a span. mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan mkSrcSpan (SrcLoc fn sl sc) (SrcLoc _ el ec) = SrcSpan fn sl sc el ec @@ -61,6 +71,7 @@ mergeSrcSpan (SrcSpan fn sl sc _ _) (SrcSpan _ _ _ el ec) = SrcSpan fn sl sc el ec -- | Test if a given span starts and ends at the same location. +isNullSpan :: SrcSpan -> Bool isNullSpan ss = srcSpanStartLine ss == srcSpanEndLine ss && srcSpanStartColumn ss >= srcSpanEndColumn ss