curry-base 1.0.0 → 1.1.0

raw patch · 25 files changed

+2887/−828 lines, 25 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• curry-base.cabal +5/−2
• src/Curry/Base/Ident.hs +83/−42
• src/Curry/Base/LLParseComb.hs +16/−2
• src/Curry/Base/Message.hs +5/−1
• src/Curry/Base/Position.hs +5/−1
• src/Curry/Base/Pretty.hs +4/−0
• src/Curry/Base/Span.hs +22/−2
• src/Curry/Base/SpanInfo.hs +101/−0
• src/Curry/CondCompile/Type.hs +5/−0
• src/Curry/Files/Filenames.hs +37/−3
• src/Curry/FlatCurry/Annotated/Goodies.hs +12/−2
• src/Curry/FlatCurry/Annotated/Type.hs +17/−1
• src/Curry/FlatCurry/Annotated/Typing.hs +0/−36
• src/Curry/FlatCurry/Typeable.hs +22/−0
• src/Curry/FlatCurry/Typed/Goodies.hs +661/−0
• src/Curry/FlatCurry/Typed/Type.hs +83/−0
• src/Curry/Syntax/Extension.hs +2/−2
• src/Curry/Syntax/InterfaceEquivalence.hs +15/−15
• src/Curry/Syntax/Lexer.hs +8/−2
• src/Curry/Syntax/Parser.hs +605/−293
• src/Curry/Syntax/Pretty.hs +72/−65
• src/Curry/Syntax/ShowModule.hs +212/−134
• src/Curry/Syntax/Type.hs +805/−168
• src/Curry/Syntax/Utils.hs +85/−57

@@ -1,6 +1,11 @@ Change log for curry-base ========================= +Version (1.1.0)+===================================++  * Added SpanInfos to AST+ Version (1.0.0) =============== 

@@ -1,5 +1,5 @@ Name:          curry-base-Version:       1.0.0+Version:       1.1.0 Cabal-Version: >= 1.10 Synopsis:      Functions for manipulating Curry programs Description:   This package serves as a foundation for Curry compilers.@@ -64,6 +64,7 @@     Curry.Base.Position     Curry.Base.Pretty     Curry.Base.Span+    Curry.Base.SpanInfo     Curry.CondCompile.Parser     Curry.CondCompile.Transform     Curry.CondCompile.Type@@ -76,9 +77,11 @@     Curry.FlatCurry.InterfaceEquivalence     Curry.FlatCurry.Pretty     Curry.FlatCurry.Type+    Curry.FlatCurry.Typeable     Curry.FlatCurry.Annotated.Goodies     Curry.FlatCurry.Annotated.Type-    Curry.FlatCurry.Annotated.Typing+    Curry.FlatCurry.Typed.Goodies+    Curry.FlatCurry.Typed.Type     Curry.Syntax     Curry.Syntax.Extension     Curry.Syntax.InterfaceEquivalence

@@ -21,21 +21,21 @@      Qualified identifiers may optionally be prefixed by a module name. -}-+{-# LANGUAGE CPP #-} module Curry.Base.Ident   ( -- * Module identifiers     ModuleIdent (..), mkMIdent, moduleName, escModuleName-  , fromModuleName, isValidModuleName, addPositionModuleIdent+  , fromModuleName, isValidModuleName, addPositionModuleIdent, mIdentLength      -- * Local identifiers   , Ident (..), mkIdent, showIdent, escName, identSupply   , globalScope, hasGlobalScope, isRenamed, renameIdent, unRenameIdent-  , updIdentName, addPositionIdent, isInfixOp+  , updIdentName, addPositionIdent, isInfixOp, identLength      -- * Qualified identifiers-  , QualIdent (..), qualName, escQualName, qidPosition, isQInfixOp, qualify+  , QualIdent (..), qualName, escQualName, isQInfixOp, qualify   , qualifyWith, qualQualify, qualifyLike, isQualified, unqualify, qualUnqualify-  , localIdent, isLocalIdent, updQualIdent+  , localIdent, isLocalIdent, updQualIdent, qIdentLength      -- * Predefined simple identifiers     -- ** Identifiers for modules@@ -86,12 +86,18 @@   , renameLabel, mkLabelIdent   ) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import Data.Char           (isAlpha, isAlphaNum) import Data.Function       (on) import Data.List           (intercalate, isInfixOf, isPrefixOf) import Data.Maybe          (isJust, fromMaybe)  import Curry.Base.Position+import Curry.Base.Span hiding (file)+import Curry.Base.SpanInfo import Curry.Base.Pretty  -- ---------------------------------------------------------------------------@@ -100,7 +106,7 @@  -- | Module identifier data ModuleIdent = ModuleIdent-  { midPosition   :: Position -- ^ source code 'Position'+  { midSpanInfo   :: SpanInfo -- ^ source code 'SpanInfo'   , midQualifiers :: [String] -- ^ hierarchical idenfiers   } deriving (Read, Show) @@ -110,17 +116,27 @@ instance Ord ModuleIdent where   compare = compare `on` midQualifiers +instance HasSpanInfo ModuleIdent where+  getSpanInfo = midSpanInfo+  setSpanInfo spi a = a { midSpanInfo = spi }+  updateEndPos i =+    setEndPosition (incr (getPosition i) (mIdentLength i - 1)) i+ instance HasPosition ModuleIdent where-  getPosition = midPosition-  setPosition = addPositionModuleIdent+  getPosition = getStartPosition+  setPosition = setStartPosition  instance Pretty ModuleIdent where   pPrint = hcat . punctuate dot . map text . midQualifiers +mIdentLength :: ModuleIdent -> Int+mIdentLength a = length (concat (midQualifiers a))+               + length (midQualifiers a)+ -- |Construct a 'ModuleIdent' from a list of 'String's forming the --  the hierarchical module name. mkMIdent :: [String] -> ModuleIdent-mkMIdent = ModuleIdent NoPos+mkMIdent = ModuleIdent NoSpanInfo  -- |Retrieve the hierarchical name of a module moduleName :: ModuleIdent -> String@@ -132,7 +148,7 @@  -- |Add a source code 'Position' to a 'ModuleIdent' addPositionModuleIdent :: Position -> ModuleIdent -> ModuleIdent-addPositionModuleIdent pos mi = mi { midPosition = pos }+addPositionModuleIdent = setPosition  -- |Check whether a 'String' is a valid module name. --@@ -175,7 +191,7 @@  -- |Simple identifier data Ident = Ident-  { idPosition :: Position -- ^ Source code 'Position'+  { idSpanInfo :: SpanInfo -- ^ Source code 'SpanInfo'   , idName     :: String   -- ^ Name of the identifier   , idUnique   :: Integer  -- ^ Unique number of the identifier   } deriving (Read, Show)@@ -186,21 +202,32 @@ instance Ord Ident where   Ident _ m i `compare` Ident _ n j = (m, i) `compare` (n, j) +instance HasSpanInfo Ident where+  getSpanInfo = idSpanInfo+  setSpanInfo spi a = a { idSpanInfo = spi }+  updateEndPos i@(Ident (SpanInfo _ [_,ss]) _ _) =+    setEndPosition (end ss) i+  updateEndPos i =+    setEndPosition (incr (getPosition i) (identLength i - 1)) i+ instance HasPosition Ident where-  getPosition = idPosition-  setPosition = addPositionIdent+  getPosition = getStartPosition+  setPosition = setStartPosition  instance Pretty Ident where   pPrint (Ident _ x n) | n == globalScope = text x                        | otherwise        = text x <> dot <> integer n +identLength :: Ident -> Int+identLength a = length (idName a)+ -- |Global scope for renaming globalScope :: Integer globalScope = 0  -- |Construct an 'Ident' from a 'String' mkIdent :: String -> Ident-mkIdent x = Ident NoPos x globalScope+mkIdent x = Ident NoSpanInfo x globalScope  -- |Infinite list of different 'Ident's identSupply :: [Ident]@@ -239,8 +266,7 @@  -- |Add a 'Position' to an 'Ident' addPositionIdent :: Position -> Ident -> Ident-addPositionIdent pos      (Ident NoPos x n) = Ident pos x n-addPositionIdent pos      (Ident _     x n) = Ident pos x n+addPositionIdent = setPosition  -- |Check whether an 'Ident' identifies an infix operation isInfixOp :: Ident -> Bool@@ -255,30 +281,45 @@  -- |Qualified identifier data QualIdent = QualIdent-  { qidModule :: Maybe ModuleIdent -- ^ optional module identifier-  , qidIdent  :: Ident             -- ^ identifier itself-  } deriving (Eq, Ord, Read, Show)+  { qidSpanInfo :: SpanInfo          -- ^ Source code 'SpanInfo'+  , qidModule   :: Maybe ModuleIdent -- ^ optional module identifier+  , qidIdent    :: Ident             -- ^ identifier itself+  } deriving (Read, Show) +instance Eq QualIdent where+  QualIdent _ m i == QualIdent _ n j = (m, i) == (n, j)++instance Ord QualIdent where+  QualIdent _ m i `compare` QualIdent _ n j = (m, i) `compare` (n, j)++instance HasSpanInfo QualIdent where+  getSpanInfo = qidSpanInfo+  setSpanInfo spi a = a { qidSpanInfo = spi }+  updateEndPos i@(QualIdent (SpanInfo _ [_,ss]) _ _) =+    setEndPosition (end ss) i+  updateEndPos i =+    setEndPosition (incr (getPosition i) (qIdentLength i - 1)) i+ instance HasPosition QualIdent where-  getPosition     = getPosition . qidIdent-  setPosition p q = q { qidIdent = setPosition p $ qidIdent q }+  getPosition = getStartPosition+  setPosition = setStartPosition  instance Pretty QualIdent where   pPrint = text . qualName --- |show function for qualified identifiers+qIdentLength :: QualIdent -> Int+qIdentLength (QualIdent _ (Just m) i) = identLength i + mIdentLength m+qIdentLength (QualIdent _ Nothing  i) = identLength i++-- |show function for qualified identifiers)= qualName :: QualIdent -> String-qualName (QualIdent Nothing  x) = idName x-qualName (QualIdent (Just m) x) = moduleName m ++ "." ++ idName x+qualName (QualIdent _ Nothing  x) = idName x+qualName (QualIdent _ (Just m) x) = moduleName m ++ "." ++ idName x  -- |Show the name of an 'QualIdent' escaped by ticks escQualName :: QualIdent -> String escQualName qn = '`' : qualName qn ++ "'" --- |Retrieve the 'Position' of a 'QualIdent'-qidPosition :: QualIdent -> Position-qidPosition = idPosition . qidIdent- -- |Check whether an 'QualIdent' identifies an infix operation isQInfixOp :: QualIdent -> Bool isQInfixOp = isInfixOp . qidIdent@@ -291,24 +332,25 @@  -- | Convert an 'Ident' to a 'QualIdent' qualify :: Ident -> QualIdent-qualify = QualIdent Nothing+qualify i = QualIdent (getSpanInfo i) Nothing i  -- | Convert an 'Ident' to a 'QualIdent' with a given 'ModuleIdent' qualifyWith :: ModuleIdent -> Ident -> QualIdent-qualifyWith = QualIdent . Just+qualifyWith mid i = updateEndPos $+  QualIdent (fromSrcSpan (getSrcSpan mid)) (Just mid) i  -- | Convert an 'QualIdent' to a new 'QualIdent' with a given 'ModuleIdent'. --   If the original 'QualIdent' already contains an 'ModuleIdent' it --   remains unchanged. qualQualify :: ModuleIdent -> QualIdent -> QualIdent-qualQualify m (QualIdent Nothing x) = QualIdent (Just m) x+qualQualify m (QualIdent _ Nothing x) = qualifyWith m x qualQualify _ x = x  -- |Qualify an 'Ident' with the 'ModuleIdent' of the given 'QualIdent', -- if present. qualifyLike :: QualIdent -> Ident -> QualIdent-qualifyLike (QualIdent Nothing  _) x = qualify x-qualifyLike (QualIdent (Just m) _) x = qualifyWith m x+qualifyLike (QualIdent _ Nothing  _) x = qualify x+qualifyLike (QualIdent _ (Just m) _) x = qualifyWith m x  -- | Check whether a 'QualIdent' contains a 'ModuleIdent' isQualified :: QualIdent -> Bool@@ -322,8 +364,8 @@ --   original 'QualIdent' has no 'ModuleIdent' or a different one, it --   remains unchanged. qualUnqualify :: ModuleIdent -> QualIdent -> QualIdent-qualUnqualify _ qid@(QualIdent Nothing   _) = qid-qualUnqualify m     (QualIdent (Just m') x) = QualIdent m'' x+qualUnqualify _ qid@(QualIdent _   Nothing   _) = qid+qualUnqualify m     (QualIdent spi (Just m') x) = QualIdent spi m'' x   where m'' | m == m'   = Nothing             | otherwise = Just m' @@ -331,8 +373,8 @@ --   'ModuleIdent', i.e. if the 'Ident' is either unqualified or qualified --   with the given 'ModuleIdent'. localIdent :: ModuleIdent -> QualIdent -> Maybe Ident-localIdent _ (QualIdent Nothing   x) = Just x-localIdent m (QualIdent (Just m') x)+localIdent _ (QualIdent _ Nothing   x) = Just x+localIdent m (QualIdent _ (Just m') x)   | m == m'   = Just x   | otherwise = Nothing @@ -343,23 +385,22 @@ -- | Update a 'QualIdent' by applying functions to its components updQualIdent :: (ModuleIdent -> ModuleIdent) -> (Ident -> Ident)              -> QualIdent -> QualIdent-updQualIdent f g (QualIdent m x) = QualIdent (fmap f m) (g x)+updQualIdent f g (QualIdent spi m x) = QualIdent spi (fmap f m) (g x)  -- --------------------------------------------------------------------------- -- A few identifiers are predefined here. -- ---------------------------------------------------------------------------- -- | 'ModuleIdent' for the empty module emptyMIdent :: ModuleIdent-emptyMIdent = ModuleIdent NoPos []+emptyMIdent = ModuleIdent NoSpanInfo []  -- | 'ModuleIdent' for the main module mainMIdent :: ModuleIdent-mainMIdent = ModuleIdent NoPos ["main"]+mainMIdent = ModuleIdent NoSpanInfo ["main"]  -- | 'ModuleIdent' for the Prelude preludeMIdent :: ModuleIdent-preludeMIdent = ModuleIdent NoPos ["Prelude"]+preludeMIdent = ModuleIdent NoSpanInfo ["Prelude"]  -- --------------------------------------------------------------------------- -- Identifiers for types

@@ -31,12 +31,13 @@   , fullParser, prefixParser      -- * Basic parsers-  , position, succeed, failure, symbol+  , position, spanPosition, succeed, failure, symbol      -- *  parser combinators   , (<?>), (<|>), (<|?>), (<*>), (<\>), (<\\>)   , (<$>), (<$->), (<*->), (<-*>), (<**>), (<??>), (<.>)   , opt, choice, flag, optional, option, many, many1, sepBy, sepBy1+  , sepBySp, sepBy1Sp   , chainr, chainr1, chainl, chainl1, between, ops      -- * Layout combinators@@ -53,7 +54,7 @@  import Curry.Base.LexComb import Curry.Base.Position-import Curry.Base.Span (span2Pos)+import Curry.Base.Span (span2Pos, Span, startCol, setDistance)  infixl 5 <\>, <\\> infixl 4 <$->, <*->, <-*>, <**>, <??>, <.>@@ -136,6 +137,10 @@ position = Parser (Just p) Map.empty   where p success _ sp = success (span2Pos sp) sp +spanPosition :: Symbol s => Parser a s Span+spanPosition = Parser (Just p) Map.empty+  where p success _ sp s = success (setDistance sp (dist (startCol sp) s)) sp s+ -- |Always succeeding parser succeed :: b -> Parser a s b succeed x = Parser (Just p) Map.empty@@ -304,6 +309,15 @@ -- |Parse a non-empty list with is separated by a seperator sepBy1 :: Symbol s => Parser a s b -> Parser a s c -> Parser a s [b] p `sepBy1` q = (:) <$> p <*> many (q <-*> p)++-- |Parse a list with is separated by a seperator+sepBySp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span])+p `sepBySp` q = p `sepBy1Sp` q `opt` ([], [])++sepBy1Sp :: Symbol s => Parser a s b -> Parser a s c -> Parser a s ([b], [Span])+p `sepBy1Sp` q = comb <$> p <*> many ((,) <$> spanPosition <*-> q <*> p)+  where comb x xs = let (ss, ys) = unzip xs+                    in (x:ys,ss)  -- |@chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. -- Returns a value produced by a *right* associative application of all

@@ -12,11 +12,15 @@     The type message represents a compiler message with an optional source     code position. -}-+{-# LANGUAGE CPP #-} module Curry.Base.Message   ( Message (..), message, posMessage, showWarning, showError   , ppMessage, ppWarning, ppError, ppMessages   ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif  import Data.Maybe          (fromMaybe) 

@@ -13,13 +13,17 @@     of a filename, a line number, and a column number. A tab stop is assumed     at every eighth column. -}-+{-# LANGUAGE CPP #-} module Curry.Base.Position   ( -- * Source code position     HasPosition (..), Position (..), (@>)   , showPosition, ppPosition, ppLine, showLine   , first, next, incr, tab, tabWidth, nl   ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif  import System.FilePath 

@@ -19,6 +19,10 @@   , module Text.PrettyPrint   ) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import Text.PrettyPrint  -- | Pretty printing class.

@@ -17,12 +17,16 @@     the abstract syntax tree by argument positions, which is used for     debugging purposes. -}-+{-# LANGUAGE CPP #-} module Curry.Base.Span where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import System.FilePath -import Curry.Base.Position+import Curry.Base.Position hiding (file) import Curry.Base.Pretty  data Span@@ -39,6 +43,13 @@ instance Pretty Span where   pPrint = ppSpan +instance HasPosition Span where+  setPosition p NoSpan       = Span "" p NoPos+  setPosition p (Span f _ e) = Span f p e++  getPosition NoSpan       = NoPos+  getPosition (Span _ p _) = p+ -- |Show a 'Span' as a 'String' showSpan :: Span -> String showSpan = show . ppSpan@@ -81,6 +92,12 @@ span2Pos (Span _ p _) = p span2Pos NoSpan       = NoPos +combineSpans :: Span -> Span -> Span+combineSpans sp1 sp2 = Span f s e+  where s = start sp1+        e = end sp2+        f = file sp1+ -- |First position after the next tabulator tabSpan :: Span -> Span tabSpan (Span fn s e) = Span fn (tab s) (tab e)@@ -90,6 +107,9 @@ nlSpan :: Span -> Span nlSpan (Span fn s e) = Span fn (nl s) (nl e) nlSpan sp            = sp++addSpan :: Span -> (a, [Span]) -> (a, [Span])+addSpan sp (a, ss) = (a, sp:ss)  -- |Distance of a span, i.e. the line and column distance between start -- and end position

@@ -0,0 +1,101 @@+{- |+    Module      :  $Header$+    Description :  SpansInfo for entities+    Copyright   :  (c) 2017 Kai-Oliver Prott+    License     :  BSD-3-clause++    Maintainer  :  fte@informatik.uni-kiel.de+    Stability   :  experimental+    Portability :  portable++    This module implements a data type for span information for entities from a+    source file and function to operate on them. A span info consists of the+    span of the entity and a list of sub-spans whith additional information+    about location of keywords, e.g.+-}+module Curry.Base.SpanInfo+  ( SpanInfo(..), HasSpanInfo(..)+  , fromSrcSpan, fromSrcSpanBoth, getSrcSpan, setSrcSpan+  , fromSrcInfoPoints, getSrcInfoPoints, setSrcInfoPoints+  , getStartPosition, getSrcSpanEnd, setStartPosition, setEndPosition+  , spanInfo2Pos+  ) where++import Curry.Base.Position+import Curry.Base.Span++data SpanInfo = SpanInfo+    { srcSpan        :: Span+    , srcInfoPoints  :: [Span]+    }+    | NoSpanInfo+  deriving (Eq, Read, Show)++class HasPosition a => HasSpanInfo a where++  getSpanInfo :: a -> SpanInfo++  setSpanInfo :: SpanInfo -> a -> a++  updateEndPos :: a -> a+  updateEndPos = id++instance HasSpanInfo SpanInfo where+  getSpanInfo = id+  setSpanInfo = const++instance HasPosition SpanInfo where+  getPosition = getStartPosition+  setPosition = setStartPosition++fromSrcSpan :: Span -> SpanInfo+fromSrcSpan sp = SpanInfo sp []++fromSrcSpanBoth :: Span -> SpanInfo+fromSrcSpanBoth sp = SpanInfo sp [sp]++getSrcSpan :: HasSpanInfo a => a -> Span+getSrcSpan a = case getSpanInfo a of+  NoSpanInfo   -> NoSpan+  SpanInfo s _ -> s++setSrcSpan :: HasSpanInfo a => Span -> a -> a+setSrcSpan s a = case getSpanInfo a of+  NoSpanInfo     -> setSpanInfo (SpanInfo s [])  a+  SpanInfo _ inf -> setSpanInfo (SpanInfo s inf) a++fromSrcInfoPoints :: [Span] -> SpanInfo+fromSrcInfoPoints = SpanInfo NoSpan++getSrcInfoPoints :: HasSpanInfo a => a -> [Span]+getSrcInfoPoints a = case getSpanInfo a of+  NoSpanInfo    -> []+  SpanInfo _ xs -> xs++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++getStartPosition :: HasSpanInfo a => a -> Position+getStartPosition a =  case getSrcSpan a of+  NoSpan     -> NoPos+  Span _ s _ -> s++getSrcSpanEnd :: HasSpanInfo a => a -> Position+getSrcSpanEnd a = case getSpanInfo a of+  NoSpanInfo     -> NoPos+  (SpanInfo s _) -> end s++setStartPosition :: HasSpanInfo a => Position -> a -> a+setStartPosition p a = case getSrcSpan a of+  NoSpan       -> setSrcSpan (Span "" p NoPos) a+  (Span f _ e) -> setSrcSpan (Span f  p     e) a++setEndPosition :: HasSpanInfo a => Position -> a -> a+setEndPosition e a = case getSrcSpan a of+  NoSpan       -> setSrcSpan (Span "" NoPos e) a+  (Span f p _) -> setSrcSpan (Span f  p     e) a++spanInfo2Pos :: HasSpanInfo a => a -> Position+spanInfo2Pos = getStartPosition

@@ -11,9 +11,14 @@      TODO -}+{-# LANGUAGE CPP #-} module Curry.CondCompile.Type   ( Program, Stmt (..), Else (..), Elif (..), Cond (..), Op (..)   ) where++#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif  import Curry.Base.Pretty 

@@ -3,9 +3,10 @@     Description :  File names for several intermediate file formats.     Copyright   :  (c) 2009        Holger Siegel                        2013 - 2014 Björn Peemöller+                       2018        Kai-Oliver Prott     License     :  BSD-3-clause -    Maintainer  :  bjp@informatik.uni-kiel.de+    Maintainer  :  fte@informatik.uni-kiel.de     Stability   :  experimental     Portability :  portable @@ -37,8 +38,9 @@   , sourceRepExt, sourceExts, moduleExts      -- * Functions for computing file names-  , interfName, typedFlatName, flatName, flatIntName-  , acyName, uacyName, sourceRepName, tokensName, htmlName+  , interfName, typedFlatName, typeAnnFlatName, flatName, flatIntName+  , acyName, uacyName, sourceRepName, tokensName, commentsName+  , astName, shortASTName, htmlName   ) where  import System.FilePath@@ -152,6 +154,10 @@ typedFlatExt :: String typedFlatExt = ".tfcy" +-- |Filename extension for type-annotated flat-curry files+typeAnnFlatExt :: String+typeAnnFlatExt = ".tafcy"+ -- |Filename extension for flat-curry files flatExt :: String flatExt = ".fcy"@@ -176,6 +182,18 @@ tokensExt :: String tokensExt = ".tokens" +-- |Filename extension for comment token files+commentsExt :: String+commentsExt = ".cycom"++-- |Filename extension for AST files+astExt :: String+astExt = ".ast"++-- |Filename extension for shortened AST files+shortASTExt :: String+shortASTExt = ".sast"+ -- --------------------------------------------------------------------------- -- Computation of file names for a given source file -- ---------------------------------------------------------------------------@@ -188,6 +206,10 @@ typedFlatName :: FilePath -> FilePath typedFlatName = replaceExtensionWith typedFlatExt +-- |Compute the filename of the typed flat curry file for a source file+typeAnnFlatName :: FilePath -> FilePath+typeAnnFlatName = replaceExtensionWith typeAnnFlatExt+ -- |Compute the filename of the flat curry file for a source file flatName :: FilePath -> FilePath flatName = replaceExtensionWith flatExt@@ -211,6 +233,18 @@ -- |Compute the filename of the tokens file for a source file tokensName :: FilePath -> FilePath tokensName = replaceExtensionWith tokensExt++-- |Compute the filename of the comment tokens file for a source file+commentsName :: FilePath -> FilePath+commentsName = replaceExtensionWith commentsExt++-- |Compute the filename of the ast file for a source file+astName :: FilePath -> FilePath+astName = replaceExtensionWith astExt++-- |Compute the filename of the ast file for a source file+shortASTName :: FilePath -> FilePath+shortASTName = replaceExtensionWith shortASTExt  -- |Compute the filename of the HTML file for a source file htmlName :: ModuleIdent -> String

@@ -4,11 +4,21 @@     Copyright   : (c) 2016 - 2017 Finn Teegen     License     : BSD-3-clause -    Maintainer  : bjp@informatik.uni-kiel.de+    Maintainer  : fte@informatik.uni-kiel.de     Stability   : experimental     Portability : portable -    TODO+    This library provides selector functions, test and update operations+    as well as some useful auxiliary functions for AnnotatedFlatCurry data terms.+    Most of the provided functions are based on general transformation+    functions that replace constructors with user-defined+    functions. For recursive datatypes the transformations are defined+    inductively over the term structure. This is quite usual for+    transformations on AnnotatedFlatCurry terms,+    so the provided functions can be used to implement specific transformations+    without having to explicitly state the recursion. Essentially, the tedious+    part of such transformations - descend in fairly complex term structures -+    is abstracted away, which hopefully makes the code more clear and brief. -}  module Curry.FlatCurry.Annotated.Goodies

@@ -4,7 +4,7 @@     Copyright   : (c) 2016 - 2017 Finn Teegen     License     : BSD-3-clause -    Maintainer  : bjp@informatik.uni-kiel.de+    Maintainer  : fte@informatik.uni-kiel.de     Stability   : experimental     Portability : portable @@ -13,9 +13,11 @@  module Curry.FlatCurry.Annotated.Type   ( module Curry.FlatCurry.Annotated.Type+  , module Curry.FlatCurry.Typeable   , module Curry.FlatCurry.Type   ) where +import Curry.FlatCurry.Typeable import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex                             , TypeDecl (..), OpDecl (..), Fixity (..)                             , TypeExpr (..), ConsDecl (..)@@ -51,3 +53,17 @@   = APattern  a (QName, a) [(VarIndex, a)]   | ALPattern a Literal   deriving (Eq, Read, Show)++instance Typeable a => Typeable (AExpr a) where+  typeOf (AVar a _) = typeOf a+  typeOf (ALit a _) = typeOf a+  typeOf (AComb a _ _ _) = typeOf a+  typeOf (ALet a _ _) = typeOf a+  typeOf (AFree a _ _) = typeOf a+  typeOf (AOr a _ _) = typeOf a+  typeOf (ACase a _ _ _) = typeOf a+  typeOf (ATyped a _ _) = typeOf a++instance Typeable a => Typeable (APattern a) where+  typeOf (APattern a _ _) = typeOf a+  typeOf (ALPattern a _) = typeOf a

@@ -1,36 +0,0 @@-{- |-    Module      :  $Header$-    Description :  TODO-    Copyright   :  (c)        2017 Finn Teegen-    License     :  BSD-3-clause--    Maintainer  :  bjp@informatik.uni-kiel.de-    Stability   :  experimental-    Portability :  portable--   TODO--}--module Curry.FlatCurry.Annotated.Typing (Typeable(..)) where--import Curry.FlatCurry.Annotated.Type--class Typeable a where-  typeOf :: a -> TypeExpr--instance Typeable TypeExpr where-  typeOf = id--instance Typeable a => Typeable (AExpr a) where-  typeOf (AVar a _) = typeOf a-  typeOf (ALit a _) = typeOf a-  typeOf (AComb a _ _ _) = typeOf a-  typeOf (ALet a _ _) = typeOf a-  typeOf (AFree a _ _) = typeOf a-  typeOf (AOr a _ _) = typeOf a-  typeOf (ACase a _ _ _) = typeOf a-  typeOf (ATyped a _ _) = typeOf a--instance Typeable a => Typeable (APattern a) where-  typeOf (APattern a _ _) = typeOf a-  typeOf (ALPattern a _) = typeOf a

@@ -0,0 +1,22 @@+{- |+    Module      : $Header$+    Description : Typeclass of Typeable entities+    Copyright   : (c) 2018        Kai-Oliver Prott+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This module defines a Typeclass for easy access to the type of entites+-}++module Curry.FlatCurry.Typeable (Typeable(..)) where++import Curry.FlatCurry.Type (TypeExpr)++class Typeable a where+  typeOf :: a -> TypeExpr++instance Typeable TypeExpr where+  typeOf = id

