haskell-src-exts 1.3.0 → 1.3.1

raw patch · 9 files changed

+211/−13 lines, 9 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• dist/build/Language/Haskell/Exts/InternalParser.hs +6/−4
• haskell-src-exts.cabal +1/−1
• src/Language/Haskell/Exts/Annotated/ExactPrint.hs +4/−1
• src/Language/Haskell/Exts/Annotated/Syntax.hs +6/−0
• src/Language/Haskell/Exts/Comments.hs +1/−0
• src/Language/Haskell/Exts/InternalParser.ly +6/−4
• src/Language/Haskell/Exts/Lexer.hs +155/−3
• src/Language/Haskell/Exts/ParseUtils.hs +21/−0
• src/Language/Haskell/Exts/SrcLoc.hs +11/−0

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

@@ -1,5 +1,5 @@ Name:                   haskell-src-exts-Version:                1.3.0+Version:                1.3.1 License:                BSD3 License-File:           LICENSE Author:                 Niklas Broberg

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

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

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

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

@@ -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     -> "</"+  XEmptyTagClose    -> "/>"+  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"

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

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