diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ Change log for curry-base ========================= +Version (1.1.0) +=================================== + + * Added SpanInfos to AST + Version (1.0.0) =============== diff --git a/curry-base.cabal b/curry-base.cabal --- a/curry-base.cabal +++ b/curry-base.cabal @@ -1,5 +1,5 @@ Name: curry-base -Version: 1.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 diff --git a/src/Curry/Base/Ident.hs b/src/Curry/Base/Ident.hs --- a/src/Curry/Base/Ident.hs +++ b/src/Curry/Base/Ident.hs @@ -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 diff --git a/src/Curry/Base/LLParseComb.hs b/src/Curry/Base/LLParseComb.hs --- a/src/Curry/Base/LLParseComb.hs +++ b/src/Curry/Base/LLParseComb.hs @@ -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 diff --git a/src/Curry/Base/Message.hs b/src/Curry/Base/Message.hs --- a/src/Curry/Base/Message.hs +++ b/src/Curry/Base/Message.hs @@ -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) diff --git a/src/Curry/Base/Position.hs b/src/Curry/Base/Position.hs --- a/src/Curry/Base/Position.hs +++ b/src/Curry/Base/Position.hs @@ -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 diff --git a/src/Curry/Base/Pretty.hs b/src/Curry/Base/Pretty.hs --- a/src/Curry/Base/Pretty.hs +++ b/src/Curry/Base/Pretty.hs @@ -19,6 +19,10 @@ , module Text.PrettyPrint ) where +#if __GLASGOW_HASKELL__ >= 804 +import Prelude hiding ((<>)) +#endif + import Text.PrettyPrint -- | Pretty printing class. diff --git a/src/Curry/Base/Span.hs b/src/Curry/Base/Span.hs --- a/src/Curry/Base/Span.hs +++ b/src/Curry/Base/Span.hs @@ -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 diff --git a/src/Curry/Base/SpanInfo.hs b/src/Curry/Base/SpanInfo.hs new file mode 100644 --- /dev/null +++ b/src/Curry/Base/SpanInfo.hs @@ -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 diff --git a/src/Curry/CondCompile/Type.hs b/src/Curry/CondCompile/Type.hs --- a/src/Curry/CondCompile/Type.hs +++ b/src/Curry/CondCompile/Type.hs @@ -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 diff --git a/src/Curry/Files/Filenames.hs b/src/Curry/Files/Filenames.hs --- a/src/Curry/Files/Filenames.hs +++ b/src/Curry/Files/Filenames.hs @@ -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 diff --git a/src/Curry/FlatCurry/Annotated/Goodies.hs b/src/Curry/FlatCurry/Annotated/Goodies.hs --- a/src/Curry/FlatCurry/Annotated/Goodies.hs +++ b/src/Curry/FlatCurry/Annotated/Goodies.hs @@ -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 diff --git a/src/Curry/FlatCurry/Annotated/Type.hs b/src/Curry/FlatCurry/Annotated/Type.hs --- a/src/Curry/FlatCurry/Annotated/Type.hs +++ b/src/Curry/FlatCurry/Annotated/Type.hs @@ -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 diff --git a/src/Curry/FlatCurry/Annotated/Typing.hs b/src/Curry/FlatCurry/Annotated/Typing.hs deleted file mode 100644 --- a/src/Curry/FlatCurry/Annotated/Typing.hs +++ /dev/null @@ -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 diff --git a/src/Curry/FlatCurry/Typeable.hs b/src/Curry/FlatCurry/Typeable.hs new file mode 100644 --- /dev/null +++ b/src/Curry/FlatCurry/Typeable.hs @@ -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 diff --git a/src/Curry/FlatCurry/Typed/Goodies.hs b/src/Curry/FlatCurry/Typed/Goodies.hs new file mode 100644 --- /dev/null +++ b/src/Curry/FlatCurry/Typed/Goodies.hs @@ -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 diff --git a/src/Curry/FlatCurry/Typed/Type.hs b/src/Curry/FlatCurry/Typed/Type.hs new file mode 100644 --- /dev/null +++ b/src/Curry/FlatCurry/Typed/Type.hs @@ -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 diff --git a/src/Curry/Syntax/Extension.hs b/src/Curry/Syntax/Extension.hs --- a/src/Curry/Syntax/Extension.hs +++ b/src/Curry/Syntax/Extension.hs @@ -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. diff --git a/src/Curry/Syntax/InterfaceEquivalence.hs b/src/Curry/Syntax/InterfaceEquivalence.hs --- a/src/Curry/Syntax/InterfaceEquivalence.hs +++ b/src/Curry/Syntax/InterfaceEquivalence.hs @@ -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 diff --git a/src/Curry/Syntax/Lexer.hs b/src/Curry/Syntax/Lexer.hs --- a/src/Curry/Syntax/Lexer.hs +++ b/src/Curry/Syntax/Lexer.hs @@ -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 diff --git a/src/Curry/Syntax/Parser.hs b/src/Curry/Syntax/Parser.hs --- a/src/Curry/Syntax/Parser.hs +++ b/src/Curry/Syntax/Parser.hs @@ -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 ::= 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 ::= | | | 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 diff --git a/src/Curry/Syntax/Pretty.hs b/src/Curry/Syntax/Pretty.hs --- a/src/Curry/Syntax/Pretty.hs +++ b/src/Curry/Syntax/Pretty.hs @@ -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" diff --git a/src/Curry/Syntax/ShowModule.hs b/src/Curry/Syntax/ShowModule.hs --- a/src/Curry/Syntax/ShowModule.hs +++ b/src/Curry/Syntax/ShowModule.hs @@ -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 ")" diff --git a/src/Curry/Syntax/Type.hs b/src/Curry/Syntax/Type.hs --- a/src/Curry/Syntax/Type.hs +++ b/src/Curry/Syntax/Type.hs @@ -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) diff --git a/src/Curry/Syntax/Utils.hs b/src/Curry/Syntax/Utils.hs --- a/src/Curry/Syntax/Utils.hs +++ b/src/Curry/Syntax/Utils.hs @@ -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