@@ -0,0 +1,661 @@+{- |+    Module      : $Header$+    Description : Utility functions for working with TypedFlatCurry.+    Copyright   : (c) 2016 - 2017 Finn Teegen+                      2018        Kai-Oliver Prott+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable++    This library provides selector functions, test and update operations+    as well as some useful auxiliary functions for TypedFlatCurry data terms.+    Most of the provided functions are based on general transformation+    functions that replace constructors with user-defined+    functions. For recursive datatypes the transformations are defined+    inductively over the term structure. This is quite usual for+    transformations on TypedFlatCurry terms,+    so the provided functions can be used to implement specific transformations+    without having to explicitly state the recursion. Essentially, the tedious+    part of such transformations - descend in fairly complex term structures -+    is abstracted away, which hopefully makes the code more clear and brief.+-}++module Curry.FlatCurry.Typed.Goodies+  ( module Curry.FlatCurry.Typed.Goodies+  , module Curry.FlatCurry.Goodies+  ) where++import Curry.FlatCurry.Goodies ( Update+                               , trType, typeName, typeVisibility, typeParams+                               , typeConsDecls, typeSyn, isTypeSyn+                               , isDataTypeDecl, isExternalType, isPublicType+                               , updType, updTypeName, updTypeVisibility+                               , updTypeParams, updTypeConsDecls, updTypeSynonym+                               , updQNamesInType+                               , trCons, consName, consArity, consVisibility+                               , isPublicCons, consArgs, updCons, updConsName+                               , updConsArity, updConsVisibility, updConsArgs+                               , updQNamesInConsDecl+                               , tVarIndex, domain, range, tConsName, tConsArgs+                               , trTypeExpr, isTVar, isTCons, isFuncType+                               , updTVars, updTCons, updFuncTypes, argTypes+                               , typeArity, resultType, allVarsInTypeExpr+                               , allTypeCons, rnmAllVarsInTypeExpr+                               , updQNamesInTypeExpr+                               , trOp, opName, opFixity, opPrecedence, updOp+                               , updOpName, updOpFixity, updOpPrecedence+                               , trCombType, isCombTypeFuncCall+                               , isCombTypeFuncPartCall, isCombTypeConsCall+                               , isCombTypeConsPartCall+                               , isPublic+                               )++import Curry.FlatCurry.Typed.Type++-- TProg ----------------------------------------------------------------------++-- |transform program+trTProg :: (String -> [String] -> [TypeDecl] -> [TFuncDecl] -> [OpDecl] -> b)+        -> TProg -> b+trTProg prog (TProg name imps types funcs ops) = prog name imps types funcs ops++-- Selectors++-- |get name from program+tProgName :: TProg -> String+tProgName = trTProg (\name _ _ _ _ -> name)++-- |get imports from program+tProgImports :: TProg -> [String]+tProgImports = trTProg (\_ imps _ _ _ -> imps)++-- |get type declarations from program+tProgTypes :: TProg -> [TypeDecl]+tProgTypes = trTProg (\_ _ types _ _ -> types)++-- |get functions from program+tProgTFuncs :: TProg -> [TFuncDecl]+tProgTFuncs = trTProg (\_ _ _ funcs _ -> funcs)++-- |get infix operators from program+tProgOps :: TProg -> [OpDecl]+tProgOps = trTProg (\_ _ _ _ ops -> ops)++-- Update Operations++-- |update program+updTProg :: (String -> String) ->+            ([String] -> [String]) ->+            ([TypeDecl] -> [TypeDecl]) ->+            ([TFuncDecl] -> [TFuncDecl]) ->+            ([OpDecl] -> [OpDecl]) -> TProg -> TProg+updTProg fn fi ft ff fo = trTProg prog+ where+  prog name imps types funcs ops+    = TProg (fn name) (fi imps) (ft types) (ff funcs) (fo ops)++-- |update name of program+updTProgName :: Update TProg String+updTProgName f = updTProg f id id id id++-- |update imports of program+updTProgImports :: Update TProg [String]+updTProgImports f = updTProg id f id id id++-- |update type declarations of program+updTProgTypes :: Update TProg [TypeDecl]+updTProgTypes f = updTProg id id f id id++-- |update functions of program+updTProgTFuncs :: Update TProg [TFuncDecl]+updTProgTFuncs f = updTProg id id id f id++-- |update infix operators of program+updTProgOps :: Update TProg [OpDecl]+updTProgOps = updTProg id id id id++-- Auxiliary Functions++-- |get all program variables (also from patterns)+allVarsInTProg :: TProg -> [(VarIndex, TypeExpr)]+allVarsInTProg = concatMap allVarsInTFunc . tProgTFuncs++-- |lift transformation on expressions to program+updTProgTExps :: Update TProg TExpr+updTProgTExps = updTProgTFuncs . map . updTFuncBody++-- |rename programs variables+rnmAllVarsInTProg :: Update TProg VarIndex+rnmAllVarsInTProg = updTProgTFuncs . map . rnmAllVarsInTFunc++-- |update all qualified names in program+updQNamesInTProg :: Update TProg QName+updQNamesInTProg f = updTProg id id+  (map (updQNamesInType f)) (map (updQNamesInTFunc f)) (map (updOpName f))++-- |rename program (update name of and all qualified names in program)+rnmTProg :: String -> TProg -> TProg+rnmTProg name p = updTProgName (const name) (updQNamesInTProg rnm p)+ where+  rnm (m, n) | m == tProgName p = (name, n)+             | otherwise = (m, n)++-- TFuncDecl ------------------------------------------------------------------++-- |transform function+trTFunc :: (QName -> Int -> Visibility -> TypeExpr -> TRule -> b) -> TFuncDecl -> b+trTFunc func (TFunc name arity vis t rule) = func name arity vis t rule++-- Selectors++-- |get name of function+tFuncName :: TFuncDecl -> QName+tFuncName = trTFunc (\name _ _ _ _ -> name)++-- |get arity of function+tFuncArity :: TFuncDecl -> Int+tFuncArity = trTFunc (\_ arity _ _ _ -> arity)++-- |get visibility of function+tFuncVisibility :: TFuncDecl -> Visibility+tFuncVisibility = trTFunc (\_ _ vis _ _ -> vis)++-- |get type of function+tFuncType :: TFuncDecl -> TypeExpr+tFuncType = trTFunc (\_ _ _ t _ -> t)++-- |get rule of function+tFuncTRule :: TFuncDecl -> TRule+tFuncTRule = trTFunc (\_ _ _ _ rule -> rule)++-- Update Operations++-- |update function+updTFunc :: (QName -> QName) ->+            (Int -> Int) ->+            (Visibility -> Visibility) ->+            (TypeExpr -> TypeExpr) ->+            (TRule -> TRule) -> TFuncDecl -> TFuncDecl+updTFunc fn fa fv ft fr = trTFunc func+ where+  func name arity vis t rule+    = TFunc (fn name) (fa arity) (fv vis) (ft t) (fr rule)++-- |update name of function+updTFuncName :: Update TFuncDecl QName+updTFuncName f = updTFunc f id id id id++-- |update arity of function+updTFuncArity :: Update TFuncDecl Int+updTFuncArity f = updTFunc id f id id id++-- |update visibility of function+updTFuncVisibility :: Update TFuncDecl Visibility+updTFuncVisibility f = updTFunc id id f id id++-- |update type of function+updFuncType :: Update TFuncDecl TypeExpr+updFuncType f = updTFunc id id id f id++-- |update rule of function+updTFuncTRule :: Update TFuncDecl TRule+updTFuncTRule = updTFunc id id id id++-- Auxiliary Functions++-- |is function public?+isPublicTFunc :: TFuncDecl -> Bool+isPublicTFunc = isPublic . tFuncVisibility++-- |is function externally defined?+isExternal :: TFuncDecl -> Bool+isExternal = isTRuleExternal . tFuncTRule++-- |get variable names in a function declaration+allVarsInTFunc :: TFuncDecl -> [(VarIndex, TypeExpr)]+allVarsInTFunc = allVarsInTRule . tFuncTRule++-- |get arguments of function, if not externally defined+tFuncArgs :: TFuncDecl -> [(VarIndex, TypeExpr)]+tFuncArgs = tRuleArgs . tFuncTRule++-- |get body of function, if not externally defined+tFuncBody :: TFuncDecl -> TExpr+tFuncBody = tRuleBody . tFuncTRule++-- |get the right-hand-sides of a 'FuncDecl'+tFuncRHS :: TFuncDecl -> [TExpr]+tFuncRHS f | not (isExternal f) = orCase (tFuncBody f)+           | otherwise = []+ where+  orCase e+    | isTOr e = concatMap orCase (orExps e)+    | isTCase e = concatMap (orCase . tBranchTExpr) (caseBranches e)+    | otherwise = [e]++-- |rename all variables in function+rnmAllVarsInTFunc :: Update TFuncDecl VarIndex+rnmAllVarsInTFunc = updTFunc id id id id . rnmAllVarsInTRule++-- |update all qualified names in function+updQNamesInTFunc :: Update TFuncDecl QName+updQNamesInTFunc f = updTFunc f id id (updQNamesInTypeExpr f) (updQNamesInTRule f)++-- |update arguments of function, if not externally defined+updTFuncArgs :: Update TFuncDecl [(VarIndex, TypeExpr)]+updTFuncArgs = updTFuncTRule . updTRuleArgs++-- |update body of function, if not externally defined+updTFuncBody :: Update TFuncDecl TExpr+updTFuncBody = updTFuncTRule . updTRuleBody++-- TRule ----------------------------------------------------------------------++-- |transform rule+trTRule :: ([(VarIndex, TypeExpr)] -> TExpr -> b) -> (TypeExpr -> String -> b) -> TRule -> b+trTRule rule _ (TRule args e) = rule args e+trTRule _ ext (TExternal ty s) = ext ty s++-- Selectors++-- |get rules arguments if it's not external+tRuleArgs :: TRule -> [(VarIndex, TypeExpr)]+tRuleArgs = trTRule const undefined++-- |get rules body if it's not external+tRuleBody :: TRule -> TExpr+tRuleBody = trTRule (\_ e -> e) undefined++-- |get rules external declaration+tRuleExtDecl :: TRule -> String+tRuleExtDecl = trTRule undefined (\_ s -> s)++-- Test Operations++-- |is rule external?+isTRuleExternal :: TRule -> Bool+isTRuleExternal = trTRule (\_ _ -> False) (\_ _ -> True)++-- Update Operations++-- |update rule+updTRule :: (TypeExpr -> TypeExpr) ->+            ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) ->+            (TExpr -> TExpr) ->+            (String -> String) -> TRule -> TRule+updTRule fannot fa fe fs = trTRule rule ext+ where+  rule args e = TRule (fa args) (fe e)+  ext ty s = TExternal (fannot ty) (fs s)++-- |update rules TypeExpr+updTRuleType :: Update TRule TypeExpr+updTRuleType f = updTRule f id id id++-- |update rules arguments+updTRuleArgs :: Update TRule [(VarIndex, TypeExpr)]+updTRuleArgs f = updTRule id f id id++-- |update rules body+updTRuleBody :: Update TRule TExpr+updTRuleBody f = updTRule id id f id++-- |update rules external declaration+updTRuleExtDecl :: Update TRule String+updTRuleExtDecl = updTRule id id id++-- Auxiliary Functions++-- |get variable names in a functions rule+allVarsInTRule :: TRule -> [(VarIndex, TypeExpr)]+allVarsInTRule = trTRule (\args body -> args ++ allVars body) (\_ _ -> [])++-- |rename all variables in rule+rnmAllVarsInTRule :: Update TRule VarIndex+rnmAllVarsInTRule f = updTRule id (map (\(a, b) -> (f a, b))) (rnmAllVars f) id++-- |update all qualified names in rule+updQNamesInTRule :: Update TRule QName+updQNamesInTRule = updTRuleBody . updQNames++-- TExpr ----------------------------------------------------------------------++-- Selectors++-- |get internal number of variable+varNr :: TExpr -> VarIndex+varNr (TVarE _ n) = n+varNr _           = error "Curry.FlatCurry.Typed.Goodies.varNr: no variable"++-- |get literal if expression is literal expression+literal :: TExpr -> Literal+literal (TLit _ l) = l+literal _          = error "Curry.FlatCurry.Typed.Goodies.literal: no literal"++-- |get combination type of a combined expression+combType :: TExpr -> CombType+combType (TComb _ ct _ _) = ct+combType _                = error $ "Curry.FlatCurry.Typed.Goodies.combType: " +++                                    "no combined expression"++-- |get name of a combined expression+combName :: TExpr -> QName+combName (TComb _ _ name _) = name+combName _                  = error $ "Curry.FlatCurry.Typed.Goodies.combName: " +++                                      "no combined expression"++-- |get arguments of a combined expression+combArgs :: TExpr -> [TExpr]+combArgs (TComb _ _ _ args) = args+combArgs _                  = error $ "Curry.FlatCurry.Typed.Goodies.combArgs: " +++                                      "no combined expression"++-- |get number of missing arguments if expression is combined+missingCombArgs :: TExpr -> Int+missingCombArgs = missingArgs . combType+  where+  missingArgs :: CombType -> Int+  missingArgs = trCombType 0 id 0 id++-- |get indices of variables in let declaration+letBinds :: TExpr -> [((VarIndex, TypeExpr), TExpr)]+letBinds (TLet vs _) = vs+letBinds _           = error $ "Curry.FlatCurry.Typed.Goodies.letBinds: " +++                               "no let expression"++-- |get body of let declaration+letBody :: TExpr -> TExpr+letBody (TLet _ e) = e+letBody _          = error $ "Curry.FlatCurry.Typed.Goodies.letBody: " +++                             "no let expression"++-- |get variable indices from declaration of free variables+freeVars :: TExpr -> [(VarIndex, TypeExpr)]+freeVars (TFree vs _) = vs+freeVars _            = error $ "Curry.FlatCurry.Typed.Goodies.freeVars: " +++                                "no declaration of free variables"++-- |get expression from declaration of free variables+freeExpr :: TExpr -> TExpr+freeExpr (TFree _ e) = e+freeExpr _           = error $ "Curry.FlatCurry.Typed.Goodies.freeExpr: " +++                               "no declaration of free variables"++-- |get expressions from or-expression+orExps :: TExpr -> [TExpr]+orExps (TOr e1 e2) = [e1, e2]+orExps _           = error $ "Curry.FlatCurry.Typed.Goodies.orExps: " +++                             "no or expression"++-- |get case-type of case expression+caseType :: TExpr -> CaseType+caseType (TCase ct _ _) = ct+caseType _              = error $ "Curry.FlatCurry.Typed.Goodies.caseType: " +++                                  "no case expression"++-- |get scrutinee of case expression+caseExpr :: TExpr -> TExpr+caseExpr (TCase _ e _) = e+caseExpr _             = error $ "Curry.FlatCurry.Typed.Goodies.caseExpr: " +++                                   "no case expression"+++-- |get branch expressions from case expression+caseBranches :: TExpr -> [TBranchExpr]+caseBranches (TCase _ _ bs) = bs+caseBranches _              = error "Curry.FlatCurry.Typed.Goodies.caseBranches: no case expression"++-- Test Operations++-- |is expression a variable?+isTVarE :: TExpr -> Bool+isTVarE e = case e of+  TVarE _ _ -> True+  _ -> False++-- |is expression a literal expression?+isTLit :: TExpr -> Bool+isTLit e = case e of+  TLit _ _ -> True+  _ -> False++-- |is expression combined?+isTComb :: TExpr -> Bool+isTComb e = case e of+  TComb _ _ _ _ -> True+  _ -> False++-- |is expression a let expression?+isTLet :: TExpr -> Bool+isTLet e = case e of+  TLet _ _ -> True+  _ -> False++-- |is expression a declaration of free variables?+isTFree :: TExpr -> Bool+isTFree e = case e of+  TFree _ _ -> True+  _ -> False++-- |is expression an or-expression?+isTOr :: TExpr -> Bool+isTOr e = case e of+  TOr _ _ -> True+  _ -> False++-- |is expression a case expression?+isTCase :: TExpr -> Bool+isTCase e = case e of+  TCase _ _ _ -> True+  _ -> False++-- |transform expression+trTExpr  :: (TypeExpr -> VarIndex -> b)+         -> (TypeExpr -> Literal -> b)+         -> (TypeExpr -> CombType -> QName -> [b] -> b)+         -> ([((VarIndex, TypeExpr), b)] -> b -> b)+         -> ([(VarIndex, TypeExpr)] -> b -> b)+         -> (b -> b -> b)+         -> (CaseType -> b -> [c] -> b)+         -> (TPattern -> b -> c)+         -> (b -> TypeExpr -> b)+         -> TExpr+         -> b+trTExpr var lit comb lt fr oR cas branch typed expr = case expr of+  TVarE ty n            -> var ty n+  TLit ty l             -> lit ty l+  TComb ty ct name args -> comb ty ct name (map f args)+  TLet bs e             -> lt (map (\(v, x) -> (v, f x)) bs) (f e)+  TFree vs e            -> fr vs (f e)+  TOr e1 e2             -> oR (f e1) (f e2)+  TCase ct e bs         -> cas ct (f e) (map (\ (TBranch p e') -> branch p (f e')) bs)+  TTyped e ty           -> typed (f e) ty+  where+  f = trTExpr var lit comb lt fr oR cas branch typed++-- |update all variables in given expression+updVars :: (TypeExpr -> VarIndex -> TExpr) -> TExpr -> TExpr+updVars var = trTExpr var TLit TComb TLet TFree TOr TCase TBranch TTyped++-- |update all literals in given expression+updLiterals :: (TypeExpr -> Literal -> TExpr) -> TExpr -> TExpr+updLiterals lit = trTExpr TVarE lit TComb TLet TFree TOr TCase TBranch TTyped++-- |update all combined expressions in given expression+updCombs :: (TypeExpr -> CombType -> QName -> [TExpr] -> TExpr) -> TExpr -> TExpr+updCombs comb = trTExpr TVarE TLit comb TLet TFree TOr TCase TBranch TTyped++-- |update all let expressions in given expression+updLets :: ([((VarIndex, TypeExpr), TExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr+updLets lt = trTExpr TVarE TLit TComb lt TFree TOr TCase TBranch TTyped++-- |update all free declarations in given expression+updFrees :: ([(VarIndex, TypeExpr)] -> TExpr -> TExpr) -> TExpr -> TExpr+updFrees fr = trTExpr TVarE TLit TComb TLet fr TOr TCase TBranch TTyped++-- |update all or expressions in given expression+updOrs :: (TExpr -> TExpr -> TExpr) -> TExpr -> TExpr+updOrs oR = trTExpr TVarE TLit TComb TLet TFree oR TCase TBranch TTyped++-- |update all case expressions in given expression+updCases :: (CaseType -> TExpr -> [TBranchExpr] -> TExpr) -> TExpr -> TExpr+updCases cas = trTExpr TVarE TLit TComb TLet TFree TOr cas TBranch TTyped++-- |update all case branches in given expression+updBranches :: (TPattern -> TExpr -> TBranchExpr) -> TExpr -> TExpr+updBranches branch = trTExpr TVarE TLit TComb TLet TFree TOr TCase branch TTyped++-- |update all typed expressions in given expression+updTypeds :: (TExpr -> TypeExpr -> TExpr) -> TExpr -> TExpr+updTypeds = trTExpr TVarE TLit TComb TLet TFree TOr TCase TBranch++-- Auxiliary Functions++-- |is expression a call of a function where all arguments are provided?+isFuncCall :: TExpr -> Bool+isFuncCall e = isTComb e && isCombTypeFuncCall (combType e)++-- |is expression a partial function call?+isFuncPartCall :: TExpr -> Bool+isFuncPartCall e = isTComb e && isCombTypeFuncPartCall (combType e)++-- |is expression a call of a constructor?+isConsCall :: TExpr -> Bool+isConsCall e = isTComb e && isCombTypeConsCall (combType e)++-- |is expression a partial constructor call?+isConsPartCall :: TExpr -> Bool+isConsPartCall e = isTComb e && isCombTypeConsPartCall (combType e)++-- |is expression fully evaluated?+isGround :: TExpr -> Bool+isGround e+  = case e of+      TComb _ ConsCall _ args -> all isGround args+      _ -> isTLit e++-- |get all variables (also pattern variables) in expression+allVars :: TExpr -> [(VarIndex, TypeExpr)]+allVars e = trTExpr var lit comb lt fr (.) cas branch typ e []+ where+  var a v = (:) (v, a)+  lit = const (const id)+  comb _ _ _ = foldr (.) id+  lt bs e' = e' . foldr (.) id (map (\(n,ns) -> (n:) . ns) bs)+  fr vs e' = (vs++) . e'+  cas _ e' bs = e' . foldr (.) id bs+  branch pat e' = (args pat ++) . e'+  typ = const+  args pat | isConsPattern pat = tPatArgs pat+           | otherwise = []++-- |rename all variables (also in patterns) in expression+rnmAllVars :: Update TExpr VarIndex+rnmAllVars f = trTExpr var TLit TComb lt fr TOr TCase branch TTyped+ where+   var a = TVarE a . f+   lt = TLet . map (\((n, b), e) -> ((f n, b), e))+   fr = TFree . map (\(b, c) -> (f b, c))+   branch = TBranch . updTPatArgs (map (\(a, b) -> (f a, b)))++-- |update all qualified names in expression+updQNames :: Update TExpr QName+updQNames f = trTExpr TVarE TLit comb TLet TFree TOr TCase branch TTyped+ where+  comb ty ct name args = TComb ty ct (f name) args+  branch = TBranch . updTPatCons f++-- TBranchExpr ----------------------------------------------------------------++-- |transform branch expression+trTBranch :: (TPattern -> TExpr -> b) -> TBranchExpr -> b+trTBranch branch (TBranch pat e) = branch pat e++-- Selectors++-- |get pattern from branch expression+tBranchTPattern :: TBranchExpr -> TPattern+tBranchTPattern = trTBranch const++-- |get expression from branch expression+tBranchTExpr :: TBranchExpr -> TExpr+tBranchTExpr = trTBranch (\_ e -> e)++-- Update Operations++-- |update branch expression+updTBranch :: (TPattern -> TPattern) -> (TExpr -> TExpr) -> TBranchExpr -> TBranchExpr+updTBranch fp fe = trTBranch branch+ where+  branch pat e = TBranch (fp pat) (fe e)++-- |update pattern of branch expression+updTBranchTPattern :: Update TBranchExpr TPattern+updTBranchTPattern f = updTBranch f id++-- |update expression of branch expression+updTBranchTExpr :: Update TBranchExpr TExpr+updTBranchTExpr = updTBranch id++-- TPattern -------------------------------------------------------------------++-- |transform pattern+trTPattern :: (TypeExpr -> QName -> [(VarIndex, TypeExpr)] -> b) -> (TypeExpr -> Literal -> b) -> TPattern -> b+trTPattern pattern _ (TPattern ty name args) = pattern ty name args+trTPattern _ lpattern (TLPattern a l) = lpattern a l++-- Selectors++-- |get name from constructor pattern+tPatCons :: TPattern -> QName+tPatCons = trTPattern (\_ name _ -> name) undefined++-- |get arguments from constructor pattern+tPatArgs :: TPattern -> [(VarIndex, TypeExpr)]+tPatArgs = trTPattern (\_ _ args -> args) undefined++-- |get literal from literal pattern+tPatLiteral :: TPattern -> Literal+tPatLiteral = trTPattern undefined (const id)++-- Test Operations++-- |is pattern a constructor pattern?+isConsPattern :: TPattern -> Bool+isConsPattern = trTPattern (\_ _ _ -> True) (\_ _ -> False)++-- Update Operations++-- |update pattern+updTPattern :: (TypeExpr -> TypeExpr) ->+               (QName -> QName) ->+               ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) ->+               (Literal -> Literal) -> TPattern -> TPattern+updTPattern fannot fn fa fl = trTPattern pattern lpattern+ where+  pattern ty name args = TPattern (fannot ty) (fn name) (fa args)+  lpattern ty l = TLPattern (fannot ty) (fl l)++-- |update TypeExpr of pattern+updTPatType :: (TypeExpr -> TypeExpr) -> TPattern -> TPattern+updTPatType f = updTPattern f id id id++-- |update constructors name of pattern+updTPatCons :: (QName -> QName) -> TPattern -> TPattern+updTPatCons f = updTPattern id f id id++-- |update arguments of constructor pattern+updTPatArgs :: ([(VarIndex, TypeExpr)] -> [(VarIndex, TypeExpr)]) -> TPattern -> TPattern+updTPatArgs f = updTPattern id id f id++-- |update literal of pattern+updTPatLiteral :: (Literal -> Literal) -> TPattern -> TPattern+updTPatLiteral = updTPattern id id id++-- Auxiliary Functions++-- |build expression from pattern+tPatExpr :: TPattern -> TExpr+tPatExpr = trTPattern (\ty name -> TComb ty ConsCall name . map (uncurry (flip TVarE))) TLit

@@ -0,0 +1,83 @@+{- |+    Module      : $Header$+    Description : Representation of annotated FlatCurry.+    Copyright   : (c) 2016 - 2017 Finn Teegen+                      2018        Kai-Oliver Prott+    License     : BSD-3-clause++    Maintainer  : fte@informatik.uni-kiel.de+    Stability   : experimental+    Portability : portable+ +    This library contains a version of FlatCurry's abstract syntax tree+    modified with type information++    For more information about the abstract syntax tree of `FlatCurry`,+    see the documentation of the respective module.+-}++module Curry.FlatCurry.Typed.Type+  ( module Curry.FlatCurry.Typed.Type+  , module Curry.FlatCurry.Typeable+  , module Curry.FlatCurry.Type+  ) where++import Curry.FlatCurry.Typeable+import Curry.FlatCurry.Type ( QName, VarIndex, Visibility (..), TVarIndex+                            , TypeDecl (..), OpDecl (..), Fixity (..)+                            , TypeExpr (..), ConsDecl (..)+                            , Literal (..), CombType (..), CaseType (..)+                            )++data TProg = TProg String [String] [TypeDecl] [TFuncDecl] [OpDecl]+  deriving (Eq, Read, Show)++data TFuncDecl = TFunc QName Int Visibility TypeExpr TRule+  deriving (Eq, Read, Show)++data TRule+  = TRule     [(VarIndex, TypeExpr)] TExpr+  | TExternal TypeExpr String+  deriving (Eq, Read, Show)++data TExpr+  = TVarE  TypeExpr VarIndex -- otherwise name clash with TypeExpr's TVar+  | TLit   TypeExpr Literal+  | TComb  TypeExpr CombType QName [TExpr]+  | TLet   [((VarIndex, TypeExpr), TExpr)] TExpr+  | TFree  [(VarIndex, TypeExpr)] TExpr+  | TOr    TExpr TExpr+  | TCase  CaseType TExpr [TBranchExpr]+  | TTyped TExpr TypeExpr+  deriving (Eq, Read, Show)++data TBranchExpr = TBranch TPattern TExpr+  deriving (Eq, Read, Show)++data TPattern+  = TPattern  TypeExpr QName [(VarIndex, TypeExpr)]+  | TLPattern TypeExpr Literal+  deriving (Eq, Read, Show)++instance Typeable TRule where+  typeOf (TRule args e) = foldr (FuncType . snd) (typeOf e) args+  typeOf (TExternal ty _) = ty++instance Typeable TExpr where+  typeOf (TVarE ty _) = ty+  typeOf (TLit ty _) = ty+  typeOf (TComb  ty _ _ _) = ty+  typeOf (TLet _ e) = typeOf e+  typeOf (TFree _ e) = typeOf e+  typeOf (TOr e _) = typeOf e+  typeOf (TCase _ _ (e:_)) = typeOf e+  typeOf (TTyped _ ty) = ty+  typeOf (TCase _ _ []) = error $ "Curry.FlatCurry.Typed.Type.typeOf: " +++                                  "empty list in case expression"++instance Typeable TPattern where+  typeOf (TPattern ty _ _) = ty+  typeOf (TLPattern ty _) = ty++instance Typeable TBranchExpr where+  typeOf (TBranch _ e) = typeOf e

@@ -50,8 +50,8 @@ -- |Classifies a 'String' as an 'Extension' classifyExtension :: Ident -> Extension classifyExtension i = case reads extName of-  [(e, "")] -> KnownExtension   (idPosition i) e-  _         -> UnknownExtension (idPosition i) extName+  [(e, "")] -> KnownExtension   (getPosition i) e+  _         -> UnknownExtension (getPosition i) extName   where extName = idName i  -- |'Extension's available by Kiel's Curry compilers.

@@ -175,29 +175,29 @@   fix tcs (IMethodDecl p f a qty) = IMethodDecl p f a (fix tcs qty)  instance FixInterface QualTypeExpr where-  fix tcs (QualTypeExpr cx ty) = QualTypeExpr (fix tcs cx) (fix tcs ty)+  fix tcs (QualTypeExpr spi cx ty) = QualTypeExpr spi (fix tcs cx) (fix tcs ty)  instance FixInterface Constraint where-  fix tcs (Constraint qcls ty) = Constraint qcls (fix tcs ty)+  fix tcs (Constraint spi qcls ty) = Constraint spi qcls (fix tcs ty)  instance FixInterface TypeExpr where-  fix tcs (ConstructorType tc)+  fix tcs (ConstructorType spi tc)     | not (isQualified tc) && not (isPrimTypeId tc) && tc' `Set.notMember` tcs-    = VariableType tc'-    | otherwise = ConstructorType tc+    = VariableType spi tc'+    | otherwise = ConstructorType spi tc     where tc' = unqualify tc-  fix tcs (ApplyType  ty1 ty2) = ApplyType (fix tcs ty1) (fix tcs ty2)-  fix tcs (VariableType    tv)-    | tv `Set.member` tcs = ConstructorType (qualify tv)-    | otherwise           = VariableType tv-  fix tcs (TupleType      tys) = TupleType (fix tcs tys)-  fix tcs (ListType        ty) = ListType  (fix tcs ty)-  fix tcs (ArrowType  ty1 ty2) = ArrowType (fix tcs ty1) (fix tcs ty2)-  fix tcs (ParenType       ty) = ParenType (fix tcs ty)-  fix tcs (ForallType   vs ty) = ForallType vs (fix tcs ty)+  fix tcs (ApplyType  spi ty1 ty2) = ApplyType spi (fix tcs ty1) (fix tcs ty2)+  fix tcs (VariableType    spi tv)+    | tv `Set.member` tcs = ConstructorType spi (qualify tv)+    | otherwise           = VariableType spi tv+  fix tcs (TupleType      spi tys) = TupleType spi (fix tcs tys)+  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 (ForallType   spi vs ty) = ForallType spi vs (fix tcs ty)  typeConstructors :: [IDecl] -> [Ident]-typeConstructors ds = [tc | (QualIdent Nothing tc) <- foldr tyCons [] ds]+typeConstructors ds = [tc | (QualIdent _ Nothing tc) <- foldr tyCons [] ds]   where tyCons (IInfixDecl          _ _ _ _) tcs = tcs         tyCons (HidingDataDecl     _ tc _ _) tcs = tc : tcs         tyCons (IDataDecl      _ tc _ _ _ _) tcs = tc : tcs

@@ -654,9 +654,15 @@ -- Lex an optionally qualified entity (identifier or symbol). lexOptQual :: (Token -> P a) -> Token -> [String] -> P a lexOptQual cont token mIdent sp cs@('.':c:s)-  | isAlpha  c       = lexQualIdent     cont identCont mIdent (nextSpan sp) (c:s)-  | isSymbolChar c   = lexQualSymbol    cont identCont mIdent (nextSpan sp) (c:s)+  | isAlpha  c                 = lexQualIdent cont identCont mIdent+                                   (nextSpan sp) (c:s)+  | isSymbolChar c && c /= '.' = lexQualSymbol cont identCont mIdent+                                   (nextSpan sp) (c:s) --   | c `elem` ":[("   = lexQualPrimitive cont token     mIdent (nextSpan sp) (c:s)+  where identCont _ _ = cont token sp cs+lexOptQual cont token mIdent sp cs@('.':'.':c:s)+  | isSymbolChar c =             lexQualSymbol cont identCont mIdent+                                   (nextSpan sp) ('.':c:s)   where identCont _ _ = cont token sp cs lexOptQual cont token _      sp cs = cont token sp cs 

@@ -20,8 +20,10 @@  import Curry.Base.Ident import Curry.Base.Monad       (CYM)-import Curry.Base.Position    (Position)+import Curry.Base.Position    (Position(..), getPosition, setPosition, incr) import Curry.Base.LLParseComb+import Curry.Base.Span        hiding (file) -- clash with Position.file+import Curry.Base.SpanInfo  import Curry.Syntax.Extension import Curry.Syntax.Lexer (Token (..), Category (..), Attributes (..), lexer)@@ -29,13 +31,16 @@  -- |Parse a 'Module' parseSource :: FilePath -> String -> CYM (Module ())-parseSource fn-  = fullParser (uncurry <$> moduleHeader <*> layout moduleDecls) lexer fn+parseSource = fullParser (uncurry <$> moduleHeader <*> layout moduleDecls) lexer +-- TODO position on prefix parsers? -- |Parse only pragmas of a 'Module' parsePragmas :: FilePath -> String -> CYM (Module ()) parsePragmas-  = prefixParser ((\ps -> Module ps mainMIdent Nothing [] []) <$> modulePragmas)+  = prefixParser ((\ps sp -> setEndPosition NoPos+                              (Module (SpanInfo sp []) ps mainMIdent+                                 Nothing [] []))+                    <$> modulePragmas <*> spanPosition)       lexer  -- |Parse a 'Module' header@@ -58,42 +63,63 @@  -- |Parser for a module header moduleHeader :: Parser a Token ([ImportDecl] -> [Decl b] -> Module b)-moduleHeader = (\ps (m, es) -> Module ps m es)-           <$> modulePragmas-           <*> header-  where header = (,) <$-> token KW_module <*> modIdent-                     <*>  option exportSpec-                     <*-> expectWhere-                `opt` (mainMIdent, Nothing)+moduleHeader =+  (\sp ps (m, es, inf) is ds -> updateEndPos+      (Module (SpanInfo sp inf) ps m es is ds))+    <$> spanPosition+    <*> modulePragmas+    <*> header+  where header = (\sp1 m es sp2 -> (m, es, [sp1,sp2]))+                    <$>  tokenSpan KW_module+                    <*>  modIdent+                    <*>  option exportSpec+                    <*>  spanPosition+                    <*-> expectWhere+                `opt` (mainMIdent, Nothing, [])  modulePragmas :: Parser a Token [ModulePragma] modulePragmas = many (languagePragma <|> optionsPragma)  languagePragma :: Parser a Token ModulePragma-languagePragma =   LanguagePragma-              <$>  tokenPos PragmaLanguage-              <*>  (languageExtension `sepBy1` comma)-              <*-> token PragmaEnd+languagePragma =   languagePragma'+              <$>  tokenSpan PragmaLanguage+              <*>  (languageExtension `sepBy1Sp` comma)+              <*>  tokenSpan PragmaEnd   where languageExtension = classifyExtension <$> ident+        languagePragma' sp1 (ex, ss) sp2 = updateEndPos $+          LanguagePragma (SpanInfo sp1 (sp1 : ss ++ [sp2])) ex +-- TODO The span info is not 100% complete due to the lexer+-- combining OPTIONS, toolVal and toolArgs optionsPragma :: Parser a Token ModulePragma-optionsPragma = (\pos a -> OptionsPragma pos (fmap classifyTool $ toolVal a)-                                             (toolArgs a))-           <$>  position+optionsPragma = optionsPragma'+           <$>  spanPosition            <*>  token PragmaOptions-           <*-> token PragmaEnd+           <*>  tokenSpan PragmaEnd+  where optionsPragma' sp1 a sp2 = updateEndPos $+          OptionsPragma (SpanInfo sp1 [sp1, sp2])+                        (classifyTool <$> toolVal a)+                        (toolArgs a)  -- |Parser for an export specification exportSpec :: Parser a Token ExportSpec-exportSpec = Exporting <$> position <*> parens (export `sepBy` comma)+exportSpec = exportSpec' <$> spanPosition <*> parensSp (export `sepBySp` comma)+  where exportSpec' sp1 ((ex, ss),sp2,sp3) = updateEndPos $+          Exporting (SpanInfo sp1 (sp2:(ss ++ [sp3]))) ex  -- |Parser for an export item export :: Parser a Token Export-export =  qtycon <**> (parens spec `opt` Export)         -- type constructor-      <|> Export <$> qfun <\> qtycon                     -- fun-      <|> ExportModule <$-> token KW_module <*> modIdent -- module-  where spec =       ExportTypeAll  <$-> token DotDot-            <|> flip ExportTypeWith <$>  con `sepBy` comma+export =  qtycon <**> (tcExportWith <$> parensSp spec `opt` tcExport)+      <|> tcExport <$> qfun <\> qtycon+      <|> exportModule' <$> tokenSpan KW_module <*> modIdent+  where spec =  (\sp      -> (ExportTypeAll    , [sp])) <$> tokenSpan DotDot+            <|> (\(c, ss) -> (exportTypeWith' c,  ss )) <$> con `sepBySp` comma+        tcExport qtc = updateEndPos $ Export (fromSrcSpan (getSrcSpan qtc)) qtc+        tcExportWith ((spc, ss), sp1, sp2) qtc =+          updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+          spc (fromSrcSpan (getSrcSpan qtc)) qtc+        exportTypeWith' c spi qtc = ExportTypeWith spi qtc c+        exportModule' sp = updateEndPos . ExportModule (SpanInfo sp [])  moduleDecls :: Parser a Token ([ImportDecl], [Decl ()]) moduleDecls = impDecl <$> importDecl@@ -103,24 +129,43 @@  -- |Parser for a single import declaration importDecl :: Parser a Token ImportDecl-importDecl =  flip . ImportDecl-          <$> tokenPos KW_import-          <*> flag (token Id_qualified)+importDecl =  importDecl'+          <$> tokenSpan KW_import+          <*> option (tokenSpan Id_qualified)           <*> modIdent-          <*> option (token Id_as <-*> modIdent)+          <*> option ((,) <$> tokenSpan Id_as <*> modIdent)           <*> option importSpec+  where+    importDecl' sp1 (Just sp2) mid (Just (sp3, alias)) = updateEndPos .+      ImportDecl (SpanInfo sp1 [sp1, sp2, sp3]) mid True  (Just alias)+    importDecl' sp1 Nothing    mid (Just (sp3, alias)) = updateEndPos .+      ImportDecl (SpanInfo sp1      [sp1, sp3]) mid False (Just alias)+    importDecl' sp1 (Just sp2) mid Nothing             = updateEndPos .+      ImportDecl (SpanInfo sp1      [sp1, sp2]) mid True  Nothing+    importDecl' sp1 Nothing    mid Nothing             = updateEndPos .+      ImportDecl (SpanInfo sp1           [sp1]) mid False Nothing  -- |Parser for an import specification importSpec :: Parser a Token ImportSpec-importSpec =   position-          <**> (Hiding <$-> token Id_hiding `opt` Importing)-          <*>  parens (spec `sepBy` comma)+importSpec =   spanPosition+          <**> (hiding' <$-> token Id_hiding `opt` importing')+          <*>  parensSp (importSp `sepBySp` comma)   where-  spec    =  tycon <**> (parens constrs `opt` Import)-         <|> Import <$> fun <\> tycon-  constrs =  ImportTypeAll       <$-> token DotDot-         <|> flip ImportTypeWith <$>  con `sepBy` comma+    hiding' sp1 ((specs, ss), sp2, sp3) = updateEndPos $+      Hiding    (SpanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) specs+    importing' sp1 ((specs, ss), sp2, sp3) = updateEndPos $+      Importing (SpanInfo sp1 (      sp2 : (ss ++ [sp3]))) specs +importSp :: Parser a Token Import+importSp = tycon <**> (tcImportWith <$> parensSp spec `opt` tcImport)+      <|> tcImport <$> fun <\> tycon+  where spec =  (\sp      -> (ImportTypeAll    , [sp])) <$> tokenSpan DotDot+            <|> (\(c, ss) -> (importTypeWith' c,  ss )) <$> con `sepBySp` comma+        tcImport tc = updateEndPos $ Import (fromSrcSpan (getSrcSpan tc)) tc+        tcImportWith ((spc, ss), sp1, sp2) tc =+          updateEndPos $ setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+          spc (fromSrcSpan (getSrcSpan tc)) tc+        importTypeWith' c spi tc = ImportTypeWith spi tc c -- --------------------------------------------------------------------------- -- Interfaces -- ---------------------------------------------------------------------------@@ -150,7 +195,8 @@  -- |Parser for an interface infix declaration iInfixDecl :: Parser a Token IDecl-iInfixDecl = infixDeclLhs IInfixDecl <*> integer <*> qfunop+iInfixDecl = infixDeclLhs iInfixDecl' <*> integer <*> qfunop+  where iInfixDecl' sp = IInfixDecl (span2Pos sp)  -- |Parser for an interface hiding declaration iHidingDecl :: Parser a Token IDecl@@ -159,7 +205,7 @@   hDataDecl = hiddenData <$-> token KW_data <*> withKind qtycon <*> many tyvar   hClassDecl = hiddenClass <$> classInstHead KW_class (withKind qtycls) clsvar   hiddenData (tc, k) tvs p = HidingDataDecl p tc k tvs-  hiddenClass (_, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv+  hiddenClass (_, _, cx, (qcls, k), tv) p = HidingClassDecl p cx qcls k tv  -- |Parser for an interface data declaration iDataDecl :: Parser a Token IDecl@@ -204,7 +250,8 @@  -- |Parser for an interface class declaration iClassDecl :: Parser a Token IDecl-iClassDecl = (\(p, cx, (qcls, k), tv) -> IClassDecl p cx qcls k tv)+iClassDecl = (\(sp, _, cx, (qcls, k), tv) ->+               IClassDecl (span2Pos sp) cx qcls k tv)         <$> classInstHead KW_class (withKind qtycls) clsvar         <*> braces (iMethod `sepBy` semicolon)         <*> iClassHidden@@ -223,7 +270,8 @@  -- |Parser for an interface instance declaration iInstanceDecl :: Parser a Token IDecl-iInstanceDecl = (\(p, cx, qcls, inst) -> IInstanceDecl p cx qcls inst)+iInstanceDecl = (\(sp, _, cx, qcls, inst) ->+                   IInstanceDecl (span2Pos sp) cx qcls inst)            <$> classInstHead KW_instance qtycls type2            <*> braces (iImpl `sepBy` semicolon)            <*> option iModulePragma@@ -248,113 +296,176 @@                  , infixDecl, functionDecl ]  dataDecl :: Parser a Token (Decl ())-dataDecl = typeDeclLhs DataDecl KW_data <*> constrs <*> deriv-  where constrs = equals <-*> constrDecl `sepBy1` bar `opt` []+dataDecl = combineWithSpans+             <$> typeDeclLhs dataDecl' KW_data+             <*> ((addSpan <$> tokenSpan Equals <*> constrs) `opt` ([],[]))+             <*> deriv+  where constrs = constrDecl `sepBy1Sp` bar+        dataDecl' sp = DataDecl (SpanInfo sp [sp])  externalDataDecl :: Parser a Token (Decl ())-externalDataDecl = decl <$> tokenPos KW_external <*> typeDeclLhs (,,) KW_data-  where decl p (_, tc, tvs) = ExternalDataDecl p tc tvs+externalDataDecl = decl <$> tokenSpan KW_external <*> typeDeclLhs (,,) KW_data+  where decl sp1 (sp2, tc, tvs) = updateEndPos $+          ExternalDataDecl (SpanInfo sp1 [sp1, sp2]) tc tvs  newtypeDecl :: Parser a Token (Decl ())-newtypeDecl = typeDeclLhs NewtypeDecl KW_newtype <*-> equals <*> newConstrDecl-                                                             <*> deriv+newtypeDecl = combineWithSpans+             <$> typeDeclLhs newtypeDecl' KW_newtype+             <*> ((\sp c -> (c, [sp]))  <$> tokenSpan Equals <*> newConstrDecl)+             <*> deriv+  where newtypeDecl' sp = NewtypeDecl (SpanInfo sp [sp]) +combineWithSpans :: HasSpanInfo a =>+                    (t1 -> t2 -> a) -> (t1, [Span]) -> (t2, [Span]) -> a+combineWithSpans df (cs, sps1) (cls, sps2)+  = updateEndPos $ setSrcInfoPoints (getSrcInfoPoints res ++ sps1 ++ sps2) res+  where res = df cs cls+ typeDecl :: Parser a Token (Decl ())-typeDecl = typeDeclLhs TypeDecl KW_type <*-> equals <*> type0+typeDecl = typeDeclLhs typeDecl' KW_type <*> tokenSpan Equals <*> type0+  where typeDecl' sp1 tyc tyv sp2 txp = updateEndPos $+          TypeDecl (SpanInfo sp1 [sp1, sp2]) tyc tyv txp -typeDeclLhs :: (Position -> Ident -> [Ident] -> a) -> Category+typeDeclLhs :: (Span -> Ident -> [Ident] -> a) -> Category             -> Parser b Token a-typeDeclLhs f kw = f <$> tokenPos kw <*> tycon <*> many anonOrTyvar+typeDeclLhs f kw = f <$> tokenSpan kw <*> tycon <*> many anonOrTyvar  constrDecl :: Parser a Token ConstrDecl-constrDecl = position <**> (existVars <**> optContext (flip ($)) constr)+constrDecl = spanPosition <**> (existVars+                          <**> optContext (\cx sp f -> f sp cx) constr)   where   constr =  conId     <**> identDecl-        <|> leftParen <-*> parenDecl+        <|> tokenSpan LeftParen <**> parenDecl         <|> type1 <\> conId <\> leftParen <**> opDecl   identDecl =  many type2 <**> (conType <$> opDecl `opt` conDecl)            <|> recDecl <$> recFields   parenDecl =  conOpDeclPrefix-           <$> conSym    <*-> rightParen <*> type2 <*> type2-           <|> tupleType <*-> rightParen <**> opDecl+           <$> conSym    <*>   tokenSpan RightParen <*> type2 <*> type2+           <|> tupleType <**> (tokenSpan RightParen <**> opDeclParen)   opDecl = conOpDecl <$> conop <*> type1-  recFields                        = layoutOff <-*> braces-                                       (fieldDecl `sepBy` comma)-  conType f tys c                  = f $ apply (ConstructorType $ qualify c) tys-  apply                            = foldl ApplyType-  conDecl tys c cx tvs p              = ConstrDecl p tvs cx c tys-  conOpDecl op ty2 ty1 cx tvs p       = ConOpDecl p tvs cx ty1 op ty2-  conOpDeclPrefix op ty1 ty2 cx tvs p = ConOpDecl p tvs cx ty1 op ty2-  recDecl fs c cx tvs p               = RecordDecl p tvs cx c fs+  opDeclParen = conOpDeclParen <$> conop <*> type1+  recFields = layoutOff <-*> bracesSp (fieldDecl `sepBySp` comma)+  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  fieldDecl :: Parser a Token FieldDecl-fieldDecl = FieldDecl <$> position <*> labels <*-> token DoubleColon <*> type0-  where labels = fun `sepBy1` comma+fieldDecl = mkFieldDecl <$> spanPosition <*> labels+                        <*> tokenSpan DoubleColon <*> type0+  where labels = fun `sepBy1Sp` comma+        mkFieldDecl sp1 (idt,ss) sp2 ty = updateEndPos $+          FieldDecl (SpanInfo sp1 (ss ++ [sp2])) idt ty  newConstrDecl :: Parser a Token NewConstrDecl-newConstrDecl = position <**> (con <**> newConstr)+newConstrDecl = spanPosition <**> (con <**> newConstr)   where newConstr =  newConDecl <$> type2                  <|> newRecDecl <$> newFieldDecl-        newConDecl ty  c p = NewConstrDecl p c ty-        newRecDecl fld c p = NewRecordDecl p c fld+        newConDecl ty  c sp = updateEndPos $ NewConstrDecl (SpanInfo sp []) c ty+        newRecDecl ((idt, sp2, ty), sp3, sp4) c sp1 = updateEndPos $+          NewRecordDecl (SpanInfo sp1 [sp3,sp2,sp4]) c (idt, ty) -newFieldDecl :: Parser a Token (Ident, TypeExpr)-newFieldDecl = layoutOff <-*> braces labelDecl-  where labelDecl = (,) <$> fun <*-> token DoubleColon <*> type0+newFieldDecl :: Parser a Token ((Ident, Span, TypeExpr), Span, Span)+newFieldDecl = layoutOff <-*> bracesSp labelDecl+  where labelDecl = (,,) <$> fun <*> tokenSpan DoubleColon <*> type0 -deriv :: Parser a Token [QualIdent]-deriv = token KW_deriving <-*> classes `opt` []-  where classes =  return <$> qtycls-               <|> parens (qtycls `sepBy` comma)+deriv :: Parser a Token ([QualIdent], [Span])+deriv = (addSpan <$> tokenSpan KW_deriving <*> classes) `opt` ([], [])+  where classes = ((\q -> ([q], [])) <$> qtycls)+               <|> ((\sp1 (qs, ss) sp2 -> (qs, sp1 : (ss ++ [sp2])))+                      <$> tokenSpan LeftParen+                      <*> (qtycls `sepBySp` comma)+                      <*> tokenSpan RightParen)  -- Parsing of existential variables-existVars :: Parser a Token [Ident]-existVars = token Id_forall <-*> many1 tyvar <*-> dot `opt` []+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 = position <**> decl-  where decl = fun `sepBy1` comma <**> funListDecl <|?> funRule+functionDecl = spanPosition <**> decl+  where decl = fun `sepBy1Sp` comma <**> funListDecl <|?> funRule -funRule :: Parser a Token (Position -> Decl ())+funRule :: Parser a Token (Span -> Decl ()) funRule = mkFunDecl <$> lhs <*> declRhs-  where lhs = (\f -> (f, FunLhs f [])) <$> fun <|?> funLhs+  where lhs = (\f ->+                 (f, updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f []))+                 <$> fun <|?> funLhs -funListDecl :: Parser a Token ([Ident] -> Position -> Decl ())-funListDecl = typeSig-          <|> flip ExternalDecl . map (Var ()) <$-> token KW_external+funListDecl :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())+funListDecl = typeSig <|> mkExtFun <$> tokenSpan KW_external+  where mkExtFun sp1 (vs,ss) sp2 = updateEndPos $+          ExternalDecl (SpanInfo sp2 (ss++[sp1])) (map (Var ()) vs) -typeSig :: Parser a Token ([Ident] -> Position -> Decl ())-typeSig = sig <$-> token DoubleColon <*> qualType-  where sig qty vs p = TypeSig p vs qty -mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Position -> Decl ()-mkFunDecl (f, lhs) rhs' p = FunctionDecl p () f [Equation p lhs rhs']+typeSig :: Parser a Token (([Ident],[Span]) -> Span -> Decl ())+typeSig = sig <$> tokenSpan DoubleColon <*> qualType+  where sig sp1 qty (vs,ss) sp2 = updateEndPos $+          TypeSig (SpanInfo sp2 (ss++[sp1])) vs qty +mkFunDecl :: (Ident, Lhs ()) -> Rhs () -> Span -> Decl ()+mkFunDecl (f, lhs) rhs' p = updateEndPos $+    FunctionDecl (SpanInfo p []) () f [updateEndPos $+                                         Equation (SpanInfo p []) lhs rhs']+ funLhs :: Parser a Token (Ident, Lhs ()) funLhs = mkFunLhs    <$> fun      <*> many1 pattern2-    <|?> flip ($ id) <$> pattern1 <*> opLhs+    <|?> flip ($ updateEndPos) <$> pattern1 <*> opLhs     <|?> curriedLhs   where   opLhs  =                opLHS funSym (gConSym <\> funSym)-       <|> backquote <-*> opLHS (funId            <*-> expectBackquote)-                                (qConId <\> funId <*-> expectBackquote)-  opLHS funP consP = mkOpLhs    <$> funP  <*> pattern0-                 <|> mkInfixPat <$> consP <*> pattern1 <*> opLhs-  mkFunLhs f ts           = (f , FunLhs f ts)-  mkOpLhs op t2 f t1      = (op, OpLhs (f t1) op t2)-  mkInfixPat op t2 f g t1 = f (g . InfixPattern () t1 op) t2+       <|> tokenSpan Backquote <**>+             opLHSSp ((,) <$> funId            <*>  spanPosition+                                               <*-> expectBackquote)+                     ((,) <$> qConId <\> funId <*>  spanPosition+                                               <*-> expectBackquote)+  opLHS funP consP   = mkOpLhs       <$> funP  <*> pattern0+                    <|> mkInfixPat   <$> consP <*> pattern1 <*> opLhs+  opLHSSp funP consP = mkOpLhsSp     <$> funP  <*> pattern0+                    <|> mkInfixPatSp <$> consP <*> pattern1 <*> opLhs+  mkFunLhs f ts = (f , updateEndPos $ FunLhs (fromSrcSpan (getSrcSpan f)) f ts)+  mkOpLhs op t2 f t1      =+    let t1' = f t1+    in (op, updateEndPos $ OpLhs (fromSrcSpan (getSrcSpan t1')) t1' op t2)+  mkInfixPat op t2 f g t1 =+    f (g . InfixPattern (fromSrcSpan (getSrcSpan t1)) () t1 op) t2+  mkOpLhsSp (op, sp1)    t2   sp2 f t1 =+    let t1' = f t1+    in (op, updateEndPos $+              OpLhs (SpanInfo (getSrcSpan t1') [sp2, sp1]) t1' op t2) +  mkInfixPatSp (op, sp1) t2 g sp2 f t1 =+    g (f . InfixPattern (SpanInfo (getSrcSpan t1) [sp2, sp1]) () t1 op) t2++ curriedLhs :: Parser a Token (Ident, Lhs ())-curriedLhs = apLhs <$> parens funLhs <*> many1 pattern2-  where apLhs (f, lhs) ts = (f, ApLhs lhs ts)+curriedLhs = apLhs <$> parensSp funLhs <*> many1 pattern2+  where apLhs ((f, lhs), sp1, sp2) ts =+          let spi = fromSrcSpan sp1+          in (f, updateEndPos $ setSrcInfoPoints [sp1, sp2] $ ApLhs spi lhs ts)  declRhs :: Parser a Token (Rhs ()) declRhs = rhs equals  rhs :: Parser a Token b -> Parser a Token (Rhs ())-rhs eq = rhsExpr <*> localDecls-  where rhsExpr =  SimpleRhs  <$-> eq <*> position <*> expr-               <|> GuardedRhs <$>  many1 (condExpr eq)+rhs eq = rhsExpr <*> spanPosition <*> localDecls+  where rhsExpr =  mkSimpleRhs  <$> spanPosition <*-> eq <*> expr+               <|> mkGuardedRhs <$> spanPosition <*>  many1 (condExpr eq)+        mkSimpleRhs  sp1 e  sp2 ds = updateEndPos $+          SimpleRhs  (SpanInfo sp1 [sp2]) e  ds+        mkGuardedRhs sp1 ce sp2 ds = updateEndPos $+          GuardedRhs (SpanInfo sp1 [sp2]) ce ds  whereClause :: Parser a Token [b] -> Parser a Token [b] whereClause decls = token KW_where <-*> layout decls `opt` []@@ -366,83 +477,111 @@ valueDecls  = choice [infixDecl, valueDecl] `sepBy` semicolon  infixDecl :: Parser a Token (Decl ())-infixDecl = infixDeclLhs InfixDecl <*> option integer <*> funop `sepBy1` comma+infixDecl = infixDeclLhs infixDecl'+              <*> option ((,) <$> spanPosition <*> integer)+              <*> funop `sepBy1Sp` comma+  where infixDecl' sp1 inf (Just (sp2, pr)) (ids, ss) =+          updateEndPos $ InfixDecl (SpanInfo sp1 (sp1:sp2:ss)) inf (Just pr) ids+        infixDecl' sp1 inf Nothing          (ids, ss) =+          updateEndPos $ InfixDecl (SpanInfo sp1 (sp1    :ss)) inf Nothing   ids -infixDeclLhs :: (Position -> Infix -> a) -> Parser b Token a-infixDeclLhs f = f <$> position <*> tokenOps infixKW+infixDeclLhs :: (Span -> Infix -> a) -> Parser b Token a+infixDeclLhs f = f <$> spanPosition <*> tokenOps infixKW   where infixKW = [(KW_infix, Infix), (KW_infixl, InfixL), (KW_infixr, InfixR)]  valueDecl :: Parser a Token (Decl ())-valueDecl = position <**> decl+valueDecl = spanPosition <**> decl   where-  decl =   var `sepBy1` comma         <**> valListDecl+  decl =   var `sepBy1Sp` comma       <**> valListDecl       <|?> patOrFunDecl <$> pattern0   <*> declRhs       <|?> mkFunDecl    <$> curriedLhs <*> declRhs    valListDecl =  funListDecl-             <|> (flip FreeDecl . map (Var ())) <$-> token KW_free+             <|> mkFree <$> tokenSpan KW_free+    where mkFree sp1 (vs, ss) sp2 = updateEndPos $+            FreeDecl (SpanInfo sp2 (ss ++ [sp1])) (map (Var ()) vs) -  patOrFunDecl (ConstructorPattern _ c ts)-    | not (isConstrId c) = mkFunDecl (f, FunLhs f ts)+  patOrFunDecl (ConstructorPattern spi _ c ts)+    | not (isConstrId c) = mkFunDecl (f, FunLhs spi f ts)     where f = unqualify c-  patOrFunDecl t = patOrOpDecl id t+  patOrFunDecl t = patOrOpDecl updateEndPos t -  patOrOpDecl f (InfixPattern a t1 op t2)-    | isConstrId op = patOrOpDecl (f . InfixPattern a t1 op) t2-    | otherwise     = mkFunDecl (op', OpLhs (f t1) op' t2)+  patOrOpDecl f (InfixPattern spi a t1 op t2)+    | isConstrId op = patOrOpDecl (f . InfixPattern spi a t1 op) t2+    | otherwise     = mkFunDecl (op', updateEndPos $ OpLhs spi (f t1) op' t2)     where op' = unqualify op   patOrOpDecl f t = mkPatDecl (f t) -  mkPatDecl t rhs' p = PatternDecl p t rhs'+  mkPatDecl t rhs' sp = updateEndPos $ PatternDecl (fromSrcSpan sp) t rhs'    isConstrId c = c == qConsId || isQualified c || isQTupleId c  defaultDecl :: Parser a Token (Decl ())-defaultDecl = DefaultDecl <$> position <*-> token KW_default-                          <*> parens (type0 `sepBy` comma)+defaultDecl = mkDefaultDecl <$> tokenSpan KW_default+                            <*> parensSp (type0 `sepBySp` comma)+  where mkDefaultDecl sp1 ((ty, ss), sp2, sp3) = updateEndPos $+          DefaultDecl (SpanInfo sp1 (sp1 : sp2 : (ss ++ [sp3]))) ty  classInstHead :: Category -> Parser a Token b -> Parser a Token c-              -> Parser a Token (Position, Context, b, c)-classInstHead kw cls ty = f <$> tokenPos kw-                            <*> optContext (,) ((,) <$> cls <*> ty)-  where f p (cx, (cls', ty')) = (p, cx, cls', ty')+              -> Parser a Token (Span, [Span], Context, b, c)+classInstHead kw cls ty = f <$> tokenSpan kw+                            <*> optContext (,,) ((,) <$> cls <*> ty)+  where f sp (cx, ss, (cls', ty')) = (sp, ss, cx, cls', ty')  classDecl :: Parser a Token (Decl ())-classDecl = (\(p, cx, cls, tv) -> ClassDecl p cx cls tv)+classDecl = (\(sp1, ss, cx, cls, tv) sp2 -> updateEndPos .+                ClassDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx cls tv)         <$> classInstHead KW_class tycls clsvar+        <*> spanPosition         <*> whereClause innerDecls   where   innerDecls = innerDecl `sepBy` semicolon   --TODO: Refactor by left-factorization   --TODO: Support infixDecl-  innerDecl = foldr1 (<|?>) [ position <**> (fun `sepBy1` comma <**> typeSig)-                            , position <**> funRule+  innerDecl = foldr1 (<|?>)+    [ spanPosition <**> (fun `sepBy1Sp` comma <**> typeSig)+    , spanPosition <**> funRule                             {-, infixDecl-} ]  instanceDecl :: Parser a Token (Decl ())-instanceDecl = (\(p, cx, qcls, inst) -> InstanceDecl p cx qcls inst)+instanceDecl = (\(sp1, ss, cx, qcls, inst) sp2 ->  updateEndPos .+                   InstanceDecl (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) cx qcls inst)            <$> classInstHead KW_instance qtycls type2+           <*> spanPosition            <*> whereClause innerDecls   where-  innerDecls = (position <**> funRule) `sepBy` semicolon-+  innerDecls = (spanPosition <**> funRule) `sepBy` semicolon -- --------------------------------------------------------------------------- -- Type classes -- --------------------------------------------------------------------------- -optContext :: (Context -> a -> b) -> Parser c Token a -> Parser c Token b-optContext f p = f <$> context <*-> token DoubleArrow <*> p-            <|?> f [] <$> p+optContext :: (Context -> [Span] -> a -> b)+           -> Parser c Token a+           -> Parser c Token b+optContext f p = combine <$> context <*> tokenSpan DoubleArrow <*> p+            <|?> f [] [] <$> p+  where combine (ctx, ss) sp = f ctx (ss ++ [sp]) -context :: Parser a Token Context-context = return <$> constraint-      <|> parens (constraint `sepBy` comma)+context :: Parser a Token (Context, [Span])+context = (\c -> ([c], [])) <$> constraint+      <|> combine <$> parensSp (constraint `sepBySp` comma)+  where combine ((ctx, ss), sp1, sp2) = (ctx, sp1 : (ss ++ [sp2])) +-- TODO: ??? constraint :: Parser a Token Constraint-constraint = Constraint <$> qtycls <*> conType-  where varType = VariableType <$> clsvar-        conType = varType-              <|> parens (foldl ApplyType <$> varType <*> many1 type2)+constraint = mkConstraint <$> spanPosition <*> qtycls <*> conType+  where varType = mkVariableType <$> spanPosition <*> clsvar+        conType = fmap ((,) []) varType+               <|> mk <$> parensSp+                            (foldl mkApplyType <$> varType <*> many1 type2)+        mkConstraint sp qtc (ss, ty) = updateEndPos $+          Constraint (SpanInfo sp ss) qtc ty+        mkVariableType sp = VariableType (fromSrcSpan sp)+        mkApplyType t1 t2 =+          ApplyType (fromSrcSpan (combineSpans (getSrcSpan t1)+                                               (getSrcSpan t2)))+                    t1 t2+        mk (a, sp1, sp2) = ([sp1, sp2], a)  -- --------------------------------------------------------------------------- -- Kinds@@ -469,15 +608,21 @@  -- qualType ::= [context '=>']  type0 qualType :: Parser a Token QualTypeExpr-qualType = optContext QualTypeExpr type0+qualType = mkQualTypeExpr <$> spanPosition <*> optContext (,,) type0+  where mkQualTypeExpr sp (cx, ss, ty) = updateEndPos $+          QualTypeExpr (SpanInfo sp ss) cx ty  -- type0 ::= type1 ['->' type0] type0 :: Parser a Token TypeExpr-type0 = type1 `chainr1` (ArrowType <$-> token RightArrow)+type0 = type1 `chainr1` (mkArrowType <$> tokenSpan RightArrow)+  where mkArrowType sp ty1 ty2 = updateEndPos $+          ArrowType (SpanInfo (getSrcSpan ty1) [sp]) ty1 ty2  -- type1 ::= [type1] type2 type1 :: Parser a Token TypeExpr-type1 = foldl1 ApplyType <$> many1 type2+type1 = foldl1 mkApplyType <$> many1 type2+  where mkApplyType ty1 ty2 = updateEndPos $+          ApplyType (fromSrcSpan (getSrcSpan ty1)) ty1 ty2  -- type2 ::= anonType | identType | parenType | bracketType type2 :: Parser a Token TypeExpr@@ -485,16 +630,19 @@  -- anonType ::= '_' anonType :: Parser a Token TypeExpr-anonType = VariableType <$> anonIdent+anonType = mkVariableType <$> spanPosition <*> anonIdent+  where mkVariableType sp = VariableType (fromSrcSpan sp)  -- identType ::= <identifier> identType :: Parser a Token TypeExpr-identType = VariableType <$> tyvar-        <|> ConstructorType <$> qtycon <\> tyvar+identType =  mkVariableType    <$> spanPosition <*> tyvar+         <|> mkConstructorType <$> spanPosition <*> qtycon <\> tyvar+  where mkVariableType    sp = VariableType    (fromSrcSpan sp)+        mkConstructorType sp = ConstructorType (fromSrcSpan sp)  -- parenType ::= '(' tupleType ')' parenType :: Parser a Token TypeExpr-parenType = parens tupleType+parenType = fmap updateSpanWithBrackets (parensSp tupleType)  -- tupleType ::= type0                         (parenthesized type) --            |  type0 ',' type0 { ',' type0 } (tuple type)@@ -502,20 +650,26 @@ --            |  ',' { ',' }                   (tuple type constructor) --            |                                (unit type) tupleType :: Parser a Token TypeExpr-tupleType = type0 <**> (tuple <$> many1 (comma <-*> type0) `opt` ParenType)-        <|> token RightArrow <-*> succeed (ConstructorType qArrowId)-        <|> ConstructorType . qTupleId . (+1) . length <$> many1 comma-        <|> succeed (ConstructorType qUnitId)-  where tuple tys ty = TupleType (ty : tys)+tupleType = type0 <**> (mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> type0)+                          `opt` ParenType NoSpanInfo)+        <|> tokenSpan RightArrow <**> succeed (mkConstructorType qArrowId)+        <|> mkConstructorTupleType <$> many1 (tokenSpan Comma)+        <|> succeed (ConstructorType NoSpanInfo qUnitId)+  where mkTuple stys ty = let (ss, tys) = unzip stys+                          in TupleType (fromSrcInfoPoints ss) (ty : tys)+        mkConstructorType qid sp = ConstructorType (fromSrcInfoPoints [sp]) qid+        mkConstructorTupleType ss = ConstructorType (fromSrcInfoPoints ss)+                                                    (qTupleId (length ss + 1))  -- bracketType ::= '[' listType ']' bracketType :: Parser a Token TypeExpr-bracketType = brackets listType+bracketType = fmap updateSpanWithBrackets (bracketsSp listType)  -- listType ::= type0 (list type) --           |        (list type constructor) listType :: Parser a Token TypeExpr-listType = ListType <$> type0 `opt` (ConstructorType qListId)+listType = ListType NoSpanInfo <$> type0+             `opt` ConstructorType NoSpanInfo qListId  -- --------------------------------------------------------------------------- -- Literals@@ -537,7 +691,11 @@  -- pattern0 ::= pattern1 [ gconop pattern0 ] pattern0 :: Parser a Token (Pattern ())-pattern0 = pattern1 `chainr1` (flip (InfixPattern ()) <$> gconop)+pattern0 = pattern1 `chainr1` (mkInfixPattern <$> gconop)+  where mkInfixPattern qid p1 p2 =+          InfixPattern (fromSrcSpan (combineSpans (getSrcSpan p1)+                                                  (getSrcSpan p2)))+            () p1 qid p2  -- pattern1 ::= varId --           |  QConId { pattern2 }@@ -546,10 +704,10 @@ --           |  '(' parenPattern' --           | pattern2 pattern1 :: Parser a Token (Pattern ())-pattern1 =  varId <**> identPattern'            -- unqualified+pattern1 = varId <**> identPattern'            -- unqualified         <|> qConId <\> varId <**> constrPattern -- qualified-        <|> minus     <-*> negNum-        <|> leftParen <-*> parenPattern'+        <|> mkNegNum <$> minus <*> negNum+        <|> tokenSpan LeftParen <**> parenPattern'         <|> pattern2  <\> qConId <\> leftParen   where   identPattern' =  optAsRecPattern@@ -558,28 +716,38 @@   constrPattern =  mkConsPattern id <$> many1 pattern2                <|> optRecPattern -  mkConsPattern f ts c = ConstructorPattern () (f c) ts    parenPattern' =  minus <**> minusPattern-               <|> gconPattern-               <|> funSym <\> minus <*-> rightParen <**> identPattern'-               <|> parenTuplePattern <\> minus <*-> rightParen-  minusPattern = rightParen         <-*> identPattern'-              <|> parenMinusPattern <*-> rightParen-  gconPattern = ConstructorPattern () <$> gconId <*-> rightParen-                                      <*> many pattern2+      <|> mkGconPattern <$> gconId <*> tokenSpan RightParen <*> many pattern2+      <|> mkFunIdentP <$> funSym <\> minus <*> tokenSpan RightParen+                                           <*> identPattern'+      <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen+  minusPattern = flip mkParenMinus <$> tokenSpan RightParen <*> identPattern'+         <|> mkParenMinus <$> parenMinusPattern <*> tokenSpan RightParen +  mkNegNum idt p = setEndPosition (end (getSrcSpan idt)) p+  mkParenTuple p sp1 sp2 =+    setSpanInfo (SpanInfo (combineSpans sp2 sp1) [sp2, sp1]) p+  mkFunIdentP idt sp1 f sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)+  mkParenMinus f sp1 idt sp2 = setSrcSpan (combineSpans sp2 sp1) (f idt)+  mkConsPattern f ts c = updateEndPos $+    ConstructorPattern (fromSrcSpan (getSrcSpan (f c))) () (f c) ts+  mkGconPattern qid sp1 ps sp2 = updateEndPos $+    ConstructorPattern (SpanInfo (getSrcSpan qid) [sp2,sp1]) () qid ps+ pattern2 :: Parser a Token (Pattern ()) pattern2 =  literalPattern <|> anonPattern <|> identPattern         <|> parenPattern   <|> listPattern <|> lazyPattern  -- literalPattern ::= <integer> | <char> | <float> | <string> literalPattern :: Parser a Token (Pattern ())-literalPattern = LiteralPattern () <$> literal+literalPattern = flip LiteralPattern () <$> fmap fromSrcSpan spanPosition+                                        <*> literal  -- anonPattern ::= '_' anonPattern :: Parser a Token (Pattern ())-anonPattern = VariablePattern () <$> anonIdent+anonPattern = flip VariablePattern () <$> fmap fromSrcSpan spanPosition+                                      <*> anonIdent  -- identPattern ::= Variable [ '@' pattern2 | '{' fields '}' --               |  qConId   [ '{' fields '}' ]@@ -589,31 +757,54 @@  -- TODO: document me! parenPattern :: Parser a Token (Pattern ())-parenPattern = leftParen <-*> parenPattern'+parenPattern = tokenSpan LeftParen <**> parenPattern'   where   parenPattern' = minus <**> minusPattern-              <|> flip (ConstructorPattern ()) [] <$> gconId <*-> rightParen-              <|> funSym <\> minus <*-> rightParen <**> optAsRecPattern-              <|> parenTuplePattern <\> minus <*-> rightParen-  minusPattern = rightParen <-*> optAsRecPattern-              <|> parenMinusPattern <*-> rightParen+      <|> mkConstructorPattern <$> gconId <*> tokenSpan RightParen+      <|> mkFunAsRec <$> funSym <\> minus <*> tokenSpan RightParen+                     <*> optAsRecPattern+      <|> mkParenTuple <$> parenTuplePattern <\> minus <*> tokenSpan RightParen+  minusPattern = mkOptAsRec <$> tokenSpan RightParen <*> optAsRecPattern+      <|> mkParen <$> parenMinusPattern <*> tokenSpan RightParen +  mkConstructorPattern qid sp1 sp2 =+    ConstructorPattern (fromSrcSpan (combineSpans sp2 sp1)) () qid []+  mkFunAsRec = flip (flip . mkOptAsRec)+  mkParenTuple p sp1 sp2 =+    let ss  = getSrcInfoPoints p+        spi = SpanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))+    in setSpanInfo spi p+  mkOptAsRec sp1 f idt sp2 =+    let p   = f idt+        ss  = getSrcInfoPoints p+        spi = SpanInfo (combineSpans sp2 sp1) ([sp2, sp1] ++ ss)+    in setSpanInfo spi p+  mkParen f sp1 idt sp2 =+    let p   = f idt+        ss  = getSrcInfoPoints p+        spi = SpanInfo (combineSpans sp2 sp1) (sp2 : (ss ++ [sp1]))+    in setSpanInfo spi p+ -- listPattern ::= '[' pattern0s ']' -- pattern0s   ::= {- empty -} --              |  pattern0 ',' pattern0s listPattern :: Parser a Token (Pattern ())-listPattern = ListPattern () <$> brackets (pattern0 `sepBy` comma)+listPattern = mkListPattern <$> bracketsSp (pattern0 `sepBySp` comma)+  where mkListPattern ((ps, ss), sp1, sp2) = updateEndPos $+          ListPattern (SpanInfo sp1 (sp1 : (ss ++ [sp2]))) () ps  -- lazyPattern ::= '~' pattern2 lazyPattern :: Parser a Token (Pattern ())-lazyPattern = LazyPattern <$-> token Tilde <*> pattern2+lazyPattern = mkLazyPattern <$> tokenSpan Tilde <*> pattern2+  where mkLazyPattern sp p = updateEndPos $ LazyPattern (SpanInfo sp [sp]) p  -- optRecPattern ::= [ '{' fields '}' ] optRecPattern :: Parser a Token (QualIdent -> Pattern ())-optRecPattern = mkRecPattern <$> fields pattern0 `opt` mkConPattern+optRecPattern = mkRecordPattern <$> fieldsSp pattern0 `opt` mkConPattern   where-  mkRecPattern fs c = RecordPattern () c fs-  mkConPattern c    = ConstructorPattern () c []+  mkRecordPattern ((fs, ss), sp1, sp2) c = updateEndPos $+    RecordPattern (SpanInfo (getSrcSpan c) (sp1 : (ss ++ [sp2]))) () c fs+  mkConPattern c = ConstructorPattern (fromSrcSpan (getSrcSpan c)) () c []  -- --------------------------------------------------------------------------- -- Partial patterns used in the combinators above, but also for parsing@@ -624,31 +815,47 @@ gconId = colon <|> tupleCommas  negNum :: Parser a Token (Pattern ())-negNum = NegativePattern ()-         <$> (Int <$> integer <|> Float <$> float)+negNum = mkNegativePattern <$> spanPosition <*>+                             (Int <$> integer <|> Float <$> float)+  where mkNegativePattern sp = NegativePattern (fromSrcSpan sp) ()  optAsRecPattern :: Parser a Token (Ident -> Pattern ())-optAsRecPattern =  flip AsPattern <$-> token At <*> pattern2-               <|> recPattern     <$>  fields pattern0-               `opt` VariablePattern ()-  where recPattern fs v = RecordPattern () (qualify v) fs+optAsRecPattern =  mkAsPattern     <$> tokenSpan At <*> pattern2+               <|> mkRecordPattern <$> fieldsSp pattern0+               `opt` mkVariablePattern+  where mkRecordPattern ((fs,ss),sp1,sp2) v =+          let s = getPosition v+              e = end sp2+              f = file s+              spi = SpanInfo (Span f s e) (sp1 : (ss ++ [sp2]))+          in updateEndPos $ RecordPattern spi () (qualify v) fs+        mkAsPattern sp p idt =+          AsPattern (SpanInfo (getSrcSpan idt) [sp]) idt p+        mkVariablePattern idt =+          VariablePattern (fromSrcSpan (getSrcSpan idt)) () idt  optInfixPattern :: Parser a Token (Pattern () -> Pattern ()) optInfixPattern = mkInfixPat <$> gconop <*> pattern0             `opt` id-  where mkInfixPat op t2 t1 = InfixPattern () t1 op t2+  where mkInfixPat op t2 t1 =+          let s = getPosition t1+              e = getSrcSpanEnd t2+              f = file s+          in InfixPattern (fromSrcSpan (Span f s e)) () t1 op t2  optTuplePattern :: Parser a Token (Pattern () -> Pattern ())-optTuplePattern = tuple <$> many1 (comma <-*> pattern0)-            `opt` ParenPattern-  where tuple ts t = TuplePattern (t:ts)+optTuplePattern = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> pattern0)+            `opt` ParenPattern NoSpanInfo+  where mkTuple ts t = let (ss, ps) = unzip ts+                       in TuplePattern (fromSrcInfoPoints ss) (t:ps)  parenMinusPattern :: Parser a Token (Ident -> Pattern ())-parenMinusPattern = const <$> negNum <.> optInfixPattern <.> optTuplePattern+parenMinusPattern = mkNeg <$> negNum <.> optInfixPattern <.> optTuplePattern+  where mkNeg neg idt = setEndPosition (end (getSrcSpan idt)) neg  parenTuplePattern :: Parser a Token (Pattern ()) parenTuplePattern = pattern0 <**> optTuplePattern-              `opt` ConstructorPattern () qUnitId []+              `opt` ConstructorPattern NoSpanInfo () qUnitId []  -- --------------------------------------------------------------------------- -- Expressions@@ -663,124 +870,196 @@ -- @ -- can not be parsed with a limited parser lookahead. condExpr :: Parser a Token b -> Parser a Token (CondExpr ())-condExpr eq = CondExpr <$> position <*-> bar <*> expr0 <*-> eq <*> expr+condExpr eq = mkCondExpr <$> spanPosition <*-> bar <*> expr0+                         <*> spanPosition <*-> eq  <*> expr+  where mkCondExpr sp1 e1 sp2 e2 = updateEndPos $+          CondExpr (SpanInfo sp1 [sp1, sp2]) e1 e2  -- expr ::= expr0 [ '::' type0 ] expr :: Parser a Token (Expression ())-expr = expr0 <??> (flip Typed <$-> token DoubleColon <*> qualType)+expr = expr0 <??> (mkTyped <$> tokenSpan DoubleColon <*> qualType)+  where mkTyped sp qty e = updateEndPos $ setSrcSpan (getSrcSpan e) $+          Typed (fromSrcInfoPoints [sp]) e qty  -- expr0 ::= expr1 { infixOp expr1 } expr0 :: Parser a Token (Expression ())-expr0 = expr1 `chainr1` (flip InfixApply <$> infixOp)+expr0 = expr1 `chainr1` (mkInfixApply <$> infixOp)+  where mkInfixApply op e1 e2 = InfixApply+          (fromSrcSpan (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2  -- expr1 ::= - expr2 | -. expr2 | expr2 expr1 :: Parser a Token (Expression ())-expr1 =  UnaryMinus <$-> minus <*> expr2+expr1 =  mkUnaryMinus <$> minus <*> expr2      <|> expr2+  where mkUnaryMinus idt ex =+          let p = getPosition idt+              e = getSrcSpanEnd ex+              f = file p+          in UnaryMinus (SpanInfo (Span f p e) [Span f p (incr p 1)]) ex  -- expr2 ::= lambdaExpr | letExpr | doExpr | ifExpr | caseExpr | expr3 expr2 :: Parser a Token (Expression ()) expr2 = choice [ lambdaExpr, letExpr, doExpr, ifExpr, caseExpr-               , foldl1 Apply <$> many1 expr3+               , foldl1 mkApply <$> many1 expr3                ]+  where mkApply e1 e2 = updateEndPos $ Apply (fromSrcSpan (getSrcSpan e1)) e1 e2  expr3 :: Parser a Token (Expression ())-expr3 = foldl RecordUpdate <$> expr4 <*> many recUpdate-  where recUpdate = layoutOff <-*> braces (field expr0 `sepBy1` comma)+expr3 = foldl mkRecordUpdate <$> expr4 <*> many recUpdate+  where recUpdate = layoutOff <-*> bracesSp (field expr0 `sepBy1Sp` comma)+        mkRecordUpdate e ((fs,ss), sp1, sp2) = updateEndPos $+          setSrcInfoPoints (sp1 : (ss ++ [sp2])) $+          RecordUpdate (fromSrcSpan (getSrcSpan e)) e fs  expr4 :: Parser a Token (Expression ()) expr4 = choice   [constant, anonFreeVariable, variable, parenExpr, listExpr]  constant :: Parser a Token (Expression ())-constant = Literal () <$> literal+constant = mkLiteral <$> spanPosition <*> literal+  where mkLiteral sp = Literal (fromSrcSpan sp) ()  anonFreeVariable :: Parser a Token (Expression ())-anonFreeVariable =  (\ p v -> Variable () $ qualify $ addPositionIdent p v)+anonFreeVariable =  (\ p v -> mkVariable $ qualify $ addPositionIdent p v)                 <$> position <*> anonIdent+  where mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid  variable :: Parser a Token (Expression ()) variable = qFunId <**> optRecord-  where optRecord = flip (Record ()) <$> fields expr0 `opt` Variable ()+  where optRecord = mkRecord <$> fieldsSp expr0 `opt` mkVariable+        mkRecord ((fs,ss), sp1, sp2) qid =+          let spi = SpanInfo (getSrcSpan qid) (sp1 : (ss ++ [sp2]))+          in updateEndPos $ Record spi () qid fs+        mkVariable qid = Variable (fromSrcSpan (getSrcSpan qid)) () qid  parenExpr :: Parser a Token (Expression ())-parenExpr = parens pExpr+parenExpr = fmap updateSpanWithBrackets (parensSp pExpr)   where   pExpr = minus <**> minusOrTuple-      <|> Constructor () <$> tupleCommas+      <|> mkConstructor () <$> tupleCommas       <|> leftSectionOrTuple <\> minus       <|> opOrRightSection <\> minus-      `opt` Constructor () qUnitId-  minusOrTuple = const . UnaryMinus <$> expr1 <.> infixOrTuple-            `opt` Variable () . qualify+      `opt` Constructor (fromSrcInfoPoints []) () qUnitId+  minusOrTuple = mkUnaryMinus <$> expr1 <.> infixOrTuple+            `opt` mkVariable . qualify   leftSectionOrTuple = expr1 <**> infixOrTuple-  infixOrTuple = ($ id) <$> infixOrTuple'+  infixOrTuple = ($ updateEndPos) <$> infixOrTuple'   infixOrTuple' = infixOp <**> leftSectionOrExp               <|> (.) <$> (optType <.> tupleExpr)   leftSectionOrExp = expr1 <**> (infixApp <$> infixOrTuple')                 `opt` leftSection-  optType   = flip Typed <$-> token DoubleColon <*> qualType `opt` id-  tupleExpr = tuple <$> many1 (comma <-*> expr) `opt` Paren+  optType   = mkTyped <$> tokenSpan DoubleColon <*> qualType `opt` id+  tupleExpr = mkTuple <$> many1 ((,) <$> tokenSpan Comma <*> expr)+               `opt` Paren NoSpanInfo   opOrRightSection =  qFunSym <**> optRightSection                   <|> colon   <**> optCRightSection                   <|> infixOp <\> colon <\> qFunSym <**> rightSection-  optRightSection  = (. InfixOp ()    ) <$> rightSection `opt` Variable ()-  optCRightSection = (. InfixConstr ()) <$> rightSection `opt` Constructor ()-  rightSection     = flip RightSection <$> expr0-  infixApp f e2 op g e1 = f (g . InfixApply e1 op) e2-  leftSection op f e = LeftSection (f e) op-  tuple es e = Tuple (e:es)+  optRightSection  = (. InfixOp ()    ) <$> rightSection+                       `opt` Variable NoSpanInfo ()+  optCRightSection = (. InfixConstr ()) <$> rightSection+                       `opt` Constructor NoSpanInfo ()+  rightSection     = mkRightSection <$> expr0+  infixApp f e2 op g e1 = f (g . mkInfixApply e1 op) e2+  leftSection op f e = mkLeftSection (f e) op+  mkTuple ses e = let (ss,es) = unzip ses+                  in Tuple (fromSrcInfoPoints ss) (e:es)+  mkConstructor = Constructor NoSpanInfo+  mkTyped sp ty e = Typed (fromSrcInfoPoints [sp]) e ty+  mkRightSection = flip (RightSection NoSpanInfo)+  mkLeftSection  = LeftSection  NoSpanInfo+  mkInfixApply e1 op e2 = InfixApply (fromSrcSpan+    (combineSpans (getSrcSpan e1) (getSrcSpan e2))) e1 op e2+  mkVariable = Variable NoSpanInfo ()+  mkUnaryMinus ex idt =+    let p = getPosition idt+        e = getSrcSpanEnd ex+        f = file p+    in UnaryMinus (SpanInfo (Span f p e) [Span f p (incr p 1)]) ex  infixOp :: Parser a Token (InfixOp ()) infixOp = InfixOp () <$> qfunop <|> InfixConstr () <$> colon  listExpr :: Parser a Token (Expression ())-listExpr = brackets (elements `opt` List () [])+listExpr = updateSpanWithBrackets <$>+             bracketsSp (elements `opt` List (fromSrcInfoPoints []) () [])   where   elements = expr <**> rest   rest = comprehension-      <|> enumeration (flip EnumFromTo) EnumFrom-      <|> comma <-*> expr <**>-          (enumeration (flip3 EnumFromThenTo) (flip EnumFromThen)-          <|> list <$> many (comma <-*> expr))-    `opt` (\e -> List () [e])-  comprehension = flip ListCompr <$-> bar <*> quals+      <|> enumeration mkEnumFromTo mkEnumFrom+      <|> (tokenSpan Comma <**> (expr <**>(+           enumeration mkEnumFromThenTo mkEnumFromThen+          <|> list <$> many ((,) <$> tokenSpan Comma <*> expr)))+    `opt` (\ e -> List (fromSrcInfoPoints []) () [e]))+  comprehension = mkListCompr <$> tokenSpan Bar <*> quals   enumeration enumTo enum =-    token DotDot <-*> (enumTo <$> expr `opt` enum)-  list es e2 e1 = List () (e1:e2:es)-  flip3 f x y z = f z y x+    tokenSpan DotDot <**> (enumTo <$> expr `opt` enum) +  mkEnumFrom                 sp     =+    EnumFrom (fromSrcInfoPoints [sp])+  mkEnumFromTo            e1 sp  e2 =+    EnumFromTo (fromSrcInfoPoints [sp]) e2 e1+  mkEnumFromThen      sp1 e1 sp2 e2 =+    EnumFromThen (fromSrcInfoPoints [sp2,sp1]) e2 e1+  mkEnumFromThenTo e1 sp1 e2 sp2 e3 =+    EnumFromThenTo (fromSrcInfoPoints [sp2,sp1]) e3 e2 e1+  mkListCompr sp qu e = ListCompr (fromSrcInfoPoints [sp]) e qu++  list xs e2 sp e1 = let (ss, es) = unzip xs+                     in List (fromSrcInfoPoints (sp:ss)) () (e1:e2:es)++updateSpanWithBrackets :: HasSpanInfo a => (a, Span, Span) -> a+updateSpanWithBrackets (ex, sp1, sp2) =+  let ss = getSrcInfoPoints ex+      s  = getPosition sp1+      e  = end sp2+      f  = file s+      spi = SpanInfo (Span f s e) (sp1 : (ss ++ [sp2]))+  in setSpanInfo spi ex+ lambdaExpr :: Parser a Token (Expression ())-lambdaExpr = Lambda <$-> token Backslash <*> many1 pattern2-                    <*-> expectRightArrow <*> expr+lambdaExpr = mkLambda <$> tokenSpan Backslash <*> many1 pattern2+                      <*> spanPosition <*-> expectRightArrow+                      <*> expr+  where mkLambda sp1 ps sp2 e = updateEndPos $ Lambda (SpanInfo sp1 [sp1, sp2]) ps e  letExpr :: Parser a Token (Expression ())-letExpr = Let <$-> token KW_let <*> layout valueDecls-              <*-> (token KW_in <?> "in expected") <*> expr+letExpr = mkLet <$>  tokenSpan KW_let <*> layout valueDecls+                <*> (tokenSpan KW_in <?> "in expected") <*> expr+  where mkLet sp1 ds sp2 e = updateEndPos $ Let (SpanInfo sp1 [sp1, sp2]) ds e  doExpr :: Parser a Token (Expression ())-doExpr = uncurry Do <$-> token KW_do <*> layout stmts+doExpr = mkDo <$> tokenSpan KW_do <*> layout stmts+  where mkDo sp (stms, ex) = updateEndPos $ Do (SpanInfo sp [sp]) stms ex  ifExpr :: Parser a Token (Expression ())-ifExpr = IfThenElse-    <$-> token KW_if                         <*> expr-    <*-> (token KW_then <?> "then expected") <*> expr-    <*-> (token KW_else <?> "else expected") <*> expr+ifExpr = mkIfThenElse+    <$>  tokenSpan KW_if                        <*> expr+    <*> (tokenSpan KW_then <?> "then expected") <*> expr+    <*> (tokenSpan KW_else <?> "else expected") <*> expr+  where mkIfThenElse sp1 e1 sp2 e2 sp3 e3 = updateEndPos $+          IfThenElse (SpanInfo sp1 [sp1, sp2, sp3]) e1 e2 e3  caseExpr :: Parser a Token (Expression ())-caseExpr = keyword <*> expr-      <*-> (token KW_of <?> "of expected") <*> layout (alt `sepBy1` semicolon)-  where keyword =  Case Flex  <$-> token KW_fcase-               <|> Case Rigid <$-> token KW_case+caseExpr = (mkCase Flex  <$> tokenSpan KW_fcase+        <|> mkCase Rigid <$> tokenSpan KW_case)+          <*> expr+          <*> (tokenSpan KW_of <?> "of expected")+          <*> layout (alt `sepBy1` semicolon)+  where mkCase ct sp1 e sp2 = updateEndPos . Case (SpanInfo sp1 [sp1, sp2]) ct e  alt :: Parser a Token (Alt ())-alt = Alt <$> position <*> pattern0 <*> rhs expectRightArrow+alt = mkAlt <$> spanPosition <*> pattern0+            <*> spanPosition <*> rhs expectRightArrow+  where mkAlt sp1 p sp2 = updateEndPos . Alt (SpanInfo sp1 [sp2]) p -fields :: Parser a Token b -> Parser a Token [Field b]-fields p = layoutOff <-*> braces (field p `sepBy` comma)+fieldsSp :: Parser a Token b -> Parser a Token (([Field b], [Span]), Span, Span)+fieldsSp p = layoutOff <-*> bracesSp (field p `sepBySp` comma)  field :: Parser a Token b -> Parser a Token (Field b)-field p = Field <$> position <*> qfun <*-> expectEquals <*> p+field p = mkField <$> spanPosition <*> qfun+                  <*> spanPosition <*-> expectEquals+                  <*> p+  where mkField sp1 q sp2 = updateEndPos . Field (SpanInfo sp1 [sp2]) q  -- --------------------------------------------------------------------------- -- \paragraph{Statements in list comprehensions and \texttt{do} expressions}@@ -800,10 +1079,12 @@ reqStmts = (\ (sts, e) st -> (st : sts, e)) <$-> semicolon <*> stmts  optStmts :: Parser a Token (Expression () -> ([Statement ()], Expression ()))-optStmts = succeed StmtExpr <.> reqStmts `opt` (,) []+optStmts = succeed mkStmtExpr <.> reqStmts `opt` (,) []+  where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e  quals :: Parser a Token [Statement ()]-quals = stmt (succeed id) (succeed StmtExpr) `sepBy1` comma+quals = stmt (succeed id) (succeed mkStmtExpr) `sepBy1` comma+  where mkStmtExpr e = StmtExpr (fromSrcSpan (getSrcSpan e)) e  stmt :: Parser a Token (Statement () -> b)      -> Parser a Token (Expression () -> b) -> Parser a Token b@@ -812,23 +1093,35 @@  letStmt :: Parser a Token (Statement () -> b)         -> Parser a Token (Expression () -> b) -> Parser a Token b-letStmt stmtCont exprCont = token KW_let <-*> layout valueDecls <**> optExpr-  where optExpr =  flip Let <$-> token KW_in <*> expr <.> exprCont-               <|> succeed StmtDecl <.> stmtCont+letStmt stmtCont exprCont = ((,) <$> tokenSpan KW_let <*> layout valueDecls)+                              <**> optExpr+  where optExpr =  let' <$> tokenSpan KW_in <*> expr <.> exprCont+               <|> succeed stmtDecl' <.> stmtCont+          where+            let' sp1 e (sp2, ds) = updateEndPos $+              Let (SpanInfo sp2 [sp2, sp1]) ds e+            stmtDecl'  (sp2, ds) = updateEndPos $+              StmtDecl (SpanInfo sp2 [sp2]) ds  exprOrBindStmt :: Parser a Token (Statement () -> b)                -> Parser a Token (Expression () -> b)                -> Parser a Token b exprOrBindStmt stmtCont exprCont =-       StmtBind <$> pattern0 <*-> leftArrow <*> expr <**> stmtCont+       stmtBind' <$> spanPosition <*> pattern0 <*> tokenSpan LeftArrow <*> expr+         <**> stmtCont   <|?> expr <\> token KW_let <**> exprCont+  where+    stmtBind' sp1 p sp2 e = updateEndPos $+      StmtBind (SpanInfo sp1 [sp2]) p e  -- --------------------------------------------------------------------------- -- Goals -- ---------------------------------------------------------------------------  goal :: Parser a Token (Goal ())-goal = Goal <$> position <*> expr <*> localDecls+goal = mkGoal <$> spanPosition <*> expr <*> spanPosition <*> localDecls+  where mkGoal sp1 ex sp2 ds = updateEndPos $+          Goal (SpanInfo sp1 [sp2]) ex ds  -- --------------------------------------------------------------------------- -- Literals, identifiers, and (infix) operators@@ -889,19 +1182,24 @@ modIdent = mIdent <?> "module name expected"  var :: Parser a Token Ident-var = varId <|> parens (funSym <?> "operator symbol expected")+var = varId <|> updateSpanWithBrackets+                     <$> parensSp (funSym <?> "operator symbol expected")  fun :: Parser a Token Ident-fun = funId <|> parens (funSym <?> "operator symbol expected")+fun = funId <|> updateSpanWithBrackets+                     <$> parensSp (funSym <?> "operator symbol expected")  con :: Parser a Token Ident-con = conId <|> parens (conSym <?> "operator symbol expected")+con = conId <|> updateSpanWithBrackets+                     <$> parensSp (conSym <?> "operator symbol expected")  funop :: Parser a Token Ident-funop = funSym <|> backquotes (funId <?> "operator name expected")+funop = funSym <|> updateSpanWithBrackets+                     <$> backquotesSp (funId <?> "operator name expected")  conop :: Parser a Token Ident-conop = conSym <|> backquotes (conId <?> "operator name expected")+conop = conSym <|> updateSpanWithBrackets+                     <$> backquotesSp (conId <?> "operator name expected")  qFunId :: Parser a Token QualIdent qFunId = qIdent@@ -919,53 +1217,62 @@ gConSym = qConSym <|> colon  qfun :: Parser a Token QualIdent-qfun = qFunId <|> parens (qFunSym <?> "operator symbol expected")+qfun = qFunId <|> updateSpanWithBrackets+                     <$> parensSp (qFunSym <?> "operator symbol expected")  qfunop :: Parser a Token QualIdent-qfunop = qFunSym <|> backquotes (qFunId <?> "operator name expected")+qfunop = qFunSym <|> updateSpanWithBrackets+                     <$> backquotesSp (qFunId <?> "operator name expected")  gconop :: Parser a Token QualIdent-gconop = gConSym <|> backquotes (qConId <?> "operator name expected")+gconop = gConSym <|> updateSpanWithBrackets+                     <$> backquotesSp (qConId <?> "operator name expected")  anonIdent :: Parser a Token Ident-anonIdent = (\ p -> addPositionIdent p anonId) <$> tokenPos Underscore+anonIdent = ((`setSpanInfo` anonId) . fromSrcSpanBoth) <$> tokenSpan Underscore  mIdent :: Parser a Token ModuleIdent-mIdent = mIdent' <$> position <*>+mIdent = mIdent' <$> spanPosition <*>      tokens [Id,QId,Id_as,Id_ccall,Id_forall,Id_hiding,              Id_interface,Id_primitive,Id_qualified]-  where mIdent' p a = addPositionModuleIdent p $-                      mkMIdent (modulVal a ++ [sval a])+  where mIdent' sp a = ModuleIdent (fromSrcSpanBoth sp) (modulVal a ++ [sval a])  ident :: Parser a Token Ident-ident = (\ pos -> mkIdentPosition pos . sval) <$> position <*>-       tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,-               Id_interface,Id_primitive,Id_qualified]+ident = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))+          <$> spanPosition <*> tokens [Id,Id_as,Id_ccall,Id_forall,Id_hiding,+                                       Id_interface,Id_primitive,Id_qualified]  qIdent :: Parser a Token QualIdent-qIdent =  qualify  <$> ident-      <|> mkQIdent <$> position <*> token QId-  where mkQIdent p a = qualifyWith (mkMIdent (modulVal a))-                                   (mkIdentPosition p (sval a))+qIdent = qualify <$> ident <|> qIdentWith QId  sym :: Parser a Token Ident-sym = (\ pos -> mkIdentPosition pos . sval) <$> position <*>-      tokens [Sym, SymDot, SymMinus, SymStar]+sym = (\ sp t -> setSpanInfo (fromSrcSpanBoth sp) (mkIdent (sval t)))+        <$> spanPosition <*> tokens [Sym, SymDot, SymMinus, SymStar]  qSym :: Parser a Token QualIdent-qSym = qualify <$> sym <|> mkQIdent <$> position <*> token QSym-  where mkQIdent p a = qualifyWith (mkMIdent (modulVal a))-                                   (mkIdentPosition p (sval a))+qSym = qualify <$> sym <|> qIdentWith QSym +qIdentWith :: Category -> Parser a Token QualIdent+qIdentWith c = mkQIdent <$> spanPosition <*> token c+  where mkQIdent :: Span -> Attributes -> QualIdent+        mkQIdent sp a =+          let mid  = ModuleIdent (fromSrcSpan sp) (modulVal a)+              p    = incr (getPosition sp) (mIdentLength mid - 1)+              mid' = setEndPosition p mid+              idt  = setSrcSpan sp $ mkIdent (sval a)+              idt' = setPosition (incr p 1) idt+          in QualIdent (fromSrcSpanBoth sp) (Just mid') idt'+ colon :: Parser a Token QualIdent-colon = (\ p -> qualify $ addPositionIdent p consId) <$> tokenPos Colon+colon = (qualify . (`setSpanInfo` consId) . fromSrcSpanBoth) <$> tokenSpan Colon  minus :: Parser a Token Ident-minus = (\ p -> addPositionIdent p minusId) <$> tokenPos SymMinus+minus = ((`setSpanInfo` minusId) . fromSrcSpanBoth) <$> tokenSpan SymMinus  tupleCommas :: Parser a Token QualIdent-tupleCommas = (\ p -> qualify . addPositionIdent p . tupleId . succ . length)-              <$> position <*> many1 comma+tupleCommas = (\ sp ss -> qualify $ updateEndPos $ setSpanInfo (SpanInfo sp ss)+                                  $ tupleId      $ succ $ length  ss)+              <$> spanPosition <*> many1 (tokenSpan Comma)  -- --------------------------------------------------------------------------- -- Layout@@ -988,15 +1295,36 @@ braces :: Parser a Token b -> Parser a Token b braces p = between leftBrace p rightBrace -brackets :: Parser a Token b -> Parser a Token b-brackets p = between leftBracket p rightBracket+bracesSp :: Parser a Token b -> Parser a Token (b, Span, Span)+bracesSp p = (\sp1 b sp2 -> (b, sp1, sp2))+               <$> tokenSpan LeftBrace+               <*> p+               <*> tokenSpan RightBrace +bracketsSp :: Parser a Token b -> Parser a Token (b, Span, Span)+bracketsSp p = (\sp1 b sp2 -> (b, sp1, sp2))+                 <$> tokenSpan LeftBracket+                 <*> p+                 <*> tokenSpan RightBracket+ parens :: Parser a Token b -> Parser a Token b parens p = between leftParen p rightParen +parensSp :: Parser a Token b -> Parser a Token (b, Span, Span)+parensSp p = (\sp1 b sp2 -> (b, sp1, sp2))+               <$> 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))+                   <$> tokenSpan Backquote+                   <*> p+                   <*> spanPosition <*-> expectBackquote+ -- --------------------------------------------------------------------------- -- Simple token parsers -- ---------------------------------------------------------------------------@@ -1011,15 +1339,15 @@ tokenPos :: Category -> Parser a Token Position tokenPos c = position <*-> token c +tokenSpan :: Category -> Parser a Token Span+tokenSpan c = spanPosition <*-> token c+ tokenOps :: [(Category, b)] -> Parser a Token b tokenOps cs = ops [(Token c NoAttributes, x) | (c, x) <- cs]  comma :: Parser a Token Attributes comma = token Comma -dot :: Parser a Token Attributes-dot = token SymDot- semicolon :: Parser a Token Attributes semicolon = token Semicolon <|> token VSemicolon @@ -1050,24 +1378,8 @@ rightParen :: Parser a Token Attributes rightParen = token RightParen -leftBracket :: Parser a Token Attributes-leftBracket = token LeftBracket--rightBracket :: Parser a Token Attributes-rightBracket = token RightBracket- leftBrace :: Parser a Token Attributes leftBrace = token LeftBrace  rightBrace :: Parser a Token Attributes rightBrace = token RightBrace--leftArrow :: Parser a Token Attributes-leftArrow = token LeftArrow---- ------------------------------------------------------------------------------ Ident--- -----------------------------------------------------------------------------mkIdentPosition :: Position -> String -> Ident-mkIdentPosition pos = addPositionIdent pos . mkIdent

@@ -15,6 +15,7 @@     derived from the Haskell pretty printer provided in Simon Marlow's     Haskell parser. -}+{-# LANGUAGE CPP #-} module Curry.Syntax.Pretty   ( ppModule, ppInterface, ppIDecl, ppDecl, ppIdent, ppPattern, ppFieldPatt   , ppExpr, ppOp, ppStmt, ppFieldExpr, ppQualTypeExpr, ppTypeExpr, ppKindExpr@@ -22,15 +23,21 @@   , ppFieldDecl, ppEquation, ppMIdent   ) where +#if __GLASGOW_HASKELL__ >= 804+import Prelude hiding ((<>))+#endif+ import Curry.Base.Ident import Curry.Base.Pretty  import Curry.Syntax.Type import Curry.Syntax.Utils (opName) +-- TODO use span infos+ -- |Pretty print a module ppModule :: Module a -> Doc-ppModule (Module ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds+ppModule (Module _ ps m es is ds) = ppModuleHeader ps m es is $$ ppSepBlock ds  ppModuleHeader :: [ModulePragma] -> ModuleIdent -> Maybe ExportSpec                -> [ImportDecl] -> Doc@@ -62,10 +69,10 @@ ppExportSpec (Exporting _ es) = parenList (map ppExport es)  ppExport :: Export -> Doc-ppExport (Export             x) = ppQIdent x-ppExport (ExportTypeWith tc cs) = ppQIdent tc <> parenList (map ppIdent cs)-ppExport (ExportTypeAll     tc) = ppQIdent tc <> text "(..)"-ppExport (ExportModule       m) = text "module" <+> ppMIdent m+ppExport (Export             _ x) = ppQIdent x+ppExport (ExportTypeWith _ tc cs) = ppQIdent tc <> parenList (map ppIdent cs)+ppExport (ExportTypeAll     _ tc) = ppQIdent tc <> text "(..)"+ppExport (ExportModule       _ m) = text "module" <+> ppMIdent m  ppImportDecl :: ImportDecl -> Doc ppImportDecl (ImportDecl _ m q asM is) =@@ -79,9 +86,9 @@ ppImportSpec (Hiding    _ is) = text "hiding" <+> parenList (map ppImport is)  ppImport :: Import -> Doc-ppImport (Import             x) = ppIdent x-ppImport (ImportTypeWith tc cs) = ppIdent tc <> parenList (map ppIdent cs)-ppImport (ImportTypeAll     tc) = ppIdent tc <> text "(..)"+ppImport (Import             _ x) = ppIdent x+ppImport (ImportTypeWith _ tc cs) = ppIdent tc <> parenList (map ppIdent cs)+ppImport (ImportTypeAll     _ tc) = ppIdent tc <> text "(..)"  ppBlock :: [Decl a] -> Doc ppBlock = vcat . map ppDecl@@ -128,7 +135,7 @@ ppContext cs  = parenList (map ppConstraint cs) <+> darrow  ppConstraint :: Constraint -> Doc-ppConstraint (Constraint qcls ty) = ppQIdent qcls <+> ppTypeExpr 2 ty+ppConstraint (Constraint _ qcls ty) = ppQIdent qcls <+> ppTypeExpr 2 ty  ppInstanceType :: InstanceType -> Doc ppInstanceType = ppTypeExpr 2@@ -179,14 +186,14 @@ ppEquation (Equation _ lhs rhs) = ppRule (ppLhs lhs) equals rhs  ppLhs :: Lhs a -> Doc-ppLhs (FunLhs   f ts) = ppIdent f <+> fsep (map (ppPattern 2) ts)-ppLhs (OpLhs t1 f t2) = ppPattern 1 t1 <+> ppInfixOp f <+> ppPattern 1 t2-ppLhs (ApLhs  lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppPattern 2) ts)+ppLhs (FunLhs   _ f ts) = ppIdent f <+> fsep (map (ppPattern 2) ts)+ppLhs (OpLhs _ t1 f t2) = ppPattern 1 t1 <+> ppInfixOp f <+> ppPattern 1 t2+ppLhs (ApLhs  _ lhs ts) = parens (ppLhs lhs) <+> fsep (map (ppPattern 2) ts)  ppRule :: Doc -> Doc -> Rhs a -> Doc ppRule lhs eq (SimpleRhs _ e ds) =   sep [lhs <+> eq, indent (ppExpr 0 e)] $$ ppLocalDefs ds-ppRule lhs eq (GuardedRhs es ds) =+ppRule lhs eq (GuardedRhs _ es ds) =   sep [lhs, indent (vcat (map (ppCondExpr eq) es))] $$ ppLocalDefs ds  ppLocalDefs :: [Decl a] -> Doc@@ -278,26 +285,26 @@  -- |Pretty print a qualified type expression ppQualTypeExpr :: QualTypeExpr -> Doc-ppQualTypeExpr (QualTypeExpr cx ty) = ppContext cx <+> ppTypeExpr 0 ty+ppQualTypeExpr (QualTypeExpr _ cx ty) = ppContext cx <+> ppTypeExpr 0 ty  -- |Pretty print a type expression ppTypeExpr :: Int -> TypeExpr -> Doc-ppTypeExpr _ (ConstructorType tc) = ppQIdent tc-ppTypeExpr p (ApplyType  ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])-  where ppApplyType (ApplyType ty1' ty2') tys = ppApplyType ty1' (ty2' : tys)+ppTypeExpr _ (ConstructorType _ tc) = ppQIdent tc+ppTypeExpr p (ApplyType  _ ty1 ty2) = parenIf (p > 1) (ppApplyType ty1 [ty2])+  where ppApplyType (ApplyType _ ty1' ty2') tys = ppApplyType ty1' (ty2' : tys)         ppApplyType ty tys                  =           ppTypeExpr 1 ty <+> fsep (map (ppTypeExpr 2) tys)-ppTypeExpr _ (VariableType    tv) = ppIdent tv-ppTypeExpr _ (TupleType      tys) = parenList (map (ppTypeExpr 0) tys)-ppTypeExpr _ (ListType        ty) = brackets (ppTypeExpr 0 ty)-ppTypeExpr p (ArrowType  ty1 ty2) = parenIf (p > 0)-  (fsep (ppArrowType (ArrowType ty1 ty2)))+ppTypeExpr _ (VariableType    _ tv) = ppIdent tv+ppTypeExpr _ (TupleType      _ tys) = parenList (map (ppTypeExpr 0) tys)+ppTypeExpr _ (ListType        _ ty) = brackets (ppTypeExpr 0 ty)+ppTypeExpr p (ArrowType  spi ty1 ty2) = parenIf (p > 0)+  (fsep (ppArrowType (ArrowType spi ty1 ty2)))   where-  ppArrowType (ArrowType ty1' ty2') =+  ppArrowType (ArrowType _ ty1' ty2') =     ppTypeExpr 1 ty1' <+> rarrow : ppArrowType ty2'   ppArrowType ty                    = [ppTypeExpr 0 ty]-ppTypeExpr _ (ParenType       ty) = parens (ppTypeExpr 0 ty)-ppTypeExpr p (ForallType   vs ty)+ppTypeExpr _ (ParenType       _ ty) = parens (ppTypeExpr 0 ty)+ppTypeExpr p (ForallType   _ vs ty)   | null vs   = ppTypeExpr p ty   | otherwise = parenIf (p > 0) $ ppQuantifiedVars vs <+> ppTypeExpr 0 ty @@ -317,28 +324,28 @@  -- |Pretty print a constructor term ppPattern :: Int -> Pattern a -> Doc-ppPattern p (LiteralPattern _ l) = parenIf (p > 1 && isNegative l) (ppLiteral l)+ppPattern p (LiteralPattern _ _ l) = parenIf (p > 1 && isNegative l) (ppLiteral l)   where isNegative (Char   _) = False         isNegative (Int    i) = i < 0         isNegative (Float  f) = f < 0.0         isNegative (String _) = False-ppPattern p (NegativePattern        _ l) = parenIf (p > 1)+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))+ppPattern _ (VariablePattern        _ _ v) = ppIdent v+ppPattern p (ConstructorPattern  _ _ c ts) = parenIf (p > 1 && not (null ts))   (ppQIdent c <+> fsep (map (ppPattern 2) ts))-ppPattern p (InfixPattern     _ t1 c t2) = parenIf (p > 0)+ppPattern p (InfixPattern     _ _ t1 c t2) = parenIf (p > 0)   (sep [ppPattern 1 t1 <+> ppQInfixOp c, indent (ppPattern 0 t2)])-ppPattern _ (ParenPattern             t) = parens (ppPattern 0 t)-ppPattern _ (TuplePattern            ts) = parenList (map (ppPattern 0) ts)-ppPattern _ (ListPattern           _ ts) = bracketList (map (ppPattern 0) ts)-ppPattern _ (AsPattern              v t) = ppIdent v <> char '@' <> ppPattern 2 t-ppPattern _ (LazyPattern              t) = char '~' <> ppPattern 2 t-ppPattern p (FunctionPattern     _ f ts) = parenIf (p > 1 && not (null ts))+ppPattern _ (ParenPattern             _ t) = parens (ppPattern 0 t)+ppPattern _ (TuplePattern            _ ts) = parenList (map (ppPattern 0) ts)+ppPattern _ (ListPattern           _ _ ts) = bracketList (map (ppPattern 0) ts)+ppPattern _ (AsPattern              _ v t) = ppIdent v <> char '@' <> ppPattern 2 t+ppPattern _ (LazyPattern              _ t) = char '~' <> ppPattern 2 t+ppPattern p (FunctionPattern     _ _ f ts) = parenIf (p > 1 && not (null ts))   (ppQIdent f <+> fsep (map (ppPattern 2) ts))-ppPattern p (InfixFuncPattern _ t1 f t2) = parenIf (p > 0)+ppPattern p (InfixFuncPattern _ _ t1 f t2) = parenIf (p > 0)   (sep [ppPattern 1 t1 <+> ppQInfixOp f, indent (ppPattern 0 t2)])-ppPattern p (RecordPattern       _ c fs) = parenIf (p > 1)+ppPattern p (RecordPattern       _ _ c fs) = parenIf (p > 1)   (ppQIdent c <+> record (list (map ppFieldPatt fs)))  -- |Pretty print a record field pattern@@ -355,57 +362,57 @@  -- |Pretty print an expression ppExpr :: Int -> Expression a -> Doc-ppExpr _ (Literal        _ l) = ppLiteral l-ppExpr _ (Variable       _ v) = ppQIdent v-ppExpr _ (Constructor    _ c) = ppQIdent c-ppExpr _ (Paren            e) = parens (ppExpr 0 e)-ppExpr p (Typed        e qty) =+ppExpr _ (Literal        _ _ l) = ppLiteral l+ppExpr _ (Variable       _ _ v) = ppQIdent v+ppExpr _ (Constructor    _ _ c) = ppQIdent c+ppExpr _ (Paren            _ e) = parens (ppExpr 0 e)+ppExpr p (Typed        _ e qty) =   parenIf (p > 0) (ppExpr 0 e <+> text "::" <+> ppQualTypeExpr qty)-ppExpr _ (Tuple           es) = parenList (map (ppExpr 0) es)-ppExpr _ (List          _ es) = bracketList (map (ppExpr 0) es)-ppExpr _ (ListCompr     e qs) =+ppExpr _ (Tuple           _ es) = parenList (map (ppExpr 0) es)+ppExpr _ (List          _ _ es) = bracketList (map (ppExpr 0) es)+ppExpr _ (ListCompr     _ e qs) =   brackets (ppExpr 0 e <+> vbar <+> list (map ppStmt qs))-ppExpr _ (EnumFrom              e) = brackets (ppExpr 0 e <+> text "..")-ppExpr _ (EnumFromThen      e1 e2) =+ppExpr _ (EnumFrom              _ e) = brackets (ppExpr 0 e <+> text "..")+ppExpr _ (EnumFromThen      _ e1 e2) =   brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2 <+> text "..")-ppExpr _ (EnumFromTo        e1 e2) =+ppExpr _ (EnumFromTo        _ e1 e2) =   brackets (ppExpr 0 e1 <+> text ".." <+> ppExpr 0 e2)-ppExpr _ (EnumFromThenTo e1 e2 e3) =+ppExpr _ (EnumFromThenTo _ e1 e2 e3) =   brackets (ppExpr 0 e1 <> comma <+> ppExpr 0 e2               <+> text ".." <+> ppExpr 0 e3)-ppExpr p (UnaryMinus          e) =+ppExpr p (UnaryMinus          _ e) =   parenIf (p > 1) (ppInfixOp minusId <> ppExpr 1 e)-ppExpr p (Apply           e1 e2) =+ppExpr p (Apply           _ e1 e2) =   parenIf (p > 1) (sep [ppExpr 1 e1,indent (ppExpr 2 e2)])-ppExpr p (InfixApply   e1 op e2) =+ppExpr p (InfixApply   _ e1 op e2) =   parenIf (p > 0) (sep [ppExpr 1 e1 <+> ppQInfixOp (opName op),                          indent (ppExpr 1 e2)])-ppExpr _ (LeftSection      e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))-ppExpr _ (RightSection     op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)-ppExpr p (Lambda            t e) = parenIf (p > 0)+ppExpr _ (LeftSection      _ e op) = parens (ppExpr 1 e <+> ppQInfixOp (opName op))+ppExpr _ (RightSection     _ op e) = parens (ppQInfixOp (opName op) <+> ppExpr 1 e)+ppExpr p (Lambda            _ t e) = parenIf (p > 0)   (sep [backsl <> fsep (map (ppPattern 2) t) <+> rarrow, indent (ppExpr 0 e)])-ppExpr p (Let              ds e) = parenIf (p > 0)+ppExpr p (Let              _ ds e) = parenIf (p > 0)           (sep [text "let" <+> ppBlock ds, text "in" <+> ppExpr 0 e])-ppExpr p (Do              sts e) = parenIf (p > 0)+ppExpr p (Do              _ sts e) = parenIf (p > 0)           (text "do" <+> (vcat (map ppStmt sts) $$ ppExpr 0 e))-ppExpr p (IfThenElse   e1 e2 e3) = parenIf (p > 0)+ppExpr p (IfThenElse   _ e1 e2 e3) = parenIf (p > 0)            (text "if" <+>             sep [ppExpr 0 e1,                  text "then" <+> ppExpr 0 e2,                  text "else" <+> ppExpr 0 e3])-ppExpr p (Case      ct e alts) = parenIf (p > 0)+ppExpr p (Case      _ ct e alts) = parenIf (p > 0)            (ppCaseType ct <+> ppExpr 0 e <+> text "of" $$             indent (vcat (map ppAlt alts)))-ppExpr p (Record     _ c fs) = parenIf (p > 0)+ppExpr p (Record     _ _ c fs) = parenIf (p > 0)   (ppQIdent c <+> record (list (map ppFieldExpr fs)))-ppExpr _ (RecordUpdate e fs) =+ppExpr _ (RecordUpdate _ e fs) =   ppExpr 0 e <+> record (list (map ppFieldExpr fs))  -- |Pretty print a statement ppStmt :: Statement a -> Doc-ppStmt (StmtExpr   e) = ppExpr 0 e-ppStmt (StmtBind t e) = sep [ppPattern 0 t <+> larrow,indent (ppExpr 0 e)]-ppStmt (StmtDecl  ds) = text "let" <+> ppBlock ds+ppStmt (StmtExpr   _ e) = ppExpr 0 e+ppStmt (StmtBind _ t e) = sep [ppPattern 0 t <+> larrow,indent (ppExpr 0 e)]+ppStmt (StmtDecl  _ ds) = text "let" <+> ppBlock ds  ppCaseType :: CaseType -> Doc ppCaseType Rigid = text "case"

@@ -18,6 +18,8 @@  import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.Span+import Curry.Base.SpanInfo  import Curry.Syntax.Type @@ -26,8 +28,9 @@ showModule m = showsModule m "\n"  showsModule :: Show a => Module a -> ShowS-showsModule (Module ps mident espec imps decls)+showsModule (Module spi ps mident espec imps decls)   = showsString "Module "+  . showsSpanInfo spi . space   . showsList (\p -> showsPragma p . newline) ps . space   . showsModuleIdent mident . newline   . showsMaybe showsExportSpec espec . newline@@ -37,12 +40,12 @@ showsPragma :: ModulePragma -> ShowS showsPragma (LanguagePragma pos exts)   = showsString "(LanguagePragma "-  . showsPosition pos . space+  . showsSpanInfo pos . space   . showsList showsExtension exts   . showsString ")" showsPragma (OptionsPragma pos mbTool args)   = showsString "(OptionsPragma "-  . showsPosition pos . space+  . showsSpanInfo pos . space   . showsMaybe shows mbTool   . shows args   . showsString ")"@@ -62,33 +65,37 @@ showsExportSpec :: ExportSpec -> ShowS showsExportSpec (Exporting pos exports)   = showsString "(Exporting "-  . showsPosition pos . space+  . showsSpanInfo pos . space   . showsList showsExport exports   . showsString ")"  showsExport :: Export -> ShowS-showsExport (Export qident)+showsExport (Export spi qident)   = showsString "(Export "+  . showsSpanInfo spi . space   . showsQualIdent qident   . showsString ")"-showsExport (ExportTypeWith qident ids)+showsExport (ExportTypeWith spi qident ids)   = showsString "(ExportTypeWith "+  . showsSpanInfo spi . space   . showsQualIdent qident . space   . showsList showsIdent ids   . showsString ")"-showsExport (ExportTypeAll qident)+showsExport (ExportTypeAll spi qident)   = showsString "(ExportTypeAll "+  . showsSpanInfo spi . space   . showsQualIdent qident   . showsString ")"-showsExport (ExportModule m)+showsExport (ExportModule spi m)   = showsString "(ExportModule "+  . showsSpanInfo spi . space   . showsModuleIdent m   . showsString ")"  showsImportDecl :: ImportDecl -> ShowS-showsImportDecl (ImportDecl pos mident quali mmident mimpspec)+showsImportDecl (ImportDecl spi mident quali mmident mimpspec)   = showsString "(ImportDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsModuleIdent mident . space   . shows quali . space   . showsMaybe showsModuleIdent mmident . space@@ -96,114 +103,117 @@   . showsString ")"  showsImportSpec :: ImportSpec -> ShowS-showsImportSpec (Importing pos imports)+showsImportSpec (Importing spi imports)   = showsString "(Importing "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsImport imports   . showsString ")"-showsImportSpec (Hiding pos imports)+showsImportSpec (Hiding spi imports)   = showsString "(Hiding "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsImport imports   . showsString ")"  showsImport :: Import -> ShowS-showsImport (Import ident)+showsImport (Import spi ident)   = showsString "(Import "+  . showsSpanInfo spi . space   . showsIdent ident   . showsString ")"-showsImport (ImportTypeWith ident idents)+showsImport (ImportTypeWith spi ident idents)   = showsString "(ImportTypeWith "+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents   . showsString ")"-showsImport (ImportTypeAll ident)+showsImport (ImportTypeAll spi ident)   = showsString "(ImportTypeAll "+  . showsSpanInfo spi . space   . showsIdent ident   . showsString ")"  showsDecl :: Show a => Decl a -> ShowS-showsDecl (InfixDecl pos infx prec idents)+showsDecl (InfixDecl spi infx prec idents)   = showsString "(InfixDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . shows infx . space   . showsMaybe shows prec . space   . showsList showsIdent idents   . showsString ")"-showsDecl (DataDecl pos ident idents consdecls classes)+showsDecl (DataDecl spi ident idents consdecls classes)   = showsString "(DataDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents . space   . showsList showsConsDecl consdecls . space   . showsList showsQualIdent classes   . showsString ")"-showsDecl (ExternalDataDecl pos ident idents)+showsDecl (ExternalDataDecl spi ident idents)   = showsString "(ExternalDataDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents   . showsString ")"-showsDecl (NewtypeDecl pos ident idents newconsdecl classes)+showsDecl (NewtypeDecl spi ident idents newconsdecl classes)   = showsString "(NewtypeDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents . space   . showsNewConsDecl newconsdecl . space   . showsList showsQualIdent classes   . showsString ")"-showsDecl (TypeDecl pos ident idents typ)+showsDecl (TypeDecl spi ident idents typ)   = showsString "(TypeDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsIdent idents . space   . showsTypeExpr typ   . showsString ")"-showsDecl (TypeSig pos idents qtype)+showsDecl (TypeSig spi idents qtype)   = showsString "(TypeSig "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsIdent idents . space   . showsQualTypeExpr qtype   . showsString ")"-showsDecl (FunctionDecl pos a ident eqs)+showsDecl (FunctionDecl spi a ident eqs)   = showsString "(FunctionDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsIdent ident . space   . showsList showsEquation eqs   . showsString ")"-showsDecl (ExternalDecl pos vars)+showsDecl (ExternalDecl spi vars)   = showsString "(ExternalDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsVar vars   . showsString ")"-showsDecl (PatternDecl pos cons rhs)+showsDecl (PatternDecl spi cons rhs)   = showsString "(PatternDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsConsTerm cons . space   . showsRhs rhs   . showsString ")"-showsDecl (FreeDecl pos vars)+showsDecl (FreeDecl spi vars)   = showsString "(FreeDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsVar vars   . showsString ")"-showsDecl (DefaultDecl pos types)+showsDecl (DefaultDecl spi types)   = showsString "(DefaultDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsTypeExpr types   . showsString ")"-showsDecl (ClassDecl pos context cls clsvar decls)+showsDecl (ClassDecl spi context cls clsvar decls)   = showsString "(ClassDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsContext context . space   . showsIdent cls . space   . showsIdent clsvar . space   . showsList showsDecl decls   . showsString ")"-showsDecl (InstanceDecl pos context qcls inst decls)+showsDecl (InstanceDecl spi context qcls inst decls)   = showsString "(InstanceDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsContext context . space   . showsQualIdent qcls . space   . showsInstanceType inst . space@@ -211,12 +221,12 @@   . showsString ")"  showsContext :: Context -> ShowS-showsContext constraints-  = showsList showsConstraint constraints+showsContext = showsList showsConstraint  showsConstraint :: Constraint -> ShowS-showsConstraint (Constraint qcls ty)+showsConstraint (Constraint spi qcls ty)   = showsString "(Constraint "+  . showsSpanInfo spi . space   . showsQualIdent qcls . space   . showsTypeExpr ty   . showsString ")"@@ -225,26 +235,26 @@ showsInstanceType = showsTypeExpr  showsConsDecl :: ConstrDecl -> ShowS-showsConsDecl (ConstrDecl pos idents context ident types)+showsConsDecl (ConstrDecl spi idents context ident types)   = showsString "(ConstrDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsIdent idents . space   . showsContext context . space   . showsIdent ident . space   . showsList showsTypeExpr types   . showsString ")"-showsConsDecl (ConOpDecl pos idents context ty1 ident ty2)+showsConsDecl (ConOpDecl spi idents context ty1 ident ty2)   = showsString "(ConOpDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsIdent idents . space   . showsContext context . space   . showsTypeExpr ty1 . space   . showsIdent ident . space   . showsTypeExpr ty2   . showsString ")"-showsConsDecl (RecordDecl pos idents context ident fs)+showsConsDecl (RecordDecl spi idents context ident fs)   = showsString "(RecordDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsIdent idents . space   . showsContext context . space   . showsIdent ident . space@@ -252,114 +262,127 @@   . showsString ")"  showsFieldDecl :: FieldDecl -> ShowS-showsFieldDecl (FieldDecl pos labels ty)+showsFieldDecl (FieldDecl spi labels ty)   = showsString "(FieldDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList showsIdent labels . space   . showsTypeExpr ty   . showsString ")"  showsNewConsDecl :: NewConstrDecl -> ShowS-showsNewConsDecl (NewConstrDecl pos ident typ)+showsNewConsDecl (NewConstrDecl spi ident typ)   = showsString "(NewConstrDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsTypeExpr typ   . showsString ")"-showsNewConsDecl (NewRecordDecl pos ident fld)+showsNewConsDecl (NewRecordDecl spi ident fld)   = showsString "(NewRecordDecl "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsPair showsIdent showsTypeExpr fld   . showsString ")"  showsQualTypeExpr :: QualTypeExpr -> ShowS-showsQualTypeExpr (QualTypeExpr context typ)+showsQualTypeExpr (QualTypeExpr spi context typ)   = showsString "(QualTypeExpr "+  . showsSpanInfo spi . space   . showsContext context . space   . showsTypeExpr typ   . showsString ")"  showsTypeExpr :: TypeExpr -> ShowS-showsTypeExpr (ConstructorType qident)+showsTypeExpr (ConstructorType spi qident)   = showsString "(ConstructorType "+  . showsSpanInfo spi . space   . showsQualIdent qident . space   . showsString ")"-showsTypeExpr (ApplyType type1 type2)+showsTypeExpr (ApplyType spi type1 type2)   = showsString "(ApplyType "+  . showsSpanInfo spi . space   . showsTypeExpr type1 . space   . showsTypeExpr type2 . space   . showsString ")"-showsTypeExpr (VariableType ident)+showsTypeExpr (VariableType spi ident)   = showsString "(VariableType "+  . showsSpanInfo spi . space   . showsIdent ident   . showsString ")"-showsTypeExpr (TupleType types)+showsTypeExpr (TupleType spi types)   = showsString "(TupleType "+  . showsSpanInfo spi . space   . showsList showsTypeExpr types   . showsString ")"-showsTypeExpr (ListType typ)+showsTypeExpr (ListType spi typ)   = showsString "(ListType "+  . showsSpanInfo spi . space   . showsTypeExpr typ   . showsString ")"-showsTypeExpr (ArrowType dom ran)+showsTypeExpr (ArrowType spi dom ran)   = showsString "(ArrowType "+  . showsSpanInfo spi . space   . showsTypeExpr dom . space   . showsTypeExpr ran   . showsString ")"-showsTypeExpr (ParenType ty)+showsTypeExpr (ParenType spi ty)   = showsString "(ParenType "+  . showsSpanInfo spi . space   . showsTypeExpr ty   . showsString ")"-showsTypeExpr (ForallType vars ty)+showsTypeExpr (ForallType spi vars ty)   = showsString "(ForallType "+  . showsSpanInfo spi . space   . showsList showsIdent vars   . showsTypeExpr ty   . showsString ")"  showsEquation :: Show a => Equation a -> ShowS-showsEquation (Equation pos lhs rhs)+showsEquation (Equation spi lhs rhs)   = showsString "(Equation "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsLhs lhs . space   . showsRhs rhs   . showsString ")"  showsLhs :: Show a => Lhs a -> ShowS-showsLhs (FunLhs ident conss)+showsLhs (FunLhs spi ident conss)   = showsString "(FunLhs "+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsList showsConsTerm conss   . showsString ")"-showsLhs (OpLhs cons1 ident cons2)+showsLhs (OpLhs spi cons1 ident cons2)   = showsString "(OpLhs "+  . showsSpanInfo spi . space   . showsConsTerm cons1 . space   . showsIdent ident . space   . showsConsTerm cons2   . showsString ")"-showsLhs (ApLhs lhs conss)+showsLhs (ApLhs spi lhs conss)   = showsString "(ApLhs "+  . showsSpanInfo spi . space   . showsLhs lhs . space   . showsList showsConsTerm conss   . showsString ")"  showsRhs :: Show a => Rhs a -> ShowS-showsRhs (SimpleRhs pos expr decls)+showsRhs (SimpleRhs spi expr decls)   = showsString "(SimpleRhs "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsExpression expr . space   . showsList showsDecl decls   . showsString ")"-showsRhs (GuardedRhs cexps decls)+showsRhs (GuardedRhs spi cexps decls)   = showsString "(GuardedRhs "+  . showsSpanInfo spi . space   . showsList showsCondExpr cexps . space   . showsList showsDecl decls   . showsString ")"  showsCondExpr :: Show a => CondExpr a -> ShowS-showsCondExpr (CondExpr pos exp1 exp2)+showsCondExpr (CondExpr spi exp1 exp2)   = showsString "(CondExpr "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"@@ -383,194 +406,231 @@   . showsString ")"  showsConsTerm :: Show a => Pattern a -> ShowS-showsConsTerm (LiteralPattern a lit)+showsConsTerm (LiteralPattern spi a lit)   = showsString "(LiteralPattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsLiteral lit   . showsString ")"-showsConsTerm (NegativePattern a lit)+showsConsTerm (NegativePattern spi a lit)   = showsString "(NegativePattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsLiteral lit   . showsString ")"-showsConsTerm (VariablePattern a ident)+showsConsTerm (VariablePattern spi a ident)   = showsString "(VariablePattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsIdent ident   . showsString ")"-showsConsTerm (ConstructorPattern a qident conss)+showsConsTerm (ConstructorPattern spi a qident conss)   = showsString "(ConstructorPattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsQualIdent qident . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (InfixPattern a cons1 qident cons2)+showsConsTerm (InfixPattern spi a cons1 qident cons2)   = showsString "(InfixPattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsConsTerm cons1 . space   . showsQualIdent qident . space   . showsConsTerm cons2   . showsString ")"-showsConsTerm (ParenPattern cons)+showsConsTerm (ParenPattern spi cons)   = showsString "(ParenPattern "+  . showsSpanInfo spi . space   . showsConsTerm cons   . showsString ")"-showsConsTerm (TuplePattern conss)+showsConsTerm (TuplePattern spi conss)   = showsString "(TuplePattern "+  . showsSpanInfo spi . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (ListPattern a conss)+showsConsTerm (ListPattern spi a conss)   = showsString "(ListPattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (AsPattern ident cons)+showsConsTerm (AsPattern spi ident cons)   = showsString "(AsPattern "+  . showsSpanInfo spi . space   . showsIdent ident . space   . showsConsTerm cons   . showsString ")"-showsConsTerm (LazyPattern cons)+showsConsTerm (LazyPattern spi cons)   = showsString "(LazyPattern "+  . showsSpanInfo spi . space   . showsConsTerm cons   . showsString ")"-showsConsTerm (FunctionPattern a qident conss)+showsConsTerm (FunctionPattern spi a qident conss)   = showsString "(FunctionPattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsQualIdent qident . space   . showsList showsConsTerm conss   . showsString ")"-showsConsTerm (InfixFuncPattern a cons1 qident cons2)+showsConsTerm (InfixFuncPattern spi a cons1 qident cons2)   = showsString "(InfixFuncPattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsConsTerm cons1 . space   . showsQualIdent qident . space   . showsConsTerm cons2   . showsString ")"-showsConsTerm (RecordPattern a qident cfields)+showsConsTerm (RecordPattern spi a qident cfields)   = showsString "(RecordPattern "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsQualIdent qident . space   . showsList (showsField showsConsTerm) cfields . space   . showsString ")"  showsExpression :: Show a => Expression a -> ShowS-showsExpression (Literal a lit)+showsExpression (Literal spi a lit)   = showsString "(Literal "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsLiteral lit   . showsString ")"-showsExpression (Variable a qident)+showsExpression (Variable spi a qident)   = showsString "(Variable "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsQualIdent qident   . showsString ")"-showsExpression (Constructor a qident)+showsExpression (Constructor spi a qident)   = showsString "(Constructor "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsQualIdent qident   . showsString ")"-showsExpression (Paren expr)+showsExpression (Paren spi expr)   = showsString "(Paren "+  . showsSpanInfo spi . space   . showsExpression expr   . showsString ")"-showsExpression (Typed expr qtype)+showsExpression (Typed spi expr qtype)   = showsString "(Typed "+  . showsSpanInfo spi . space   . showsExpression expr . space   . showsQualTypeExpr qtype   . showsString ")"-showsExpression (Tuple exps)+showsExpression (Tuple spi exps)   = showsString "(Tuple "+  . showsSpanInfo spi . space   . showsList showsExpression exps   . showsString ")"-showsExpression (List a exps)+showsExpression (List spi a exps)   = showsString "(List "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsList showsExpression exps   . showsString ")"-showsExpression (ListCompr expr stmts)+showsExpression (ListCompr spi expr stmts)   = showsString "(ListCompr "+  . showsSpanInfo spi . space   . showsExpression expr . space   . showsList showsStatement stmts   . showsString ")"-showsExpression (EnumFrom expr)+showsExpression (EnumFrom spi expr)   = showsString "(EnumFrom "+  . showsSpanInfo spi . space   . showsExpression expr   . showsString ")"-showsExpression (EnumFromThen exp1 exp2)+showsExpression (EnumFromThen spi exp1 exp2)   = showsString "(EnumFromThen "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"-showsExpression (EnumFromTo exp1 exp2)+showsExpression (EnumFromTo spi exp1 exp2)   = showsString "(EnumFromTo "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"-showsExpression (EnumFromThenTo exp1 exp2 exp3)+showsExpression (EnumFromThenTo spi exp1 exp2 exp3)   = showsString "(EnumFromThenTo "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2 . space   . showsExpression exp3   . showsString ")"-showsExpression (UnaryMinus expr)+showsExpression (UnaryMinus spi expr)   = showsString "(UnaryMinus "+  . showsSpanInfo spi . space   . showsExpression expr   . showsString ")"-showsExpression (Apply exp1 exp2)+showsExpression (Apply spi exp1 exp2)   = showsString "(Apply "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2   . showsString ")"-showsExpression (InfixApply exp1 op exp2)+showsExpression (InfixApply spi exp1 op exp2)   = showsString "(InfixApply "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsInfixOp op . space   . showsExpression exp2   . showsString ")"-showsExpression (LeftSection expr op)+showsExpression (LeftSection spi expr op)   = showsString "(LeftSection "+  . showsSpanInfo spi . space   . showsExpression expr . space   . showsInfixOp op   . showsString ")"-showsExpression (RightSection op expr)+showsExpression (RightSection spi op expr)   = showsString "(RightSection "+  . showsSpanInfo spi . space   . showsInfixOp op . space   . showsExpression expr   . showsString ")"-showsExpression (Lambda conss expr)+showsExpression (Lambda spi conss expr)   = showsString "(Lambda "+  . showsSpanInfo spi . space   . showsList showsConsTerm conss . space   . showsExpression expr   . showsString ")"-showsExpression (Let decls expr)+showsExpression (Let spi decls expr)   = showsString "(Let "+  . showsSpanInfo spi . space   . showsList showsDecl decls . space   . showsExpression expr   . showsString ")"-showsExpression (Do stmts expr)+showsExpression (Do spi stmts expr)   = showsString "(Do "+  . showsSpanInfo spi . space   . showsList showsStatement stmts . space   . showsExpression expr   . showsString ")"-showsExpression (IfThenElse exp1 exp2 exp3)+showsExpression (IfThenElse spi exp1 exp2 exp3)   = showsString "(IfThenElse "+  . showsSpanInfo spi . space   . showsExpression exp1 . space   . showsExpression exp2 . space   . showsExpression exp3   . showsString ")"-showsExpression (Case ct expr alts)+showsExpression (Case spi ct expr alts)   = showsString "(Case "+  . showsSpanInfo spi . space   . showsCaseType ct . space   . showsExpression expr . space   . showsList showsAlt alts   . showsString ")"-showsExpression (RecordUpdate expr efields)+showsExpression (RecordUpdate spi expr efields)   = showsString "(RecordUpdate "+  . showsSpanInfo spi . space   . showsExpression expr . space   . showsList (showsField showsExpression) efields   . showsString ")"-showsExpression (Record a qident efields)+showsExpression (Record spi a qident efields)   = showsString "(Record "+  . showsSpanInfo spi . space   . showsPrec 11 a . space   . showsQualIdent qident . space   . showsList (showsField showsExpression) efields@@ -589,16 +649,19 @@   . showsString ")"  showsStatement :: Show a => Statement a -> ShowS-showsStatement (StmtExpr expr)+showsStatement (StmtExpr spi expr)   = showsString "(StmtExpr "+  . showsSpanInfo spi . space   . showsExpression expr   . showsString ")"-showsStatement (StmtDecl decls)+showsStatement (StmtDecl spi decls)   = showsString "(StmtDecl "+  . showsSpanInfo spi . space   . showsList showsDecl decls   . showsString ")"-showsStatement (StmtBind cons expr)+showsStatement (StmtBind spi cons expr)   = showsString "(StmtBind "+  . showsSpanInfo spi . space   . showsConsTerm cons . space   . showsExpression expr   . showsString ")"@@ -608,17 +671,17 @@ showsCaseType Flex  = showsString "Flex"  showsAlt :: Show a => Alt a -> ShowS-showsAlt (Alt pos cons rhs)+showsAlt (Alt spi cons rhs)   = showsString "(Alt "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsConsTerm cons . space   . showsRhs rhs   . showsString ")"  showsField :: (a -> ShowS) -> Field a -> ShowS-showsField sa (Field pos ident a)+showsField sa (Field spi ident a)   = showsString "(Field "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsQualIdent ident . space   . sa a   . showsString ")"@@ -631,15 +694,29 @@   . showsString ")"  showsPosition :: Position -> ShowS-showsPosition Position { line = l, column = c } = showsPair shows shows (l, c)-showsPosition _ = showsString "(0,0)"--- showsPosition (Position file row col)---   = showsString "(Position "---   . shows file . space---   . shows row . space---   . shows col---   . showsString ")"+showsPosition NoPos = showsString "NoPos"+showsPosition Position { line = l, column = c }+   = showsString "(Position "+   . shows l . space+   . shows c+   . showsString ")" +showsSpanInfo :: SpanInfo -> ShowS+showsSpanInfo NoSpanInfo = showsString "NoSpanInfo"+showsSpanInfo SpanInfo { srcSpan = sp, srcInfoPoints = ss }+  = showsString "(SpanInfo "+  . showsSpan sp . space+  . showsList showsSpan ss+  . showsString ")"++showsSpan :: Span -> ShowS+showsSpan NoSpan = showsString "NoSpan"+showsSpan Span { start = s, end = e }+  = showsString "(Span "+  . showsPosition s . space+  . showsPosition e+  . showsString ")"+ showsString :: String -> ShowS showsString = (++) @@ -665,22 +742,23 @@   = showsString "(" . sa a . showsString "," . sb b . showsString ")"  showsIdent :: Ident -> ShowS-showsIdent (Ident p x n)-  = showsString "(Ident " . showsPosition p . space+showsIdent (Ident spi x n)+  = showsString "(Ident " . showsSpanInfo spi . space   . shows x . space . shows n . showsString ")"  showsQualIdent :: QualIdent -> ShowS-showsQualIdent (QualIdent mident ident)+showsQualIdent (QualIdent spi mident ident)   = showsString "(QualIdent "+  . showsSpanInfo spi . space   . showsMaybe showsModuleIdent mident   . space   . showsIdent ident   . showsString ")"  showsModuleIdent :: ModuleIdent -> ShowS-showsModuleIdent (ModuleIdent pos ss)+showsModuleIdent (ModuleIdent spi ss)   = showsString "(ModuleIdent "-  . showsPosition pos . space+  . showsSpanInfo spi . space   . showsList (showsQuotes showsString) ss   . showsString ")" 

@@ -31,7 +31,7 @@     -- * Declarations   , Decl (..), Precedence, Infix (..), ConstrDecl (..), NewConstrDecl (..)   , FieldDecl (..)-  , CallConv (..), TypeExpr (..), QualTypeExpr (..)+  , TypeExpr (..), QualTypeExpr (..)   , Equation (..), Lhs (..), Rhs (..), CondExpr (..)   , Literal (..), Pattern (..), Expression (..), InfixOp (..)   , Statement (..), CaseType (..), Alt (..), Field (..), Var (..)@@ -43,6 +43,8 @@  import Curry.Base.Ident import Curry.Base.Position+import Curry.Base.SpanInfo+import Curry.Base.Span import Curry.Base.Pretty      (Pretty(..))  import Curry.Syntax.Extension@@ -54,30 +56,30 @@ -- ---------------------------------------------------------------------------  -- |Curry module-data Module a = Module [ModulePragma] ModuleIdent (Maybe ExportSpec)+data Module a = Module SpanInfo [ModulePragma] ModuleIdent (Maybe ExportSpec)                        [ImportDecl] [Decl a]     deriving (Eq, Read, Show)  -- |Module pragma data ModulePragma-  = LanguagePragma Position [Extension]         -- ^ language pragma-  | OptionsPragma  Position (Maybe Tool) String -- ^ options pragma+  = LanguagePragma SpanInfo [Extension]         -- ^ language pragma+  | OptionsPragma  SpanInfo (Maybe Tool) String -- ^ options pragma     deriving (Eq, Read, Show)  -- |Export specification-data ExportSpec = Exporting Position [Export]+data ExportSpec = Exporting SpanInfo [Export]     deriving (Eq, Read, Show)  -- |Single exported entity data Export-  = Export         QualIdent         -- f/T-  | ExportTypeWith QualIdent [Ident] -- T (C1,...,Cn)-  | ExportTypeAll  QualIdent         -- T (..)-  | ExportModule   ModuleIdent       -- module M+  = Export         SpanInfo QualIdent         -- f/T+  | ExportTypeWith SpanInfo QualIdent [Ident] -- T (C1,...,Cn)+  | ExportTypeAll  SpanInfo QualIdent         -- T (..)+  | ExportModule   SpanInfo ModuleIdent       -- module M     deriving (Eq, Read, Show)  -- |Import declaration-data ImportDecl = ImportDecl Position ModuleIdent Qualified+data ImportDecl = ImportDecl SpanInfo ModuleIdent Qualified                              (Maybe ModuleIdent) (Maybe ImportSpec)     deriving (Eq, Read, Show) @@ -86,15 +88,15 @@  -- |Import specification data ImportSpec-  = Importing Position [Import]-  | Hiding    Position [Import]+  = Importing SpanInfo [Import]+  | Hiding    SpanInfo [Import]     deriving (Eq, Read, Show)  -- |Single imported entity data Import-  = Import         Ident            -- f/T-  | ImportTypeWith Ident [Ident]    -- T (C1,...,Cn)-  | ImportTypeAll  Ident            -- T (..)+  = Import         SpanInfo Ident            -- f/T+  | ImportTypeWith SpanInfo Ident [Ident]    -- T (C1,...,Cn)+  | ImportTypeAll  SpanInfo Ident            -- T (..)     deriving (Eq, Read, Show)  -- ---------------------------------------------------------------------------@@ -149,19 +151,19 @@  -- |Declaration in a module data Decl a-  = InfixDecl        Position Infix (Maybe Precedence) [Ident]         -- infixl 5 (op), `fun`-  | DataDecl         Position Ident [Ident] [ConstrDecl] [QualIdent]   -- data C a b = C1 a | C2 b deriving (D, ...)-  | ExternalDataDecl Position Ident [Ident]-  | NewtypeDecl      Position Ident [Ident] NewConstrDecl [QualIdent]  -- newtype C a b = C a b deriving (D, ...)-  | TypeDecl         Position Ident [Ident] TypeExpr                   -- type C a b = D a b-  | TypeSig          Position [Ident] QualTypeExpr                     -- f, g :: Bool-  | FunctionDecl     Position a Ident [Equation a]                     -- f True = 1 ; f False = 0-  | ExternalDecl     Position [Var a]                                  -- f, g external-  | PatternDecl      Position (Pattern a) (Rhs a)                      -- Just x = ...-  | FreeDecl         Position [Var a]                                  -- x, y free-  | DefaultDecl      Position [TypeExpr]                               -- default (Int, Float)-  | ClassDecl        Position Context Ident Ident [Decl a]             -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl}-  | InstanceDecl     Position Context QualIdent InstanceType [Decl a]  -- instance C a => M.D (N.T a b c) where {FunctionDecl}+  = InfixDecl        SpanInfo Infix (Maybe Precedence) [Ident]         -- infixl 5 (op), `fun`+  | DataDecl         SpanInfo Ident [Ident] [ConstrDecl] [QualIdent]   -- data C a b = C1 a | C2 b deriving (D, ...)+  | ExternalDataDecl SpanInfo Ident [Ident]+  | 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] 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 = ...+  | FreeDecl         SpanInfo [Var a]                                  -- x, y free+  | DefaultDecl      SpanInfo [TypeExpr]                               -- default (Int, Float)+  | ClassDecl        SpanInfo Context Ident Ident [Decl a]             -- class C a => D a where {TypeSig|InfixDecl|FunctionDecl}+  | InstanceDecl     SpanInfo Context QualIdent InstanceType [Decl a]  -- instance C a => M.D (N.T a b c) where {FunctionDecl}     deriving (Eq, Read, Show)  -- ---------------------------------------------------------------------------@@ -180,41 +182,35 @@  -- |Constructor declaration for algebraic data types data ConstrDecl-  = ConstrDecl Position [Ident] Context Ident [TypeExpr]-  | ConOpDecl  Position [Ident] Context TypeExpr Ident TypeExpr-  | RecordDecl Position [Ident] Context 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) data NewConstrDecl-  = NewConstrDecl Position Ident TypeExpr-  | NewRecordDecl Position Ident (Ident, TypeExpr)+  = NewConstrDecl SpanInfo Ident TypeExpr+  | NewRecordDecl SpanInfo Ident (Ident, TypeExpr)    deriving (Eq, Read, Show)  -- |Declaration for labelled fields-data FieldDecl = FieldDecl Position [Ident] TypeExpr+data FieldDecl = FieldDecl SpanInfo [Ident] TypeExpr   deriving (Eq, Read, Show) --- |Calling convention for C code-data CallConv-  = CallConvPrimitive-  | CallConvCCall-    deriving (Eq, Read, Show)- -- |Type expressions data TypeExpr-  = ConstructorType QualIdent-  | ApplyType       TypeExpr TypeExpr-  | VariableType    Ident-  | TupleType       [TypeExpr]-  | ListType        TypeExpr-  | ArrowType       TypeExpr TypeExpr-  | ParenType       TypeExpr-  | ForallType      [Ident] TypeExpr+  = ConstructorType SpanInfo QualIdent+  | ApplyType       SpanInfo TypeExpr TypeExpr+  | VariableType    SpanInfo Ident+  | TupleType       SpanInfo [TypeExpr]+  | ListType        SpanInfo TypeExpr+  | ArrowType       SpanInfo TypeExpr TypeExpr+  | ParenType       SpanInfo TypeExpr+  | ForallType      SpanInfo [Ident] TypeExpr     deriving (Eq, Read, Show)  -- |Qualified type expressions-data QualTypeExpr = QualTypeExpr Context TypeExpr+data QualTypeExpr = QualTypeExpr SpanInfo Context TypeExpr     deriving (Eq, Read, Show)  -- ---------------------------------------------------------------------------@@ -223,7 +219,7 @@  type Context = [Constraint] -data Constraint = Constraint QualIdent TypeExpr+data Constraint = Constraint SpanInfo QualIdent TypeExpr     deriving (Eq, Read, Show)  type InstanceType = TypeExpr@@ -233,24 +229,24 @@ -- ---------------------------------------------------------------------------  -- |Function defining equation-data Equation a = Equation Position (Lhs a) (Rhs a)+data Equation a = Equation SpanInfo (Lhs a) (Rhs a)     deriving (Eq, Read, Show)  -- |Left-hand-side of an 'Equation' (function identifier and patterns) data Lhs a-  = FunLhs Ident [Pattern a]             -- f x y-  | OpLhs  (Pattern a) Ident (Pattern a) -- x $ y-  | ApLhs  (Lhs a) [Pattern a]           -- ($) x y+  = FunLhs SpanInfo Ident [Pattern a]             -- f x y+  | OpLhs  SpanInfo (Pattern a) Ident (Pattern a) -- x $ y+  | ApLhs  SpanInfo (Lhs a) [Pattern a]           -- ($) x y     deriving (Eq, Read, Show)  -- |Right-hand-side of an 'Equation' data Rhs a-  = SimpleRhs  Position (Expression a) [Decl a] -- @expr where decls@-  | GuardedRhs [CondExpr a] [Decl a]            -- @| cond = expr where decls@+  = SimpleRhs  SpanInfo (Expression a) [Decl a] -- @expr where decls@+  | GuardedRhs SpanInfo [CondExpr a] [Decl a]   -- @| cond = expr where decls@     deriving (Eq, Read, Show)  -- |Conditional expression (expression conditioned by a guard)-data CondExpr a = CondExpr Position (Expression a) (Expression a)+data CondExpr a = CondExpr SpanInfo (Expression a) (Expression a)     deriving (Eq, Read, Show)  -- |Literal@@ -263,47 +259,47 @@  -- |Constructor term (used for patterns) data Pattern a-  = LiteralPattern     a Literal-  | NegativePattern    a Literal-  | VariablePattern    a Ident-  | ConstructorPattern a QualIdent [Pattern a]-  | InfixPattern       a (Pattern a) QualIdent (Pattern a)-  | ParenPattern       (Pattern a)-  | RecordPattern      a QualIdent [Field (Pattern a)] -- C { l1 = p1, ..., ln = pn }-  | TuplePattern       [Pattern a]-  | ListPattern        a [Pattern a]-  | AsPattern          Ident (Pattern a)-  | LazyPattern        (Pattern a)-  | FunctionPattern    a QualIdent [Pattern a]-  | InfixFuncPattern   a (Pattern a) QualIdent (Pattern a)+  = LiteralPattern     SpanInfo a Literal+  | NegativePattern    SpanInfo a Literal+  | VariablePattern    SpanInfo a Ident+  | ConstructorPattern SpanInfo a QualIdent [Pattern a]+  | InfixPattern       SpanInfo a (Pattern a) QualIdent (Pattern a)+  | ParenPattern       SpanInfo (Pattern a)+  | RecordPattern      SpanInfo a QualIdent [Field (Pattern a)] -- C { l1 = p1, ..., ln = pn }+  | TuplePattern       SpanInfo [Pattern a]+  | ListPattern        SpanInfo a [Pattern a]+  | AsPattern          SpanInfo Ident (Pattern a)+  | LazyPattern        SpanInfo (Pattern a)+  | FunctionPattern    SpanInfo a QualIdent [Pattern a]+  | InfixFuncPattern   SpanInfo a (Pattern a) QualIdent (Pattern a)     deriving (Eq, Read, Show)  -- |Expression data Expression a-  = Literal           a Literal-  | Variable          a QualIdent-  | Constructor       a QualIdent-  | Paren             (Expression a)-  | Typed             (Expression a) QualTypeExpr-  | Record            a QualIdent [Field (Expression a)]    -- C {l1 = e1,..., ln = en}-  | RecordUpdate      (Expression a) [Field (Expression a)] -- e {l1 = e1,..., ln = en}-  | Tuple             [Expression a]-  | List              a [Expression a]-  | ListCompr         (Expression a) [Statement a]   -- the ref corresponds to the main list-  | EnumFrom          (Expression a)-  | EnumFromThen      (Expression a) (Expression a)-  | EnumFromTo        (Expression a) (Expression a)-  | EnumFromThenTo    (Expression a) (Expression a) (Expression a)-  | UnaryMinus        (Expression a)-  | Apply             (Expression a) (Expression a)-  | InfixApply        (Expression a) (InfixOp a) (Expression a)-  | LeftSection       (Expression a) (InfixOp a)-  | RightSection      (InfixOp a) (Expression a)-  | Lambda            [Pattern a] (Expression a)-  | Let               [Decl a] (Expression a)-  | Do                [Statement a] (Expression a)-  | IfThenElse        (Expression a) (Expression a) (Expression a)-  | Case              CaseType (Expression a) [Alt a]+  = Literal           SpanInfo a Literal+  | Variable          SpanInfo a QualIdent+  | Constructor       SpanInfo a QualIdent+  | Paren             SpanInfo (Expression a)+  | 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]+  | List              SpanInfo a [Expression a]+  | ListCompr         SpanInfo (Expression a) [Statement a]   -- the ref corresponds to the main list+  | EnumFrom          SpanInfo (Expression a)+  | EnumFromThen      SpanInfo (Expression a) (Expression a)+  | EnumFromTo        SpanInfo (Expression a) (Expression a)+  | EnumFromThenTo    SpanInfo (Expression a) (Expression a) (Expression a)+  | UnaryMinus        SpanInfo (Expression a)+  | Apply             SpanInfo (Expression a) (Expression a)+  | InfixApply        SpanInfo (Expression a) (InfixOp a) (Expression a)+  | LeftSection       SpanInfo (Expression a) (InfixOp a)+  | RightSection      SpanInfo (InfixOp a) (Expression a)+  | Lambda            SpanInfo [Pattern a] (Expression a)+  | Let               SpanInfo [Decl a] (Expression a)+  | Do                SpanInfo [Statement a] (Expression a)+  | IfThenElse        SpanInfo (Expression a) (Expression a) (Expression a)+  | Case              SpanInfo CaseType (Expression a) [Alt a]     deriving (Eq, Read, Show)  -- |Infix operation@@ -314,9 +310,9 @@  -- |Statement (used for do-sequence and list comprehensions) data Statement a-  = StmtExpr (Expression a)-  | StmtDecl [Decl a]-  | StmtBind (Pattern a) (Expression a)+  = StmtExpr SpanInfo (Expression a)+  | StmtDecl SpanInfo [Decl a]+  | StmtBind SpanInfo (Pattern a) (Expression a)     deriving (Eq, Read, Show)  -- |Type of case expressions@@ -326,11 +322,11 @@     deriving (Eq, Read, Show)  -- |Single case alternative-data Alt a = Alt Position (Pattern a) (Rhs a)+data Alt a = Alt SpanInfo (Pattern a) (Rhs a)     deriving (Eq, Read, Show)  -- |Record field-data Field a = Field Position QualIdent a+data Field a = Field SpanInfo QualIdent a     deriving (Eq, Read, Show)  -- |Annotated identifier@@ -342,7 +338,7 @@ -- ---------------------------------------------------------------------------  -- |Goal in REPL (expression to evaluate)-data Goal a = Goal Position (Expression a) [Decl a]+data Goal a = Goal SpanInfo (Expression a) [Decl a]     deriving (Eq, Read, Show)  -- ---------------------------------------------------------------------------@@ -350,97 +346,97 @@ -- ---------------------------------------------------------------------------  instance Functor Module where-  fmap f (Module ps m es is ds) = Module ps m es is (map (fmap f) ds)+  fmap f (Module sp ps m es is ds) = Module sp ps m es is (map (fmap f) ds)  instance Functor Decl where-  fmap _ (InfixDecl p fix prec ops) = InfixDecl p fix prec ops-  fmap _ (DataDecl p tc tvs cs clss) = DataDecl p tc tvs cs clss-  fmap _ (ExternalDataDecl p tc tvs) = ExternalDataDecl p tc tvs-  fmap _ (NewtypeDecl p tc tvs nc clss) = NewtypeDecl p tc tvs nc clss-  fmap _ (TypeDecl p tc tvs ty) = TypeDecl p tc tvs ty-  fmap _ (TypeSig p fs qty) = TypeSig p fs qty-  fmap f (FunctionDecl p a f' eqs) = FunctionDecl p (f a) f' (map (fmap f) eqs)-  fmap f (ExternalDecl p vs) = ExternalDecl p (map (fmap f) vs)-  fmap f (PatternDecl p t rhs) = PatternDecl p (fmap f t) (fmap f rhs)-  fmap f (FreeDecl p vs) = FreeDecl p (map (fmap f) vs)-  fmap _ (DefaultDecl p tys) = DefaultDecl p tys-  fmap f (ClassDecl p cx cls clsvar ds) =-    ClassDecl p cx cls clsvar (map (fmap f) ds)-  fmap f (InstanceDecl p cx qcls inst ds) =-    InstanceDecl p cx qcls inst (map (fmap f) ds)+  fmap _ (InfixDecl sp fix prec ops) = InfixDecl sp fix prec ops+  fmap _ (DataDecl sp tc tvs cs clss) = DataDecl sp tc tvs cs clss+  fmap _ (ExternalDataDecl sp tc tvs) = ExternalDataDecl sp tc tvs+  fmap _ (NewtypeDecl sp tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss+  fmap _ (TypeDecl sp tc tvs ty) = TypeDecl sp tc tvs ty+  fmap _ (TypeSig sp fs qty) = TypeSig sp fs qty+  fmap f (FunctionDecl sp a f' eqs) = FunctionDecl sp (f a) f' (map (fmap f) eqs)+  fmap f (ExternalDecl sp vs) = ExternalDecl sp (map (fmap f) vs)+  fmap f (PatternDecl sp t rhs) = PatternDecl sp (fmap f t) (fmap f rhs)+  fmap f (FreeDecl sp vs) = FreeDecl sp (map (fmap f) vs)+  fmap _ (DefaultDecl sp tys) = DefaultDecl sp tys+  fmap f (ClassDecl sp cx cls clsvar ds) =+    ClassDecl sp cx cls clsvar (map (fmap f) ds)+  fmap f (InstanceDecl sp cx qcls inst ds) =+    InstanceDecl sp cx qcls inst (map (fmap f) ds)  instance Functor Equation where   fmap f (Equation p lhs rhs) = Equation p (fmap f lhs) (fmap f rhs)  instance Functor Lhs where-  fmap f (FunLhs f' ts) = FunLhs f' (map (fmap f) ts)-  fmap f (OpLhs t1 op t2) = OpLhs (fmap f t1) op (fmap f t2)-  fmap f (ApLhs lhs ts) = ApLhs (fmap f lhs) (map (fmap f) ts)+  fmap f (FunLhs p f' ts) = FunLhs p f' (map (fmap f) ts)+  fmap f (OpLhs p t1 op t2) = OpLhs p (fmap f t1) op (fmap f t2)+  fmap f (ApLhs p lhs ts) = ApLhs p (fmap f lhs) (map (fmap f) ts)  instance Functor Rhs where   fmap f (SimpleRhs p e ds) = SimpleRhs p (fmap f e) (map (fmap f) ds)-  fmap f (GuardedRhs cs ds) = GuardedRhs (map (fmap f) cs) (map (fmap f) ds)+  fmap f (GuardedRhs p cs ds) = GuardedRhs p (map (fmap f) cs) (map (fmap f) ds)  instance Functor CondExpr where   fmap f (CondExpr p g e) = CondExpr p (fmap f g) (fmap f e)  instance Functor Pattern where-  fmap f (LiteralPattern a l) = LiteralPattern (f a) l-  fmap f (NegativePattern a l) = NegativePattern (f a) l-  fmap f (VariablePattern a v) = VariablePattern (f a) v-  fmap f (ConstructorPattern a c ts) =-    ConstructorPattern (f a) c (map (fmap f) ts)-  fmap f (InfixPattern a t1 op t2) =-    InfixPattern (f a) (fmap f t1) op (fmap f t2)-  fmap f (ParenPattern t) = ParenPattern (fmap f t)-  fmap f (RecordPattern a c fs) =-    RecordPattern (f a) c (map (fmap (fmap f)) fs)-  fmap f (TuplePattern ts) = TuplePattern (map (fmap f) ts)-  fmap f (ListPattern a ts) = ListPattern (f a) (map (fmap f) ts)-  fmap f (AsPattern v t) = AsPattern v (fmap f t)-  fmap f (LazyPattern t) = LazyPattern (fmap f t)-  fmap f (FunctionPattern a f' ts) =-    FunctionPattern (f a) f' (map (fmap f) ts)-  fmap f (InfixFuncPattern a t1 op t2) =-    InfixFuncPattern (f a) (fmap f t1) op (fmap f t2)+  fmap f (LiteralPattern p a l) = LiteralPattern p (f a) l+  fmap f (NegativePattern p a l) = NegativePattern p (f a) l+  fmap f (VariablePattern p a v) = VariablePattern p (f a) v+  fmap f (ConstructorPattern p a c ts) =+    ConstructorPattern p (f a) c (map (fmap f) ts)+  fmap f (InfixPattern p a t1 op t2) =+    InfixPattern p (f a) (fmap f t1) op (fmap f t2)+  fmap f (ParenPattern p t) = ParenPattern p (fmap f t)+  fmap f (RecordPattern p a c fs) =+    RecordPattern p (f a) c (map (fmap (fmap f)) fs)+  fmap f (TuplePattern p ts) = TuplePattern p (map (fmap f) ts)+  fmap f (ListPattern p a ts) = ListPattern p (f a) (map (fmap f) ts)+  fmap f (AsPattern p v t) = AsPattern p v (fmap f t)+  fmap f (LazyPattern p t) = LazyPattern p (fmap f t)+  fmap f (FunctionPattern p a f' ts) =+    FunctionPattern p (f a) f' (map (fmap f) ts)+  fmap f (InfixFuncPattern p a t1 op t2) =+    InfixFuncPattern p (f a) (fmap f t1) op (fmap f t2)  instance Functor Expression where-  fmap f (Literal a l) = Literal (f a) l-  fmap f (Variable a v) = Variable (f a) v-  fmap f (Constructor a c) = Constructor (f a) c-  fmap f (Paren e) = Paren (fmap f e)-  fmap f (Typed e qty) = Typed (fmap f e) qty-  fmap f (Record a c fs) = Record (f a) c (map (fmap (fmap f)) fs)-  fmap f (RecordUpdate e fs) = RecordUpdate (fmap f e) (map (fmap (fmap f)) fs)-  fmap f (Tuple es) = Tuple (map (fmap f) es)-  fmap f (List a es) = List (f a) (map (fmap f) es)-  fmap f (ListCompr e stms) = ListCompr (fmap f e) (map (fmap f) stms)-  fmap f (EnumFrom e) = EnumFrom (fmap f e)-  fmap f (EnumFromThen e1 e2) = EnumFromThen (fmap f e1) (fmap f e2)-  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 e) = UnaryMinus (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)-  fmap f (LeftSection e op) = LeftSection (fmap f e) (fmap f op)-  fmap f (RightSection op e) = RightSection (fmap f op) (fmap f e)-  fmap f (Lambda ts e) = Lambda (map (fmap f) ts) (fmap f e)-  fmap f (Let ds e) = Let (map (fmap f) ds) (fmap f e)-  fmap f (Do stms e) = Do (map (fmap f) stms) (fmap f e)-  fmap f (IfThenElse e1 e2 e3) =-    IfThenElse (fmap f e1) (fmap f e2) (fmap f e3)-  fmap f (Case ct e as) = Case ct (fmap f e) (map (fmap f) as)+  fmap f (Literal p a l) = Literal p (f a) l+  fmap f (Variable p a v) = Variable p (f a) v+  fmap f (Constructor p a c) = Constructor p (f a) c+  fmap f (Paren p e) = Paren p (fmap f e)+  fmap f (Typed p e qty) = Typed p (fmap f e) qty+  fmap f (Record p a c fs) = Record p (f a) c (map (fmap (fmap f)) fs)+  fmap f (RecordUpdate p e fs) = RecordUpdate p (fmap f e) (map (fmap (fmap f)) fs)+  fmap f (Tuple p es) = Tuple p (map (fmap f) es)+  fmap f (List p a es) = List p (f a) (map (fmap f) es)+  fmap f (ListCompr p e stms) = ListCompr p (fmap f e) (map (fmap f) stms)+  fmap f (EnumFrom p e) = EnumFrom p (fmap f e)+  fmap f (EnumFromThen p e1 e2) = EnumFromThen p (fmap f e1) (fmap f e2)+  fmap f (EnumFromTo p e1 e2) = EnumFromTo p (fmap f e1) (fmap f e2)+  fmap f (EnumFromThenTo p e1 e2 e3) =+    EnumFromThenTo p (fmap f e1) (fmap f e2) (fmap f e3)+  fmap f (UnaryMinus p e) = UnaryMinus p (fmap f e)+  fmap f (Apply p e1 e2) = Apply p (fmap f e1) (fmap f e2)+  fmap f (InfixApply p e1 op e2) =+    InfixApply p (fmap f e1) (fmap f op) (fmap f e2)+  fmap f (LeftSection p e op) = LeftSection p (fmap f e) (fmap f op)+  fmap f (RightSection p op e) = RightSection p (fmap f op) (fmap f e)+  fmap f (Lambda p ts e) = Lambda p (map (fmap f) ts) (fmap f e)+  fmap f (Let p ds e) = Let p (map (fmap f) ds) (fmap f e)+  fmap f (Do p stms e) = Do p (map (fmap f) stms) (fmap f e)+  fmap f (IfThenElse p e1 e2 e3) =+    IfThenElse p (fmap f e1) (fmap f e2) (fmap f e3)+  fmap f (Case p ct e as) = Case p ct (fmap f e) (map (fmap f) as)  instance Functor InfixOp where   fmap f (InfixOp a op) = InfixOp (f a) op   fmap f (InfixConstr a op) = InfixConstr (f a) op  instance Functor Statement where-  fmap f (StmtExpr e) = StmtExpr (fmap f e)-  fmap f (StmtDecl ds) = StmtDecl (map (fmap f) ds)-  fmap f (StmtBind t e) = StmtBind (fmap f t) (fmap f e)+  fmap f (StmtExpr p e) = StmtExpr p (fmap f e)+  fmap f (StmtDecl p ds) = StmtDecl p (map (fmap f) ds)+  fmap f (StmtBind p t e) = StmtBind p (fmap f t) (fmap f e)  instance Functor Alt where   fmap f (Alt p t rhs) = Alt p (fmap f t) (fmap f rhs)@@ -458,3 +454,644 @@   pPrint InfixL = text "infixl"   pPrint InfixR = text "infixr"   pPrint Infix  = text "infix"++instance HasSpanInfo (Module a) where+  getSpanInfo (Module sp _ _ _ _ _) = sp++  setSpanInfo sp (Module _ ps m es is ds) = Module sp ps m es is ds++  updateEndPos m@(Module _ _ _ _ _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) m+  updateEndPos m@(Module _ _ _ _ (i:is) _) =+    setEndPosition (getSrcSpanEnd (last (i:is))) m+  updateEndPos m@(Module (SpanInfo _ (s:ss)) _ _ _ _ _) =+    setEndPosition (end (last (s:ss))) m+  updateEndPos m@(Module _ (p:ps) _ _ _ _) =+    setEndPosition (getSrcSpanEnd (last (p:ps))) m+  updateEndPos m = m++instance HasSpanInfo (Decl a) where+  getSpanInfo (InfixDecl        sp _ _ _)   = sp+  getSpanInfo (DataDecl         sp _ _ _ _) = sp+  getSpanInfo (ExternalDataDecl sp _ _)     = sp+  getSpanInfo (NewtypeDecl      sp _ _ _ _) = sp+  getSpanInfo (TypeDecl         sp _ _ _)   = sp+  getSpanInfo (TypeSig          sp _ _)     = sp+  getSpanInfo (FunctionDecl     sp _ _ _)   = sp+  getSpanInfo (ExternalDecl     sp _)       = sp+  getSpanInfo (PatternDecl      sp _ _)     = sp+  getSpanInfo (FreeDecl         sp _)       = sp+  getSpanInfo (DefaultDecl      sp _)       = sp+  getSpanInfo (ClassDecl        sp _ _ _ _) = sp+  getSpanInfo (InstanceDecl     sp _ _ _ _) = sp++  setSpanInfo sp (InfixDecl _ fix prec ops) = InfixDecl sp fix prec ops+  setSpanInfo sp (DataDecl _ tc tvs cs clss) = DataDecl sp tc tvs cs clss+  setSpanInfo sp (ExternalDataDecl _ tc tvs) = ExternalDataDecl sp tc tvs+  setSpanInfo sp (NewtypeDecl _ tc tvs nc clss) = NewtypeDecl sp tc tvs nc clss+  setSpanInfo sp (TypeDecl _ tc tvs ty) = TypeDecl sp tc tvs ty+  setSpanInfo sp (TypeSig _ fs qty) = TypeSig sp fs qty+  setSpanInfo sp (FunctionDecl _ a f' eqs) = FunctionDecl sp a f' eqs+  setSpanInfo sp (ExternalDecl _ vs) = ExternalDecl sp vs+  setSpanInfo sp (PatternDecl _ t rhs) = PatternDecl sp t rhs+  setSpanInfo sp (FreeDecl _ vs) = FreeDecl sp vs+  setSpanInfo sp (DefaultDecl _ tys) = DefaultDecl sp tys+  setSpanInfo sp (ClassDecl _ cx cls clsvar ds) = ClassDecl sp cx cls clsvar ds+  setSpanInfo sp (InstanceDecl _ cx qcls inst ds) = InstanceDecl sp cx qcls inst ds++  updateEndPos d@(InfixDecl _ _ _ ops) =+    let i' = last ops+    in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+  updateEndPos d@(DataDecl _ _ _ _ (c:cs)) =+    let i' = last (c:cs)+    in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d+  updateEndPos d@(DataDecl _ _ _ (c:cs) _) =+    setEndPosition (getSrcSpanEnd (last (c:cs))) d+  updateEndPos d@(DataDecl _ _ (i:is) _ _) =+    let i' = last (i:is)+    in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+  updateEndPos d@(DataDecl _ i _ _ _) =+    setEndPosition (incr (getPosition i) (identLength i - 1)) d+  updateEndPos d@(ExternalDataDecl _ _ (i:is)) =+    let i' = last (i:is)+    in setEndPosition (incr (getPosition i') (identLength i' - 1)) d+  updateEndPos d@(ExternalDataDecl _ i _) =+    setEndPosition (incr (getPosition i) (identLength i - 1)) d+  updateEndPos d@(NewtypeDecl _ _ _ _ (c:cs)) =+    let i' = last (c:cs)+    in setEndPosition (incr (getPosition i') (qIdentLength i' - 1)) d+  updateEndPos d@(NewtypeDecl _ _ _ c _) =+    setEndPosition (getSrcSpanEnd c) d+  updateEndPos d@(TypeDecl _ _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) d+  updateEndPos d@(TypeSig _ _ qty) =+    setEndPosition (getSrcSpanEnd qty) d+  updateEndPos d@(FunctionDecl _ _ _ eqs) =+    setEndPosition (getSrcSpanEnd (last eqs)) d+  updateEndPos d@(ExternalDecl (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(ExternalDecl _ _) = d+  updateEndPos d@(PatternDecl _ _ rhs) =+    setEndPosition (getSrcSpanEnd rhs) d+  updateEndPos d@(FreeDecl (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(FreeDecl _ _) = d+  updateEndPos d@(DefaultDecl (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(DefaultDecl _ _) = d+  updateEndPos d@(ClassDecl _ _ _ _ (d':ds)) =+    setEndPosition (getSrcSpanEnd (last (d':ds))) d+  updateEndPos d@(ClassDecl (SpanInfo _ ss) _ _ _ _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(ClassDecl _ _ _ _ _) = d+  updateEndPos d@(InstanceDecl _ _ _ _ (d':ds)) =+    setEndPosition (getSrcSpanEnd (last (d':ds))) d+  updateEndPos d@(InstanceDecl (SpanInfo _ ss) _ _ _ _) =+    setEndPosition (end (last ss)) d+  updateEndPos d@(InstanceDecl _ _ _ _ _) = d++instance HasSpanInfo (Equation a) where+  getSpanInfo (Equation spi _ _) = spi+  setSpanInfo spi (Equation _ lhs rhs) = Equation spi lhs rhs+  updateEndPos e@(Equation _ _ rhs) =+    setEndPosition (getSrcSpanEnd rhs) e++instance HasSpanInfo ModulePragma where+  getSpanInfo (LanguagePragma sp _  ) = sp+  getSpanInfo (OptionsPragma  sp _ _) = sp++  setSpanInfo sp (LanguagePragma _ ex ) = LanguagePragma sp ex+  setSpanInfo sp (OptionsPragma  _ t a) = OptionsPragma sp t a++  updateEndPos p@(LanguagePragma (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) p+  updateEndPos p@(LanguagePragma _ _) = p+  updateEndPos p@(OptionsPragma (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) p+  updateEndPos p@(OptionsPragma _ _ _) = p++instance HasSpanInfo ExportSpec where+  getSpanInfo (Exporting sp _) = sp+  setSpanInfo sp (Exporting _ ex) = Exporting sp ex++  updateEndPos e@(Exporting (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) e+  updateEndPos e@(Exporting _ _) = e++instance HasSpanInfo Export where+  getSpanInfo (Export sp _)           = sp+  getSpanInfo (ExportTypeWith sp _ _) = sp+  getSpanInfo (ExportTypeAll sp _)    = sp+  getSpanInfo (ExportModule sp _)     = sp++  setSpanInfo sp (Export _ qid)            = Export sp qid+  setSpanInfo sp (ExportTypeWith _ qid cs) = ExportTypeWith sp qid cs+  setSpanInfo sp (ExportTypeAll _ qid)     = ExportTypeAll sp qid+  setSpanInfo sp (ExportModule _ mid)      = ExportModule sp mid++  updateEndPos e@(Export _ idt) =+    setEndPosition (incr (getPosition idt) (qIdentLength idt - 1)) e+  updateEndPos e@(ExportTypeWith (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) e+  updateEndPos e@(ExportTypeWith _ _ _) = e+  updateEndPos e@(ExportTypeAll (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) e+  updateEndPos e@(ExportTypeAll _ _) = e+  updateEndPos e@(ExportModule _ mid) =+    setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) e++instance HasSpanInfo ImportDecl where+  getSpanInfo (ImportDecl sp _ _ _ _) = sp+  setSpanInfo sp (ImportDecl _ mid q as spec) = ImportDecl sp mid q as spec++  updateEndPos i@(ImportDecl _ _ _ _ (Just spec)) =+    setEndPosition (getSrcSpanEnd spec) i+  updateEndPos i@(ImportDecl _ _ _ (Just mid) _) =+    setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i+  updateEndPos i@(ImportDecl _ mid _ _ _) =+    setEndPosition (incr (getPosition mid) (mIdentLength mid - 1)) i++instance HasSpanInfo ImportSpec where+  getSpanInfo (Importing sp _) = sp+  getSpanInfo (Hiding    sp _) = sp++  setSpanInfo sp (Importing _ im) = Importing sp im+  setSpanInfo sp (Hiding    _ im) = Hiding sp im++  updateEndPos i@(Importing (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(Importing _ _) = i+  updateEndPos i@(Hiding (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(Hiding _ _) = i++instance HasSpanInfo Import where+  getSpanInfo (Import sp _)           = sp+  getSpanInfo (ImportTypeWith sp _ _) = sp+  getSpanInfo (ImportTypeAll sp _)    = sp++  setSpanInfo sp (Import _ qid)            = Import sp qid+  setSpanInfo sp (ImportTypeWith _ qid cs) = ImportTypeWith sp qid cs+  setSpanInfo sp (ImportTypeAll _ qid)     = ImportTypeAll sp qid++  updateEndPos i@(Import _ idt) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) i+  updateEndPos i@(ImportTypeWith (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(ImportTypeWith _ _ _) = i+  updateEndPos i@(ImportTypeAll (SpanInfo _ ss) _) =+    setEndPosition (end (last ss)) i+  updateEndPos i@(ImportTypeAll _ _) = i++instance HasSpanInfo ConstrDecl where+  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++  updateEndPos c@(ConstrDecl _ _ _ _ (t:ts)) =+    setEndPosition (getSrcSpanEnd (last (t:ts))) c+  updateEndPos c@(ConstrDecl _ _ _ idt _) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) c+  updateEndPos c@(ConOpDecl _ _ _ _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) c+  updateEndPos c@(RecordDecl (SpanInfo _ ss) _ _ _ _) =+    setEndPosition (end (last ss)) c+  updateEndPos c@(RecordDecl _ _ _ _ _) = c++instance HasSpanInfo NewConstrDecl where+  getSpanInfo (NewConstrDecl sp _ _)   = sp+  getSpanInfo (NewRecordDecl sp _ _)   = sp++  setSpanInfo sp (NewConstrDecl _ idt ty)  = NewConstrDecl sp idt ty+  setSpanInfo sp (NewRecordDecl _ idt fty) = NewRecordDecl sp idt fty++  updateEndPos c@(NewConstrDecl _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) c+  updateEndPos c@(NewRecordDecl (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) c+  updateEndPos c@(NewRecordDecl _ _ _) = c++instance HasSpanInfo FieldDecl where+    getSpanInfo (FieldDecl sp _ _) = sp+    setSpanInfo sp (FieldDecl _ idt ty) = FieldDecl sp idt ty+    updateEndPos d@(FieldDecl _ _ ty) =+      setEndPosition (getSrcSpanEnd ty) d++instance HasSpanInfo TypeExpr where+  getSpanInfo (ConstructorType sp _) = sp+  getSpanInfo (ApplyType sp _ _)     = sp+  getSpanInfo (VariableType sp _)    = sp+  getSpanInfo (TupleType sp _)       = sp+  getSpanInfo (ListType sp _)        = sp+  getSpanInfo (ArrowType sp _ _)     = sp+  getSpanInfo (ParenType sp _)       = sp+  getSpanInfo (ForallType sp _ _)    = sp++  setSpanInfo sp (ConstructorType _ qid) = ConstructorType sp qid+  setSpanInfo sp (ApplyType _ ty1 ty2)   = ApplyType sp ty1 ty2+  setSpanInfo sp (VariableType _ idt)    = VariableType sp idt+  setSpanInfo sp (TupleType _ tys)       = TupleType sp tys+  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 (ForallType _ idt ty)   = ForallType sp idt ty++  updateEndPos t@(ConstructorType _ qid) =+    setEndPosition (incr (getPosition qid) (qIdentLength qid - 1)) t+  updateEndPos t@(ApplyType _ _ t2) =+    setEndPosition (getSrcSpanEnd t2) t+  updateEndPos t@(VariableType _ idt) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) t+  updateEndPos t@(ListType (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) t+  updateEndPos t@(ListType _ _) = t+  updateEndPos t@(TupleType _ tys) =+    setEndPosition (getSrcSpanEnd (last tys)) t+  updateEndPos t@(ArrowType _ _ t2) =+    setEndPosition (getSrcSpanEnd t2) t+  updateEndPos t@(ParenType (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) t+  updateEndPos t@(ParenType _ _) = 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+  setSpanInfo sp (Constraint _ qid ty) = Constraint sp qid ty+  updateEndPos c@(Constraint (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) c+  updateEndPos c@(Constraint _ _ ty) =+    setEndPosition (getSrcSpanEnd ty) c++instance HasSpanInfo (Lhs a) where+  getSpanInfo (FunLhs sp _ _)   = sp+  getSpanInfo (OpLhs  sp _ _ _) = sp+  getSpanInfo (ApLhs  sp _ _)   = sp++  setSpanInfo sp (FunLhs _ idt ps)    = FunLhs sp idt ps+  setSpanInfo sp (OpLhs  _ p1 idt p2) = OpLhs sp p1 idt p2+  setSpanInfo sp (ApLhs  _ lhs ps)    = ApLhs sp lhs ps++  updateEndPos l@(FunLhs _ _ (p:ps)) =+    setEndPosition (getSrcSpanEnd (last (p:ps))) l+  updateEndPos l@(FunLhs _ idt _) =+    setEndPosition (incr (getPosition idt) (identLength idt - 1)) l+  updateEndPos l@(OpLhs _ _ _ p) =+    setEndPosition (getSrcSpanEnd p) l+  updateEndPos l@(ApLhs _ _ (p:ps)) =+    setEndPosition (getSrcSpanEnd (last (p:ps))) l+  updateEndPos l@(ApLhs (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) l+  updateEndPos l@(ApLhs _ _ _) = l+++instance HasSpanInfo (Rhs a) where+  getSpanInfo (SimpleRhs sp _ _)  = sp+  getSpanInfo (GuardedRhs sp _ _) = sp++  setSpanInfo sp (SimpleRhs _ ex ds)  = SimpleRhs sp ex ds+  setSpanInfo sp (GuardedRhs _ cs ds) = GuardedRhs sp cs ds++  updateEndPos r@(SimpleRhs (SpanInfo _ [_,_]) _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) r+  updateEndPos r@(SimpleRhs (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) r+  updateEndPos r@(SimpleRhs _ e _) =+    setEndPosition (getSrcSpanEnd e) r+  updateEndPos r@(GuardedRhs (SpanInfo _ [_,_]) _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) r+  updateEndPos r@(GuardedRhs (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) r+  updateEndPos r@(GuardedRhs _ cs _) =+    setEndPosition (getSrcSpanEnd (last cs)) r++instance HasSpanInfo (CondExpr a) where+  getSpanInfo (CondExpr sp _ _) = sp+  setSpanInfo sp (CondExpr _ e1 e2) = CondExpr sp e1 e2+  updateEndPos ce@(CondExpr _ _ e) =+    setEndPosition (getSrcSpanEnd e) ce++instance HasSpanInfo (Pattern a) where+  getSpanInfo (LiteralPattern  sp _ _)      = sp+  getSpanInfo (NegativePattern sp _ _)      = sp+  getSpanInfo (VariablePattern sp _ _)      = sp+  getSpanInfo (ConstructorPattern sp _ _ _) = sp+  getSpanInfo (InfixPattern sp _ _ _ _)     = sp+  getSpanInfo (ParenPattern sp _)           = sp+  getSpanInfo (RecordPattern sp _ _ _)      = sp+  getSpanInfo (TuplePattern sp _)           = sp+  getSpanInfo (ListPattern sp _ _)          = sp+  getSpanInfo (AsPattern sp _ _)            = sp+  getSpanInfo (LazyPattern sp _)            = sp+  getSpanInfo (FunctionPattern sp _ _ _)    = sp+  getSpanInfo (InfixFuncPattern sp _ _ _ _) = sp++  setSpanInfo sp (LiteralPattern _ a l) = LiteralPattern sp a l+  setSpanInfo sp (NegativePattern _ a l) = NegativePattern sp a l+  setSpanInfo sp (VariablePattern _ a v) = VariablePattern sp a v+  setSpanInfo sp (ConstructorPattern _ a c ts) = ConstructorPattern sp a c ts+  setSpanInfo sp (InfixPattern _ a t1 op t2) = InfixPattern sp a t1 op t2+  setSpanInfo sp (ParenPattern _ t) = ParenPattern sp t+  setSpanInfo sp (RecordPattern _ a c fs) = RecordPattern sp a c fs+  setSpanInfo sp (TuplePattern _ ts) = TuplePattern sp ts+  setSpanInfo sp (ListPattern _ a ts) = ListPattern sp a ts+  setSpanInfo sp (AsPattern _ v t) = AsPattern sp v t+  setSpanInfo sp (LazyPattern _ t) = LazyPattern sp t+  setSpanInfo sp (FunctionPattern _ a f' ts) = FunctionPattern sp a f' ts+  setSpanInfo sp (InfixFuncPattern _ a t1 op t2) = InfixFuncPattern sp a t1 op t2++  updateEndPos p@(LiteralPattern  _ _ _) = p+  updateEndPos p@(NegativePattern _ _ _) = p+  updateEndPos p@(VariablePattern _ _ v) =+    setEndPosition (incr (getPosition v) (identLength v - 1)) p+  updateEndPos p@(ConstructorPattern _ _ _ (t:ts)) =+    setEndPosition (getSrcSpanEnd (last (t:ts))) p+  updateEndPos p@(ConstructorPattern _ _ c _) =+    setEndPosition (incr (getPosition c) (qIdentLength c - 1)) p+  updateEndPos p@(InfixPattern _ _ _ _ t2) =+    setEndPosition (getSrcSpanEnd t2) p+  updateEndPos p@(ParenPattern (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(ParenPattern _ _) = p+  updateEndPos p@(RecordPattern (SpanInfo _ (s:ss)) _ _ _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(RecordPattern _ _ _ _) = p+  updateEndPos p@(TuplePattern (SpanInfo _ (s:ss)) _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(TuplePattern _ _) = p+  updateEndPos p@(ListPattern (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) p+  updateEndPos p@(ListPattern _ _ _) = p+  updateEndPos p@(AsPattern _ _ t) =+    setEndPosition (getSrcSpanEnd t) p+  updateEndPos p@(LazyPattern _ t) =+    setEndPosition (getSrcSpanEnd t) p+  updateEndPos p@(FunctionPattern _ _ _ _) = p+  updateEndPos p@(InfixFuncPattern _ _ _ _ _) = p++instance HasSpanInfo (Expression a) where+  getSpanInfo (Literal sp _ _) = sp+  getSpanInfo (Variable sp _ _) = sp+  getSpanInfo (Constructor sp _ _) = sp+  getSpanInfo (Paren sp _) = sp+  getSpanInfo (Typed sp _ _) = sp+  getSpanInfo (Record sp _ _ _) = sp+  getSpanInfo (RecordUpdate sp _ _) = sp+  getSpanInfo (Tuple sp _) = sp+  getSpanInfo (List sp _ _) = sp+  getSpanInfo (ListCompr sp _ _) = sp+  getSpanInfo (EnumFrom sp _) = sp+  getSpanInfo (EnumFromThen sp _ _) = sp+  getSpanInfo (EnumFromTo sp _ _) = sp+  getSpanInfo (EnumFromThenTo sp _ _ _) = sp+  getSpanInfo (UnaryMinus sp _) = sp+  getSpanInfo (Apply sp _ _) = sp+  getSpanInfo (InfixApply sp _ _ _) = sp+  getSpanInfo (LeftSection sp _ _) = sp+  getSpanInfo (RightSection sp _ _) = sp+  getSpanInfo (Lambda sp _ _) = sp+  getSpanInfo (Let sp _ _) = sp+  getSpanInfo (Do sp _ _) = sp+  getSpanInfo (IfThenElse sp _ _ _) = sp+  getSpanInfo (Case sp _ _ _) = sp++  setSpanInfo sp (Literal _ a l) = Literal sp a l+  setSpanInfo sp (Variable _ a v) = Variable sp a v+  setSpanInfo sp (Constructor _ a c) = Constructor sp a c+  setSpanInfo sp (Paren _ e) = Paren sp e+  setSpanInfo sp (Typed _ e qty) = Typed sp e qty+  setSpanInfo sp (Record _ a c fs) = Record sp a c fs+  setSpanInfo sp (RecordUpdate _ e fs) = RecordUpdate sp e fs+  setSpanInfo sp (Tuple _ es) = Tuple sp es+  setSpanInfo sp (List _ a es) = List sp a es+  setSpanInfo sp (ListCompr _ e stms) = ListCompr sp e stms+  setSpanInfo sp (EnumFrom _ e) = EnumFrom sp e+  setSpanInfo sp (EnumFromThen _ e1 e2) = EnumFromThen sp e1 e2+  setSpanInfo sp (EnumFromTo _ e1 e2) = EnumFromTo sp e1 e2+  setSpanInfo sp (EnumFromThenTo _ e1 e2 e3) = EnumFromThenTo sp e1 e2 e3+  setSpanInfo sp (UnaryMinus _ e) = UnaryMinus sp e+  setSpanInfo sp (Apply _ e1 e2) = Apply sp e1 e2+  setSpanInfo sp (InfixApply _ e1 op e2) = InfixApply sp e1 op e2+  setSpanInfo sp (LeftSection _ e op) = LeftSection sp e op+  setSpanInfo sp (RightSection _ op e) = RightSection sp op e+  setSpanInfo sp (Lambda _ ts e) = Lambda sp ts e+  setSpanInfo sp (Let _ ds e) = Let sp ds e+  setSpanInfo sp (Do _ stms e) = Do sp stms e+  setSpanInfo sp (IfThenElse _ e1 e2 e3) = IfThenElse sp e1 e2 e3+  setSpanInfo sp (Case _ ct e as) = Case sp ct e as++  updateEndPos e@(Literal _ _ _) = e+  updateEndPos e@(Variable _ _ v) =+    setEndPosition (incr (getPosition v) (qIdentLength v - 1)) e+  updateEndPos e@(Constructor _ _ c) =+    setEndPosition (incr (getPosition c) (qIdentLength c - 1)) e+  updateEndPos e@(Paren (SpanInfo _ [_,s]) _) =+    setEndPosition (end s) e+  updateEndPos e@(Paren _ _) = e+  updateEndPos e@(Typed _ _ qty) =+    setEndPosition (getSrcSpanEnd qty) e+  updateEndPos e@(Record (SpanInfo _ (s:ss)) _ _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(Record _ _ _ _) = e+  updateEndPos e@(RecordUpdate (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(RecordUpdate _ _ _) = e+  updateEndPos e@(Tuple (SpanInfo _ [_,s]) _) =+    setEndPosition (end s) e+  updateEndPos e@(Tuple _ _) = e+  updateEndPos e@(List (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(List _ _ _) = e+  updateEndPos e@(ListCompr (SpanInfo _ (s:ss)) _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(ListCompr _ _ _) = e+  updateEndPos e@(EnumFrom (SpanInfo _ [_,_,s]) _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFrom _ _) = e+  updateEndPos e@(EnumFromTo (SpanInfo _ [_,_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFromTo _ _ _) = e+  updateEndPos e@(EnumFromThen (SpanInfo _ [_,_,_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFromThen _ _ _) = e+  updateEndPos e@(EnumFromThenTo (SpanInfo _ [_,_,_,s]) _ _ _) =+    setEndPosition (end s) e+  updateEndPos e@(EnumFromThenTo _ _ _ _) = e+  updateEndPos e@(UnaryMinus _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Apply _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(InfixApply _ _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(LeftSection (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(LeftSection _ _ _) = e+  updateEndPos e@(RightSection (SpanInfo _ [_,s]) _ _) =+    setEndPosition (end s) e+  updateEndPos e@(RightSection _ _ _) = e+  updateEndPos e@(Lambda _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Let _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Do _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(IfThenElse _ _ _ e') =+    setEndPosition (getSrcSpanEnd e') e+  updateEndPos e@(Case _ _ _ (a:as)) =+    setEndPosition (getSrcSpanEnd (last (a:as))) e+  updateEndPos e@(Case (SpanInfo _ (s:ss)) _ _ _) =+    setEndPosition (end (last (s:ss))) e+  updateEndPos e@(Case _ _ _ _) = e++instance HasSpanInfo (Statement a) where+  getSpanInfo (StmtExpr sp _)   = sp+  getSpanInfo (StmtDecl sp _)   = sp+  getSpanInfo (StmtBind sp _ _) = sp++  setSpanInfo sp (StmtExpr _ ex)   = StmtExpr sp ex+  setSpanInfo sp (StmtDecl _ ds)   = StmtDecl sp ds+  setSpanInfo sp (StmtBind _ p ex) = StmtBind sp p ex++  updateEndPos s@(StmtExpr _ e) =+    setEndPosition (getSrcSpanEnd e) s+  updateEndPos s@(StmtBind _ _ e) =+    setEndPosition (getSrcSpanEnd e) s+  updateEndPos s@(StmtDecl _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) s+  updateEndPos s@(StmtDecl (SpanInfo _ [s']) _) = -- empty let+    setEndPosition (end s') s+  updateEndPos s@(StmtDecl _ _) = s++instance HasSpanInfo (Alt a) where+  getSpanInfo (Alt sp _ _) = sp+  setSpanInfo sp (Alt _ p rhs) = Alt sp p rhs+  updateEndPos a@(Alt _ _ rhs) =+    setEndPosition (getSrcSpanEnd rhs) a++instance HasSpanInfo (Field a) where+  getSpanInfo (Field sp _ _) = sp+  setSpanInfo sp (Field _ qid a) = Field sp qid a+  updateEndPos f@(Field (SpanInfo _ ss) _ _) =+    setEndPosition (end (last ss)) f+  updateEndPos f@ (Field _ _ _) = f++instance HasSpanInfo (Goal a) where+  getSpanInfo (Goal sp _ _) = sp+  setSpanInfo sp (Goal _ e ds) = Goal sp e ds++  updateEndPos g@(Goal (SpanInfo _ [_]) _ (d:ds)) =+    setEndPosition (getSrcSpanEnd (last (d:ds))) g+  updateEndPos g@(Goal (SpanInfo _ [s]) _ _) =+    setEndPosition (end s) g+  updateEndPos g@(Goal _ _ _) = g++instance HasPosition (Module a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Decl a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Equation a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ModulePragma where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ExportSpec where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ImportDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ImportSpec where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition Export where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition Import where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition ConstrDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition TypeExpr where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition QualTypeExpr where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition NewConstrDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition Constraint where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition FieldDecl where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Lhs a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Rhs a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (CondExpr a) where+  getPosition = getStartPosition++instance HasPosition (Pattern a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Expression a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Alt a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Goal a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Field a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (Statement a) where+  getPosition = getStartPosition+  setPosition = setStartPosition++instance HasPosition (InfixOp a) where+  getPosition (InfixOp     _ q) = getPosition q+  getPosition (InfixConstr _ q) = getPosition q++  setPosition p (InfixOp     a q) = InfixOp     a (setPosition p q)+  setPosition p (InfixConstr a q) = InfixConstr a (setPosition p q)

@@ -33,12 +33,14 @@   , nconstrType   , recordLabels, nrecordLabels   , methods, impls, imethod, imethodArity+  , shortenModuleAST   ) where  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 import Curry.Syntax.Type@@ -49,14 +51,14 @@  -- |Extract all known extensions from a 'Module' knownExtensions :: Module a -> [KnownExtension]-knownExtensions (Module ps _ _ _ _) =+knownExtensions (Module _ ps _ _ _ _) =   [ e | LanguagePragma _ exts <- ps, KnownExtension _ e <- exts]  -- |Replace the generic module name @main@ with the module name derived -- from the 'FilePath' of the module. patchModuleId :: FilePath -> Module a -> Module a-patchModuleId fn m@(Module ps mid es is ds)-  | mid == mainMIdent = Module ps (mkMIdent [takeBaseName fn]) es is ds+patchModuleId fn m@(Module spi ps mid es is ds)+  | mid == mainMIdent = Module spi ps (mkMIdent [takeBaseName fn]) es is ds   | otherwise         = m  -- |Is the declaration a top declaration?@@ -124,52 +126,52 @@  -- |Is the pattern semantically equivalent to a variable pattern? isVariablePattern :: Pattern a -> Bool-isVariablePattern (VariablePattern _ _) = True-isVariablePattern (ParenPattern      t) = isVariablePattern t-isVariablePattern (AsPattern       _ t) = isVariablePattern t-isVariablePattern (LazyPattern       _) = True-isVariablePattern _                     = False+isVariablePattern (VariablePattern _ _ _) = True+isVariablePattern (ParenPattern    _   t) = isVariablePattern t+isVariablePattern (AsPattern       _ _ t) = isVariablePattern t+isVariablePattern (LazyPattern     _   _) = True+isVariablePattern _                       = False  -- |Is a type expression a type variable? isVariableType :: TypeExpr -> Bool-isVariableType (VariableType _) = True-isVariableType _                = False+isVariableType (VariableType _ _) = True+isVariableType _                  = False  -- |Is a type expression simple, i.e., is it of the form T u_1 ... u_n, -- where T is a type constructor and u_1 ... u_n are type variables? isSimpleType :: TypeExpr -> Bool-isSimpleType (ConstructorType _) = True-isSimpleType (ApplyType ty1 ty2) = isSimpleType ty1 && isVariableType ty2-isSimpleType (VariableType    _) = False-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 (ForallType    _ _) = False+isSimpleType (ConstructorType _ _) = True+isSimpleType (ApplyType _ ty1 ty2) = isSimpleType ty1 && isVariableType ty2+isSimpleType (VariableType   _  _) = False+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 (ForallType    _ _ _) = False  -- |Return the qualified type constructor of a type expression. typeConstr :: TypeExpr -> QualIdent-typeConstr (ConstructorType   tc) = tc-typeConstr (ApplyType       ty _) = typeConstr ty-typeConstr (TupleType        tys) = qTupleId (length tys)-typeConstr (ListType           _) = qListId-typeConstr (ArrowType        _ _) = qArrowId-typeConstr (ParenType         ty) = typeConstr ty-typeConstr (VariableType       _) =+typeConstr (ConstructorType   _ tc) = tc+typeConstr (ApplyType       _ ty _) = typeConstr ty+typeConstr (TupleType        _ tys) = qTupleId (length tys)+typeConstr (ListType           _ _) = qListId+typeConstr (ArrowType        _ _ _) = qArrowId+typeConstr (ParenType         _ ty) = typeConstr ty+typeConstr (VariableType       _ _) =   error "Curry.Syntax.Utils.typeConstr: variable type"-typeConstr (ForallType       _ _) =+typeConstr (ForallType       _ _ _) =   error "Curry.Syntax.Utils.typeConstr: forall type"  -- |Return the list of variables occuring in a type expression. typeVariables :: TypeExpr -> [Ident]-typeVariables (ConstructorType       _) = []-typeVariables (ApplyType       ty1 ty2) = typeVariables ty1 ++ typeVariables ty2-typeVariables (VariableType         tv) = [tv]-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 (ForallType        vs ty) = vs ++ typeVariables ty+typeVariables (ConstructorType       _ _) = []+typeVariables (ApplyType       _ ty1 ty2) = typeVariables ty1 ++ typeVariables ty2+typeVariables (VariableType         _ tv) = [tv]+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 (ForallType        _ vs ty) = vs ++ typeVariables ty  -- |Return the identifier of a variable. varIdent :: Var a -> Ident@@ -177,15 +179,15 @@  -- |Convert an infix operator into an expression infixOp :: InfixOp a -> Expression a-infixOp (InfixOp     a op) = Variable a op-infixOp (InfixConstr a op) = Constructor a op+infixOp (InfixOp     a op) = Variable NoSpanInfo a op+infixOp (InfixConstr a op) = Constructor NoSpanInfo a op  -- |flatten the left-hand-side to the identifier and all constructor terms flatLhs :: Lhs a -> (Ident, [Pattern a]) flatLhs lhs = flat lhs []-  where flat (FunLhs    f ts) ts' = (f, ts ++ ts')-        flat (OpLhs t1 op t2) ts' = (op, t1 : t2 : ts')-        flat (ApLhs  lhs' ts) ts' = flat lhs' (ts ++ ts')+  where flat (FunLhs    _ f ts) ts' = (f, ts ++ ts')+        flat (OpLhs _ t1 op t2) ts' = (op, t1 : t2 : ts')+        flat (ApLhs  _ lhs' ts) ts' = flat lhs' (ts ++ ts')  -- |Return the arity of an equation. eqnArity :: Equation a -> Int@@ -257,36 +259,62 @@ -- constructing elements of the abstract syntax tree -------------------------------------------------------- -funDecl :: Position -> a -> Ident -> [Pattern a] -> Expression a -> Decl a-funDecl p a f ts e = FunctionDecl p a f [mkEquation p f ts e]+funDecl :: SpanInfo -> a -> Ident -> [Pattern a] -> Expression a -> Decl a+funDecl spi a f ts e = FunctionDecl spi a f [mkEquation spi f ts e] -mkEquation :: Position -> Ident -> [Pattern a] -> Expression a -> Equation a-mkEquation p f ts e = Equation p (FunLhs f ts) (simpleRhs p e)+mkEquation :: SpanInfo -> Ident -> [Pattern a] -> Expression a -> Equation a+mkEquation spi f ts e = Equation spi (FunLhs NoSpanInfo f ts) (simpleRhs NoSpanInfo e) -simpleRhs :: Position -> Expression a -> Rhs a-simpleRhs p e = SimpleRhs p e []+simpleRhs :: SpanInfo -> Expression a -> Rhs a+simpleRhs spi e = SimpleRhs spi e [] -patDecl :: Position -> Pattern a -> Expression a -> Decl a-patDecl p t e = PatternDecl p t (SimpleRhs p e [])+patDecl :: SpanInfo -> Pattern a -> Expression a -> Decl a+patDecl spi t e = PatternDecl spi t (SimpleRhs spi e []) -varDecl :: Position -> a -> Ident -> Expression a -> Decl a-varDecl p ty = patDecl p . VariablePattern ty+varDecl :: SpanInfo -> a -> Ident -> Expression a -> Decl a+varDecl p ty = patDecl p . VariablePattern NoSpanInfo ty  constrPattern :: a -> QualIdent -> [(a, Ident)] -> Pattern a-constrPattern ty c = ConstructorPattern ty c . map (uncurry VariablePattern)+constrPattern ty c = ConstructorPattern NoSpanInfo ty c+                   . map (uncurry (VariablePattern NoSpanInfo)) -caseAlt :: Position -> Pattern a -> Expression a -> Alt a-caseAlt p t e = Alt p t (SimpleRhs p e [])+caseAlt :: SpanInfo -> Pattern a -> Expression a -> Alt a+caseAlt spi t e = Alt spi t (SimpleRhs spi e [])  mkLet :: [Decl a] -> Expression a -> Expression a-mkLet ds e = if null ds then e else Let ds e+mkLet ds e = if null ds then e else Let NoSpanInfo ds e  mkVar :: a -> Ident -> Expression a-mkVar ty = Variable ty . qualify+mkVar ty = Variable NoSpanInfo ty . qualify  apply :: Expression a -> [Expression a] -> Expression a-apply = foldl Apply+apply = foldl (Apply NoSpanInfo)  unapply :: Expression a -> [Expression a] -> (Expression a, [Expression a])-unapply (Apply e1 e2) es = unapply e1 (e2 : es)-unapply e             es = (e, es)+unapply (Apply _ e1 e2) es = unapply e1 (e2 : es)+unapply e               es = (e, es)+++--------------------------------------------------------+-- Shorten Module+-- Module Pragmas and Equations will be removed+--------------------------------------------------------++shortenModuleAST :: Module () -> Module ()+shortenModuleAST = shortenAST++class ShortenAST a where+  shortenAST :: a -> a++instance ShortenAST (Module a) where+  shortenAST (Module spi _ mid ex im ds) =+    Module spi [] mid ex im (map shortenAST ds)++instance ShortenAST (Decl a) where+  shortenAST (FunctionDecl spi a idt _) =+    FunctionDecl spi a idt []+  shortenAST (ClassDecl spi cx cls tyv ds) =+    ClassDecl spi cx cls tyv (map shortenAST ds)+  shortenAST (InstanceDecl spi cx cls tyv ds) =+    InstanceDecl spi cx cls tyv (map shortenAST ds)+  shortenAST d = d