Commits (19)
......@@ -10,6 +10,7 @@ browser/BrowserGUI
browser/GenInt
browser/ShowFlatCurry
browser/SourceProgGUI
casc/CASC
CASS/cass
CASS/cass_worker
createmakefile/CreateMakefile
......
......@@ -3,13 +3,13 @@
--- persistently in files.
---
--- @author Heiko Hoffmann, Michael Hanus
--- @version July 2016
--- @version October 2016
--------------------------------------------------------------------------
module LoadAnalysis where
import Directory
import Distribution(stripCurrySuffix)
import Distribution(installDir, stripCurrySuffix)
import FlatCurry.Types(QName)
import FilePath
import FiniteMap
......@@ -40,11 +40,13 @@ getAnalysisPublicFile :: String -> String -> IO String
getAnalysisPublicFile modname ananame = do
getAnalysisBaseFile modname ananame >>= return . (<.> "pub")
-- directory where analysis info files are stored ($HOME has to be set)
-- Directory where analysis info files are stored in subdirectory `.curry`.
-- Usually, it is $HOME.
getAnalysisDirectory :: IO String
getAnalysisDirectory = do
homeDir <- getHomeDirectory
return (homeDir </> ".curry" </> "Analysis")
let cassStoreDir = if null homeDir then installDir else homeDir
return $ cassStoreDir </> ".curry" </> "Analysis"
-- loads analysis results for a list of modules
getInterfaceInfos :: String -> [String] -> IO (ProgInfo a)
......
......@@ -7,9 +7,11 @@
module Main(main) where
import Char (toLower)
import Distribution (stripCurrySuffix)
import FilePath ((</>), (<.>))
import GetOpt
import List (isPrefixOf)
import ReadNumeric (readNat)
import Sort (sort)
import System (exitWith,getArgs)
......@@ -42,22 +44,33 @@ main = do
debugMessage 1 systemBanner
if optServer opts
then mainServer (let p = optPort opts in if p == 0 then Nothing else Just p)
else let [ananame,mname] = args
in if ananame `elem` registeredAnalysisNames
then analyzeModuleAsText ananame (stripCurrySuffix mname)
(optReAna opts) >>= putStrLn
else anaUnknownError ananame
else do let [ananame,mname] = args
fullananame <- checkAnalysisName ananame
putStrLn $ "Computing results for analysis `" ++ fullananame ++ "'"
analyzeModuleAsText fullananame (stripCurrySuffix mname)
(optReAna opts) >>= putStrLn
where
deleteFiles args = case args of
[aname] -> if aname `elem` registeredAnalysisNames
then deleteAllAnalysisFiles aname >> exitWith 0
else anaUnknownError aname
[aname] -> do fullaname <- checkAnalysisName aname
putStrLn $ "Deleting files for analysis `" ++ fullaname ++ "'"
deleteAllAnalysisFiles fullaname
exitWith 0
[] -> error "Missing analysis name!"
_ -> error "Too many arguments (only analysis name should be given)!"
anaUnknownError aname =
error $ "Unknown analysis name `"++ aname ++ "' (try `-h' for help)"
-- Checks whether a given analysis name is a unique abbreviation
-- of a registered analysis name and return the registered name.
-- Otherwise, raise an error.
checkAnalysisName :: String -> IO String
checkAnalysisName aname = case matchedNames of
[] -> error $ "Unknown analysis name `"++ aname ++ "' " ++ tryCmt
[raname] -> return raname
(_:_:_) -> error $ "Analysis name `"++ aname ++ "' not unique " ++ tryCmt ++
":\nPossible names are: " ++ unwords matchedNames
where
matchedNames = filter (isPrefixOf (map toLower aname) . map toLower)
registeredAnalysisNames
tryCmt = "(try `-h' for help)"
--------------------------------------------------------------------------
-- Representation of command line options.
......@@ -133,11 +146,11 @@ printHelp :: [String] -> IO ()
printHelp args =
if null args
then putStrLn usageText
else let aname = head args
in getAnalysisDoc aname >>=
maybe (putStrLn $
"Sorry, no documentation for analysis `" ++ aname ++ "'")
putStrLn
else do aname <- checkAnalysisName (head args)
getAnalysisDoc aname >>=
maybe (putStrLn $
"Sorry, no documentation for analysis `" ++ aname ++ "'")
putStrLn
-- Help text
usageText :: String
......
Copyright (c) 2011-2016, Michael Hanus
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
- Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
- Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
- None of the names of the copyright holders and contributors may be
used to endorse or promote products derived from this software without
specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
......@@ -4,7 +4,7 @@ Curry Tools
This directory contains various tools for Curry
that are used by different Curry systems, like PAKCS or KiCS2.
Currently it contains:
Currently, it contains the following tools:
`addtypes`:
A tool that adds type signatures to a given Curry program.
......@@ -17,6 +17,9 @@ These are used in the `CASS` and `currydoc` tools.
A tool to browse through the modules and functions of a Curry program,
show them in various formats, and analyze their properties.
`casc`:
A style checker for Curry programs.
`CASS`:
This directory contains the implementation of the
Curry Analysis Server System, a generic and distributed analysis system
......@@ -32,22 +35,20 @@ generation of web user interfaces (WUIs).
`currycheck`:
A property test tool for Curry programs.
`currytest`:
A test tool for Curry programs.
`currydoc`:
A documentation generator for Curry programs.
`currypp`:
A preprocessor for Curry programs implementing integrated code,
default rules, deterministic functions, and dynamic contract checking.
`ertool`:
`currytest`:
A test tool for Curry programs.
`ertools`:
Compilers to translate database (ER) models
into Curry programs providing high-level access to relational databases.
`genint`:
A program for generating module interfaces and source code
of a Curry module (used by the commands ":interface" and ":show"
of some Curry systems).
`importcalls`:
A tool to show all calls to imported functions in a module.
......
......@@ -3,7 +3,7 @@
--- programs.
---
--- @author Michael Hanus
--- @version July 2016
--- @version September 2016
---------------------------------------------------------------------
module BrowserGUI where
......@@ -49,7 +49,7 @@ title :: String
title = "CurryBrowser"
version :: String
version = "Version of 29/07/2016"
version = "Version of 07/09/2016"
patchReadmeVersion :: IO ()
patchReadmeVersion = do
......@@ -72,9 +72,10 @@ main = do
start :: String -> IO ()
start modpath = do
initializeAnalysisSystem
putStrLn "Please be patient, reading all interfaces..."
putStr "Please be patient, reading all interfaces..."
helptxt <- readFile (browserDir++"/README")
mods <- getImportedInterfaces modpath
putStrLn "done"
let mainmod = progName (progOfIFFP (snd (head mods)))
trees = [Leaf mainmod
(mainmod,map (moduleImports . progOfIFFP . snd) mods)]
......
......@@ -12,7 +12,7 @@ they have no effect.
Developed by
Michael Hanus (CAU Kiel, Germany, mh@informatik.uni-kiel.de)
Version of 29/07/2016
Version of 07/09/2016
Software requirements:
......
......@@ -103,8 +103,8 @@ showInterface genstub (Prog mod imports types funcs ops) = unlines $
(if null ops then [] else [""]) ++
concatMap (showInterfaceType (showQNameInModule mod))
(sortBy leqType types) ++ [""] ++
map (showInterfaceFunc (showQNameInModule mod) genstub)
(sortBy leqFunc funcs)
concatMap (showInterfaceFunc (showQNameInModule mod) genstub)
(sortBy leqFunc funcs)
-- Get a FlatCurry program (parse only if necessary):
getFlatInt :: String -> IO Prog
......@@ -165,13 +165,13 @@ showExportConsDecl tt (Cons (_,cname) _ _ argtypes) =
-- show function type declaration if it is not an internal
-- operation to implement type classes
showInterfaceFunc :: (QName -> String) -> Bool -> FuncDecl -> String
showInterfaceFunc :: (QName -> String) -> Bool -> FuncDecl -> [String]
showInterfaceFunc ttrans genstub (Func (_,fname) _ vis ftype _) =
if vis==Public && not (classOperations fname)
then showCurryId fname ++ " :: " ++
showCurryType ttrans False ftype ++
(if genstub then "\n" ++ showCurryId fname ++ " external\n" else "")
else ""
then [showCurryId fname ++ " :: " ++
showCurryType ttrans False ftype ++
(if genstub then "\n" ++ showCurryId fname ++ " external\n" else "")]
else []
where
classOperations fn = take 6 fn `elem` ["_impl#","_inst#"]
|| take 5 fn == "_def#" || take 7 fn == "_super#"
......
{- |
Module : AST.ASM
Description : Add Span Monad
This module contains the Add Span Monad, which contains the token stream,
some functions on the ASM and functions for parsing the token stream.
-}
module AST.ASM where
import AST.AST
import AST.Span (Span)
import AST.Token
-- -----------------------------------------------------------------------------
-- *A*dd *P*osition *M*onad with functions
-- -----------------------------------------------------------------------------
-- |List containing tuples of positions and tokens: the token stream
type SpanTokens = [(Span, Token)]
-- |*A*dd *P*osition *M*onad
type ASM a = SpanTokens -> (a, SpanTokens)
returnP :: a -> ASM a
returnP x ts = (x, ts)
(>+=) :: ASM a -> (a -> ASM b) -> ASM b
m >+= f = \ts -> let (a, ts') = m ts in f a ts'
(>+) :: ASM a -> ASM b -> ASM b
m >+ m' = m >+= \ _ -> m'
(<$>) :: (a -> b) -> ASM a -> ASM b
f <$> m = m >+= \x -> returnP (f x)
(<*>) :: ASM (a -> b) -> ASM a -> ASM b
mf <*> mx = mf >+= \f -> mx >+= \x -> returnP (f x)
mapM :: (a -> ASM b) -> [a] -> ASM [b]
mapM _ [] = returnP []
mapM f (x:xs) = f x >+= \ y ->
mapM f xs >+= \ ys ->
returnP (y : ys)
-- -----------------------------------------------------------------------------
-- Functions for parsing the token stream
-- -----------------------------------------------------------------------------
-- |Read the next position without changing the state
readSpan :: ASM Span
readSpan ts@((p, _) : _) = (p, ts)
readSpan [] = error "Token stream is empty."
-- |Read the next token without changing the state
readToken :: ASM Token
readToken ts@((_, t) : _) = (t, ts)
readToken [] = error "Token stream is empty."
-- |Ensure a predicate. If predicate is `False`, fail.
ensure :: Show a => Bool -> a -> ASM a
ensure b x = if b
then returnP x
else error $ "Function `ensure` failed (AST.ASM). "
++ "This should have been returned: " ++ show x
-- |Return position of token t
tokenSpan :: Token -> ASM Span
tokenSpan t = getTokenSpan >+= \(p, t') -> ensure (t == t') p
-- |Get the next position, removing it from the state
getTokenSpan :: ASM (Span, Token)
getTokenSpan (t : ts) = (t, ts)
getTokenSpan [] = error "Token stream is empty."
-- |Get position of the next token which can be one of two possible alternatives
tokenSpanOneOf :: Token -> Token -> ASM Span
tokenSpanOneOf t1 t2 ((p,t') : ts)
| t1 == t' = (p, ts)
| t2 == t' = (p, ts)
| otherwise = error $ "expexted " ++ show t1 ++ " or "
++ show t2 ++ ", got " ++ show t'
tokenSpanOneOf _ _ [] = error "Token stream is empty."
-- |Parse a chain of expressions, separated by a Token, e.g. a list: [1,2,3]
-- Process the expressions further with a function f, e.g. apLit
sepBy :: (a -> ASM b) -> ASM Span -> [a] -> ASM ([b], [Span])
sepBy f s ys = case ys of
[] -> returnP ([], [])
[x] -> f x >+= \ px -> returnP ([px], [])
(x:xs) -> f x >+= \ px ->
s >+= \ ps ->
sepBy f s xs >+= \ (pxs, pss) ->
returnP (px : pxs, ps : pss)
-- |Parse an expression surrounded by some kind of opening and closing symbols
between :: ASM a -> ASM b -> ASM c -> ASM (a, b, c)
between open f close =
open >+= \ po ->
f >+= \ pf ->
close >+= \ pc ->
returnP (po, pf, pc)
-- |Parse an expression that is surrounded by parens
parens :: ASM a -> ASM (Span, a, Span)
parens f = between (tokenSpan LeftParen) f (tokenSpan RightParen)
-- |Parse an expression that is surrounded by brackets
brackets :: ASM a -> ASM (Span, a, Span)
brackets f = between (tokenSpan LeftBracket) f (tokenSpan RightBracket)
-- |Parse an expression that is surrounded by braces
braces :: ASM a -> ASM (Span, a, Span)
braces f = between (tokenSpan LeftBrace) f (tokenSpan RightBrace)
-- |Apply function to `Maybe`
optional :: (a -> ASM b) -> Maybe a -> ASM (Maybe b)
optional _ Nothing = returnP Nothing
optional f (Just x) = Just <$> f x
-- |Get position of next token which is optional and one of two alternatives
maybeOneOf :: Token -> Token -> ASM (Maybe Span)
maybeOneOf t1 t2 ts@((p,t) : ts')
| t1 == t = (Just p, ts')
| t2 == t = (Just p, ts')
| otherwise = (Nothing, ts)
maybeOneOf _ _ [] = error "Token stream is empty."
-- |Return `Just` position of optional token or `Nothing`
maybeTokenSpan :: Token -> ASM (Maybe Span)
maybeTokenSpan t ts@((p,t') : ts')
| t == t' = (Just p , ts')
| otherwise = (Nothing, ts )
maybeTokenSpan _ [] = error "Token stream is empty."
-- |Parse an expression that might be surrounded
-- |by any kind of opening and closing symbols
maybeEnclosedBy :: [(Token, Token)] -> ASM a
-> ASM ((Maybe Span), a, (Maybe Span))
maybeEnclosedBy [] f = f >+= \ pf -> returnP (Nothing, pf, Nothing)
maybeEnclosedBy ((o, c):ocs) f =
readToken >+= \t -> if (t == o)
then between (maybeTokenSpan o) f (maybeTokenSpan c)
else maybeEnclosedBy ocs f
-- |Parse an expression that might be surrounded by parens
maybeParens :: ASM a -> ASM ((Maybe Span), a, (Maybe Span))
maybeParens f = maybeEnclosedBy [(LeftParen, RightParen)] f
{- |
Module : AST
Description : Abstract Syntax Tree
This module contains the description of the curry abstract syntax tree (AST)
and useful functions on the elements of the AST.
-}
module AST.AST where
import Char (isAlphaNum)
import List (intercalate)
import AST.Span (Pos)
-- ---------------------------------------------------------------------------
-- Types
-- ---------------------------------------------------------------------------
-- |Simple identifier
data Ident = Ident
{ idPosition :: Pos -- ^ Source code 'Position'
, idName :: String -- ^ Name of the identifier
, idUnique :: Int -- ^ Unique number of the identifier
}
deriving Show
-- |Qualified identifier
data QualIdent = QualIdent
{ qidModule :: Maybe ModuleIdent -- ^ optional module identifier
, qidIdent :: Ident -- ^ identifier itself
}
deriving Show
-- | Module identifier
data ModuleIdent = ModuleIdent
{ midPosition :: Pos -- ^ source code 'Position'
, midQualifiers :: [String] -- ^ hierarchical idenfiers
}
deriving Show
-- |Specified language extensions, either known or unknown.
data Extension
= KnownExtension Pos KnownExtension -- ^ a known extension
| UnknownExtension Pos String -- ^ an unknown extension
deriving Show
data KnownExtension
= AnonFreeVars -- ^ anonymous free variables
| FunctionalPatterns -- ^ functional patterns
| NegativeLiterals -- ^ negative literals
| NoImplicitPrelude -- ^ no implicit import of the prelude
deriving Show
-- |Different Curry tools which may accept compiler options.
data Tool = KICS2 | PAKCS | CYMAKE | UnknownTool String
deriving Show
-- ---------------------------------------------------------------------------
-- Functions
-- ---------------------------------------------------------------------------
-- |Hierarchical module name
moduleName :: ModuleIdent -> String
moduleName = intercalate "." . midQualifiers
-- |Hierarchical name of qualified Ident
qidName :: QualIdent -> String
qidName q = case q of
(QualIdent Nothing i) -> idName i
(QualIdent (Just m) i) -> intercalate "." [(moduleName m), (idName i)]
-- |Set position of ModuleIdent
setMIdPos :: Pos -> ModuleIdent -> ModuleIdent
setMIdPos p m = m { midPosition = p }
-- |Set position of Ident
setIdPos :: Pos -> Ident -> Ident
setIdPos p i = i { idPosition = p }
-- |Set position of QualIdent
setQIdPos :: Pos -> QualIdent -> QualIdent
setQIdPos p q = q { qidIdent = setIdPos p (qidIdent q) }
-- |Check whether an 'Ident' identifies an infix operation
isInfixOp :: Ident -> Bool
isInfixOp (Ident _ s _) = all (`elem` "~!@#$%^&*+-=<>:?./|\\") s
-- ---------------------------------------------------------------------------
-- Definition of AST: Module
-- ---------------------------------------------------------------------------
-- |Curry module
data Module = Module [ModulePragma] ModuleIdent (Maybe ExportSpec)
[ImportDecl] [Decl]
deriving Show
-- |Module pragma
data ModulePragma
= LanguagePragma Pos [Extension]
| OptionsPragma Pos (Maybe Tool) String
deriving Show
-- |Export specification
data ExportSpec = Exporting Pos [Export]
deriving Show
-- |Single exported entity
data Export
= Export QualIdent
| ExportTypeWith QualIdent [Ident]
| ExportTypeAll QualIdent
| ExportModule ModuleIdent
deriving Show
-- |Import declaration
data ImportDecl = ImportDecl Pos ModuleIdent Qualified
(Maybe ModuleIdent) (Maybe ImportSpec)
deriving Show
-- |Flag to signal qualified import
type Qualified = Bool
-- |Import specification
data ImportSpec
= Importing Pos [Import]
| Hiding Pos [Import]
deriving Show
-- |Single imported entity
data Import
= Import Ident
| ImportTypeWith Ident [Ident]
| ImportTypeAll Ident
deriving Show
-- ---------------------------------------------------------------------------
-- Module interfaces
-- ---------------------------------------------------------------------------
-- | Module interface
data Interface = Interface ModuleIdent [IImportDecl] [IDecl]
-- |Interface import declaration
data IImportDecl = IImportDecl Pos ModuleIdent
-- |Arity of a function
type Arity = Int
-- |Interface declaration
data IDecl
= IInfixDecl Pos Infix Precedence QualIdent
| HidingDataDecl Pos QualIdent [Ident]
| IDataDecl Pos QualIdent [Ident] [ConstrDecl] [Ident]
| INewtypeDecl Pos QualIdent [Ident] NewConstrDecl [Ident]
| ITypeDecl Pos QualIdent [Ident] TypeExpr
| IFunctionDecl Pos QualIdent Arity TypeExpr
-- ---------------------------------------------------------------------------
-- Declarations (local or top-level)
-- ---------------------------------------------------------------------------
-- |Declaration in a module
data Decl
= InfixDecl Pos Infix (Maybe Precedence) [Ident]
| DataDecl Pos Ident [Ident] [ConstrDecl]
| NewtypeDecl Pos Ident [Ident] NewConstrDecl
| TypeDecl Pos Ident [Ident] TypeExpr
| TypeSig Pos [Ident] TypeExpr
| FunctionDecl Pos Ident [Equation]
| ForeignDecl Pos CallConv (Maybe String) Ident TypeExpr
| ExternalDecl Pos [Ident]
| PatternDecl Pos Pattern Rhs
| FreeDecl Pos [Ident]
deriving Show
-- ---------------------------------------------------------------------------
-- Infix declaration
-- ---------------------------------------------------------------------------
-- |Operator precedence
type Precedence = Int
-- |Fixity of operators
data Infix
= InfixL -- ^ left-associative
| InfixR -- ^ right-associative
| Infix -- ^ no associativity
deriving Show
-- |Constructor declaration for algebraic data types
data ConstrDecl
= ConstrDecl Pos [Ident] Ident [TypeExpr]
| ConOpDecl Pos [Ident] TypeExpr Ident TypeExpr
| RecordDecl Pos [Ident] Ident [FieldDecl]
deriving Show
-- |Constructor declaration for renaming types (newtypes)
data NewConstrDecl
= NewConstrDecl Pos [Ident] Ident TypeExpr
| NewRecordDecl Pos [Ident] Ident (Ident, TypeExpr)
deriving Show
-- |Declaration for labelled fields
data FieldDecl = FieldDecl Pos [Ident] TypeExpr
deriving Show
-- |Calling convention for C code
data CallConv
= CallConvPrimitive
| CallConvCCall
deriving Show
-- |Type expressions
data TypeExpr
= ConstructorType QualIdent [TypeExpr]
| VariableType Ident
| TupleType [TypeExpr]
| ListType TypeExpr
| ArrowType TypeExpr TypeExpr
| ParenType TypeExpr
deriving Show
-- ---------------------------------------------------------------------------
-- Functions
-- ---------------------------------------------------------------------------
-- |Equation
data Equation = Equation Pos Lhs Rhs
deriving Show
-- |Left-hand-side of an `Equation` (function identifier and patterns)
data Lhs
= FunLhs Ident [Pattern]
| OpLhs Pattern Ident Pattern
| ApLhs Lhs [Pattern]
deriving Show
-- |Right-hand-side of an `Equation`
data Rhs
= SimpleRhs Pos Expression [Decl]
| GuardedRhs [CondExpr] [Decl]
deriving Show
-- |Conditional expression (expression conditioned by a guard)
data CondExpr = CondExpr Pos Expression Expression
deriving Show
-- |Literal
data Literal
= Char Char
| Int Ident Int
| Float Float
| String String
deriving Show
-- |Constructor term (used for patterns)
data Pattern
= LiteralPattern Literal
| NegativePattern Ident Literal
| VariablePattern Ident
| ConstructorPattern QualIdent [Pattern]
| InfixPattern Pattern QualIdent Pattern
| ParenPattern Pattern
| RecordPattern QualIdent [Field Pattern]
| TuplePattern [Pattern]
| ListPattern [Pattern]
| AsPattern Ident Pattern
| LazyPattern Pattern
| FunctionPattern QualIdent [Pattern]
| InfixFuncPattern Pattern QualIdent Pattern
deriving Show
-- |Expression
data Expression
= Literal Literal
| Variable QualIdent
| Constructor QualIdent
| Paren Expression
| Typed Expression TypeExpr
| Record QualIdent [Field Expression]
| RecordUpdate Expression [Field Expression]
| Tuple [Expression]
| List [Expression]
| ListCompr Expression [Statement]
| EnumFrom Expression
| EnumFromThen Expression Expression
| EnumFromTo Expression Expression
| EnumFromThenTo Expression Expression Expression
| UnaryMinus Ident Expression
| Apply Expression Expression
| InfixApply Expression InfixOp Expression
| LeftSection Expression InfixOp
| RightSection InfixOp Expression
| Lambda [Pattern] Expression
| Let [Decl] Expression
| Do [Statement] Expression
| IfThenElse Expression Expression Expression
| Case CaseType Expression [Alt]
deriving Show
-- |Infix operation
data InfixOp
= InfixOp QualIdent
| InfixConstr QualIdent
deriving Show
-- |Statement (used for do-sequence and list comprehensions)
data Statement
= StmtExpr Expression
| StmtDecl [Decl]
| StmtBind Pattern Expression
deriving Show
-- |Type of case expressions
data CaseType
= Rigid
| Flex
deriving Show
-- |Single case alternative
data Alt = Alt Pos Pattern Rhs
deriving Show
-- |Record field
data Field a = Field Pos QualIdent a
deriving Show
This diff is collapsed.
module AST.Ident where
import AST.Span (Span, virtualSpan)
-- |Simple identifier
data Ident = Ident
{ idSpan :: Span -- ^ Source code 'Span'
, idName :: String -- ^ Name of the identifier
, idUnique :: Int -- ^ Unique number of the identifier
}
deriving Show
-- |Qualified identifier
data QualIdent = QualIdent
{ qidModule :: Maybe ModuleIdent -- ^ optional module identifier
, qidIdent :: Ident -- ^ identifier itself
}
deriving Show
-- | Module identifier
data ModuleIdent = ModuleIdent
{ midSpan :: Span -- ^ source code 'Span'
, midQualifiers :: [String] -- ^ hierarchical idenfiers
}
deriving Show
-- |QualIdent that might have some kind of surrounding symbols,
-- |e.g. parens or backticks
-- 1. (Maybe Span) - opening symbol like LeftParen or Backtick
-- 2. (Maybe Span) - closing symbol like RightParen or Backtick
data SymIdent = SymIdent (Maybe Span) Ident (Maybe Span)
deriving Show
data SymQualIdent = SymQualIdent (Maybe Span) QualIdent (Maybe Span)
deriving Show
-- |Global scope for renaming
globalScope :: Int
globalScope = 0
-- |Construct an 'Ident' from a 'String'
mkIdent :: String -> Ident
mkIdent x = Ident virtualSpan x globalScope
mkSQIdent :: QualIdent -> SymQualIdent
mkSQIdent qi = SymQualIdent Nothing qi Nothing
-- | Convert an 'Ident' to a 'QualIdent'
qualify :: Ident -> QualIdent
qualify = QualIdent Nothing
-- | Convert an 'Ident' to a 'QualIdent' with a given 'ModuleIdent'
qualifyWith :: ModuleIdent -> Ident -> QualIdent
qualifyWith = QualIdent . Just
-- | Construct an 'Ident' for an n-ary tuple where n > 1
tupleId :: Int -> Ident
tupleId n
| n > 1 = mkIdent $ '(' : replicate (n - 1) ',' ++ ")"
| otherwise = error $ "ExtendAbstractCurry.tupleId: wrong arity " ++ show n
-- | 'Ident' for the value '[]'
nilId :: Ident
nilId = mkIdent "[]"
-- | 'Ident' for the function ':'
consId :: Ident
consId = mkIdent ":"
-- | 'Ident' for the type/value unit ('()')
unitId :: Ident
unitId = mkIdent "()"
-- | 'Ident' for the type '[]'
listId :: Ident
listId = mkIdent "[]"
-- | 'QualIdent' for the type/value unit ('()')
qUnitId :: QualIdent
qUnitId = qualify unitId
-- | 'QualIdent' for the type '[]'
qListId :: QualIdent
qListId = qualify listId
-- | 'QualIdent' for the type of n-ary tuples
qTupleId :: Int -> QualIdent
qTupleId = qualify . tupleId
-- | 'QualIdent' for the constructor '[]'
qNilId :: QualIdent
qNilId = qualify nilId
-- | 'QualIdent' for the constructor ':'
qConsId :: QualIdent
qConsId = qualify consId
qEnumFromId :: QualIdent
qEnumFromId = qualifyWith preludeMIdent (mkIdent "enumFrom")
qEnumFromThenId :: QualIdent
qEnumFromThenId = qualifyWith preludeMIdent (mkIdent "enumFromThen")
qEnumFromToId :: QualIdent
qEnumFromToId = qualifyWith preludeMIdent (mkIdent "enumFromTo")
qEnumFromThenToId :: QualIdent
qEnumFromThenToId = qualifyWith preludeMIdent (mkIdent "enumFromThenTo")
qNegateId :: QualIdent
qNegateId = qualifyWith preludeMIdent (mkIdent "negate")
qFlip :: QualIdent
qFlip = qualifyWith preludeMIdent (mkIdent "flip")
qIfThenElseId :: QualIdent
qIfThenElseId = qualifyWith preludeMIdent (mkIdent "if_then_else")
-- | 'ModuleIdent' for the Prelude
preludeMIdent :: ModuleIdent
preludeMIdent = ModuleIdent virtualSpan ["Prelude"]
{- |
Module : AST.PositionUtils
Description : Auxiliary functions for positions
This module provides some auxiliary functions concerning positions.
-}
module AST.PositionUtils where
import qualified AST.Ident as I
import AST.Span (Pos, Span, start, virtualPos)
import AST.SpanAST
import AST.Token
-- |Return the line of a position
line :: Pos -> Int
line pos = fst pos
-- |Return the column of a position
col :: Pos -> Int
col pos = snd pos
-- |Check whether the columns in a list of positions are all equal
allColEq :: [Pos] -> Bool
allColEq xs = case xs of
[] -> True
_ -> all (== col (head xs)) (map col (tail xs))
-- |Check whether the lines in a list of positions are all equal
allLinesEq :: [Pos] -> Bool
allLinesEq xs = case xs of
[] -> True
_ -> all (== line (head xs)) (map line (tail xs))
-- |move given position by n columns
moveColBy :: Pos -> Int -> Pos
moveColBy (l,c) n = (l, c + n)
--- |Change a position by a delta
--- @param l - line
--- @param c - column
--- @param ml - delta line
--- @param mc - delta column
--- @return - input position changed by delta line and delta column
relocate :: Pos -> (Int, Int) -> Pos
relocate (l, c) (ml, mc) = (l + ml, c + mc)
-- ----------------------------------------------------------------------------
-- Get positions of AST elements
-- ----------------------------------------------------------------------------
-- |Get start position of QualIdent
qidPos :: I.QualIdent -> Pos
qidPos (I.QualIdent _ i) = idPos i
-- |Get start position of Ident
idPos :: I.Ident -> Pos
idPos (I.Ident sp _ _) = start sp
-- |Get start position of Ident that might be surrounded by
-- |some kind of symbols, e.g. parens or backticks
sidPos :: I.SymIdent -> Pos
sidPos (I.SymIdent mpl i _) = case mpl of
Just pl -> start pl
Nothing -> idPos i
-- |Get start position of QualIdent that might be surrounded by
-- |some kind of symbols, e.g. parens or backticks
sqidPos :: I.SymQualIdent -> Pos
sqidPos (I.SymQualIdent mpl qi _) = case mpl of
Just pl -> start pl
Nothing -> qidPos qi
-- |Get start position of Export
exportPos :: Export -> Pos
exportPos e = case e of
Export qi -> sqidPos qi
ExportTypeWith qi _ _ _ _ -> qidPos qi
ExportTypeAll qi _ _ _ -> qidPos qi
ExportModule _ mi -> start (I.midSpan mi)
-- |Get start position of Decl
declPos :: Decl -> Pos
declPos d = case d of
PatternDecl pat _ -> patPos pat
_ -> virtualPos
-- |Get position of equality sign in Decl
declPosEq :: Decl -> Pos
declPosEq d = case d of
PatternDecl _ rhs -> rhsPos rhs
_ -> virtualPos
-- |Get position of Infix Keyword
infPos :: Infix -> Pos
infPos i = case i of
InfixL s -> start s
InfixR s -> start s
Infix s -> start s
-- |Get start position of ConstrDecl
constrDeclPos :: ConstrDecl -> Pos
constrDeclPos c = case c of
ConstrDecl _ i _ -> idPos i
ConOpDecl _ te _ _ -> typeExprPos te
RecordDecl _ i _ _ _ _ -> idPos i
-- |Get Type positions of ConstrDecl
constrDeclConstrTypePos :: ConstrDecl -> [Pos]
constrDeclConstrTypePos cd = case cd of
ConstrDecl _ _ cts -> if null cts
then [virtualPos]
else map typeExprPos cts
RecordDecl _ _ _ fds _ _ -> if null fds
then [virtualPos]
else map fieldDeclTEPos fds
_ -> [virtualPos]
-- |Get position of first Type in ConstrDecl
firstCDConstrTypePos :: ConstrDecl -> Pos
firstCDConstrTypePos cd = case cd of
ConstrDecl _ _ cts -> if null cts then virtualPos else typeExprPos $ head cts
_ -> virtualPos
-- |Get position of commas in FieldDecl
fieldDeclCPos :: FieldDecl -> [Pos]
fieldDeclCPos (FieldDecl _ sps _ _) = map start sps
-- | Get position of doublecolon in FieldDecl
fieldDeclDCPos :: FieldDecl -> Pos
fieldDeclDCPos (FieldDecl _ _ sp _) = start sp
-- |Get position of first constructor in FieldDecl
fieldDeclIDPos :: FieldDecl -> Pos
fieldDeclIDPos (FieldDecl ids _ _ _) = idPos $ head ids
-- |Get position of TypeExpression in FieldDecl
fieldDeclTEPos :: FieldDecl -> Pos
fieldDeclTEPos (FieldDecl _ _ _ te) = typeExprPos te
-- |Get start position of TypeExpr
typeExprPos :: TypeExpr -> Pos
typeExprPos te = case te of
ConstructorType msp qi _ _ -> case msp of
Just sp -> start sp
Nothing -> qidPos qi
VariableType i -> idPos i
TupleType sp _ _ _ -> start sp
ListType sp _ _ -> start sp
ArrowType te1 _ _ -> typeExprPos te1
ParenType sp _ _ -> start sp
-- |Get position of equality sign or rightarrow in Rhs
rhsPos :: Rhs -> Pos
rhsPos rhs = case rhs of
SimpleRhs sp _ _ _ -> start sp
GuardedRhs sp _ _ _ _ -> start sp
-- |Get start position of Lhs
lhsPos :: Lhs -> Pos
lhsPos lhs = case lhs of
FunLhs si _ -> sidPos si
OpLhs p _ _ -> patPos p
ApLhs l _ -> lhsPos l
-- |Get start position of CondExpr
condExprPos :: CondExpr -> Pos
condExprPos (CondExpr _ sp _) = start sp
-- |Get start position of Literal
litPos :: Literal -> Pos
litPos l = case l of
Char sp _ -> start sp
Int sp _ -> start sp
Float sp _ -> start sp
String sp _ -> start sp
-- |Get start position of Pattern
patPos :: Pattern -> Pos
patPos p = case p of
LiteralPattern l -> litPos l
NegativePattern i _ -> idPos i
VariablePattern i -> idPos i
ConstructorPattern qi _ -> qidPos qi
InfixPattern pat _ _ -> patPos pat
ParenPattern _ pat _ -> patPos pat
RecordPattern qi _ _ _ _ -> qidPos qi
TuplePattern spl _ _ _ -> start spl
ListPattern spl _ _ _ -> start spl
AsPattern i _ _ -> idPos i
LazyPattern sp _ -> start sp
FunctionPattern qi _ -> qidPos qi
InfixFuncPattern pat _ _ -> patPos pat
-- |Get start position of Expression
exprPos :: Expression -> Pos
exprPos e = case e of
Literal l -> litPos l
Variable v -> sqidPos v
Constructor qi -> sqidPos qi
Paren spl _ _ -> start spl
Typed e1 _ _ -> exprPos e1
Record qi _ _ _ _ -> qidPos qi
RecordUpdate e1 _ _ _ _ -> exprPos e1
Tuple spl _ _ _ -> start spl
List spl _ _ _ -> start spl
ListCompr spl _ _ _ _ _ -> start spl
EnumFrom spl _ _ _ -> start spl
EnumFromThen spl _ _ _ _ _ -> start spl
EnumFromTo spl _ _ _ _ -> start spl
EnumFromThenTo spl _ _ _ _ _ _ -> start spl
UnaryMinus i _ -> idPos i
Apply e1 _ -> exprPos e1
InfixApply e1 _ _ -> exprPos e1
LeftSection spl _ _ _ -> start spl
RightSection spl _ _ _ -> start spl
Lambda sp _ _ _ -> start sp
Let sp _ _ _ -> start sp
Do sp _ _ -> start sp
IfThenElse spi _ _ _ _ _ -> start spi
Case _ sp _ _ _ -> start sp
-- |Get start position of Statement
stmtPos :: Statement -> Pos
stmtPos s = case s of
StmtExpr e -> exprPos e
StmtDecl sp _ -> start sp
StmtBind _ pat _ -> patPos pat
-- |Get position of rightarrow in Alt
altPos :: Alt -> Pos
altPos (Alt _ rhs) = rhsPos rhs
-- span computation
-- TODO: Remove when curry-frontend was extended correspondingly
-- | Compute for a given token and its starting position a corresponding span
spanToken :: (Pos,Token) -> (Span,Token)
spanToken posTok = case posTok of
(p, CharTok c) -> ((p, moveColBy p (length (show c) - 1)), CharTok c)
(p, IntTok i) -> ((p, moveColBy p (length (show i) - 1)), IntTok i)
(p, FloatTok f) -> ((p, moveColBy p (length (show f) - 1)), FloatTok f)
(p, StringTok s) -> ((p, moveColBy p (length (show s) - 1)), StringTok s)
(p, Id i) -> ((p, moveColBy p (length i - 1)), Id i)
(p, QId qi) -> ((p, moveColBy p (length qi - 1)), QId qi)
(p, Sym s) -> ((p, moveColBy p (length s - 1)), Sym s)
(p, QSym qs) -> ((p, moveColBy p (length qs - 1)), QSym qs)
(p, KW_case) -> ((p, moveColBy p 3), KW_case)
(p, KW_data) -> ((p, moveColBy p 3), KW_data)
(p, KW_do) -> ((p, moveColBy p 1), KW_do)
(p, KW_else) -> ((p, moveColBy p 3), KW_else)
(p, KW_external) -> ((p, moveColBy p 7), KW_external)
(p, KW_fcase) -> ((p, moveColBy p 4), KW_fcase)
(p, KW_foreign) -> ((p, moveColBy p 6), KW_foreign)
(p, KW_free) -> ((p, moveColBy p 3), KW_free)
(p, KW_if) -> ((p, moveColBy p 1), KW_if)
(p, KW_import) -> ((p, moveColBy p 5), KW_import)
(p, KW_in) -> ((p, moveColBy p 1), KW_in)
(p, KW_infix) -> ((p, moveColBy p 4), KW_infix)
(p, KW_infixl) -> ((p, moveColBy p 5), KW_infixl)
(p, KW_infixr) -> ((p, moveColBy p 5), KW_infixr)
(p, KW_let) -> ((p, moveColBy p 2), KW_let)
(p, KW_module) -> ((p, moveColBy p 5), KW_module)
(p, KW_newtype) -> ((p, moveColBy p 6), KW_newtype)
(p, KW_of) -> ((p, moveColBy p 1), KW_of)
(p, KW_then) -> ((p, moveColBy p 3), KW_then)
(p, KW_type) -> ((p, moveColBy p 3), KW_type)
(p, KW_where) -> ((p, moveColBy p 4), KW_where)
(p, DotDot) -> ((p, moveColBy p 1), DotDot)
(p, DoubleColon) -> ((p, moveColBy p 1), DoubleColon)
(p, LeftArrow) -> ((p, moveColBy p 1), LeftArrow)
(p, RightArrow) -> ((p, moveColBy p 1), RightArrow)
(p, Bind) -> ((p, moveColBy p 1), Bind)
(p, Select) -> ((p, moveColBy p 1), Select)
(p, Id_as) -> ((p, moveColBy p 1), Id_as)
(p, Id_ccall) -> ((p, moveColBy p 4), Id_ccall)
(p, Id_forall) -> ((p, moveColBy p 5), Id_forall)
(p, Id_hiding) -> ((p, moveColBy p 5), Id_hiding)
(p, Id_interface) -> ((p, moveColBy p 8), Id_interface)
(p, Id_primitive) -> ((p, moveColBy p 8), Id_primitive)
(p, Id_qualified) -> ((p, moveColBy p 8), Id_qualified)
(p, SymMinusDot) -> ((p, moveColBy p 1), SymMinusDot)
(p, PragmaLanguage ) -> ((p, moveColBy p 11), PragmaLanguage)
(p, PragmaOptions ms s) -> ((p, moveColBy p (length s + 11)), PragmaOptions ms s)
(p, PragmaHiding ) -> ((p, moveColBy p 9), PragmaHiding)
(p, PragmaEnd ) -> ((p, moveColBy p 2), PragmaEnd)
(p, tok) -> ((p, p), tok)
{- |
Module : AST.RemoveSpans
Description : Remove span information from SpanAST
This module provides functions for converting an extended SpanAST back into
a simple AST. All previously added span informations are removed by tree
traversal.
This conversion allows us to make use of the built-in pretty printer for
Abstract Syntax Trees.
-}
module AST.RemoveSpans (rsModule) where
import Char (toUpper)
import AST.AST as AST
import AST.Ident as I
import AST.Span
import qualified AST.SpanAST as SpanAST
import AST.PositionUtils
-- |Remove span information from Module
rsModule :: SpanAST.Module -> AST.Module
rsModule (SpanAST.Module mps _ mi _ mes ids ds)
= AST.Module (map rsModulePragma mps) (rsMIdent mi) (rsExportSpec mes)
(map rsImportDecl ids) (map rsDecl ds)
-- |Remove span information from ModulePragma
rsModulePragma :: SpanAST.ModulePragma -> AST.ModulePragma
rsModulePragma mp = case mp of
SpanAST.LanguagePragma sp es _ _ -> AST.LanguagePragma (start sp) (map rsExtension es)
SpanAST.OptionsPragma sp mt s _ -> AST.OptionsPragma (start sp) (stringToTool mt) s
-- |Convert String to Tool
stringToTool :: (Maybe String) -> (Maybe AST.Tool)
stringToTool ms = case ms of
Nothing -> Nothing
Just s | ((map toUpper s) == "KICS2") -> Just KICS2
| ((map toUpper s) == "PAKCS") -> Just PAKCS
| ((map toUpper s) == "CYMAKE") -> Just CYMAKE
| otherwise -> Just (UnknownTool s)
-- |Remove span information from Extension
rsExtension :: SpanAST.Extension -> AST.Extension
rsExtension e = case e of
SpanAST.KnownExtension sp ke -> AST.KnownExtension (start sp) ke
SpanAST.UnknownExtension sp s -> AST.UnknownExtension (start sp) s
-- |Remove span information from ExportSpec
rsExportSpec :: Maybe SpanAST.ExportSpec -> Maybe AST.ExportSpec
rsExportSpec es = case es of
Just (SpanAST.Exporting sp es1 _ _) -> Just $ AST.Exporting (start sp) (map rsExport es1)
Nothing -> Nothing
-- |Remove span information from Export
rsExport :: SpanAST.Export -> AST.Export
rsExport e = case e of
SpanAST.Export sqi -> AST.Export (rsSymQualIdent sqi)
SpanAST.ExportTypeWith qi _ is _ _ -> AST.ExportTypeWith (rsQualIdent qi) (map rsIdent is)
SpanAST.ExportTypeAll qi _ _ _ -> AST.ExportTypeAll (rsQualIdent qi)
SpanAST.ExportModule _ mi -> AST.ExportModule (rsMIdent mi)
-- |Remove span information from ImportDecl
rsImportDecl :: SpanAST.ImportDecl -> AST.ImportDecl
rsImportDecl (SpanAST.ImportDecl sp _ mi _ q mmi misp) = let mi' = rsMIdent mi
in case mmi of
Just m -> AST.ImportDecl (start sp) mi' q (Just (rsMIdent m)) (rsMaybeImportSpec misp)
Nothing -> AST.ImportDecl (start sp) mi' q Nothing (rsMaybeImportSpec misp)
-- |Remove span information from ImportSpec
rsMaybeImportSpec :: Maybe SpanAST.ImportSpec -> Maybe AST.ImportSpec
rsMaybeImportSpec misp = case misp of
Just (SpanAST.Importing sp is _ _ ) -> Just $ AST.Importing (start sp) (map rsImport is)
Just (SpanAST.Hiding sp _ is _ _) -> Just $ AST.Hiding (start sp) (map rsImport is)
Nothing -> Nothing
-- |Remove span information from Import
rsImport :: SpanAST.Import -> AST.Import
rsImport imp = case imp of
SpanAST.Import i -> AST.Import (rsSymIdent i)
SpanAST.ImportTypeWith i _ is _ _ -> AST.ImportTypeWith (rsIdent i) (map rsIdent is)
SpanAST.ImportTypeAll i _ _ _ -> AST.ImportTypeAll (rsIdent i)
-- |Remove span information from Decl
rsDecl :: SpanAST.Decl -> AST.Decl
rsDecl d = case d of
SpanAST.InfixDecl i mp ipos _
-> AST.InfixDecl (infPos i) (rsInfix i)
(rsPrecedence mp) (map rsSymIdent ipos)
SpanAST.DataDecl sp i is _ cds _
-> AST.DataDecl (start sp) (rsIdent i) (map rsIdent is) (map rsConstrDecl cds)
SpanAST.NewtypeDecl sp i is _ ncd
-> AST.NewtypeDecl (start sp) (rsIdent i) (map rsIdent is) (rsNewConstrDecl ncd)
SpanAST.TypeDecl sp i is _ te
-> AST.TypeDecl (start sp) (rsIdent i) (map rsIdent is) (rsTypeExpr te)
SpanAST.TypeSig sis _ _ te
-> AST.TypeSig (sidPos $ head sis) (map rsSymIdent sis) (rsTypeExpr te)
SpanAST.FunctionDecl i eqs
-> AST.FunctionDecl (idPos i) (rsIdent i) (map rsEquation eqs)
SpanAST.ForeignDecl sp cc mps i _ te
-> AST.ForeignDecl (start sp) (rsCallConv cc) (convert mps) (rsSymIdent i) (rsTypeExpr te)
where convert mps' = case mps' of
Just (_, s) -> Just s
Nothing -> Nothing
SpanAST.ExternalDecl is _ _
-> AST.ExternalDecl (sidPos $ head is) (map rsSymIdent is)
SpanAST.PatternDecl p rhs
-> AST.PatternDecl (patPos p) (rsPattern p) (rsRhs rhs)
SpanAST.FreeDecl is _ _
-> AST.FreeDecl (idPos $ head is) (map rsIdent is)
-- |Remove span information from Infix
rsInfix :: SpanAST.Infix -> AST.Infix
rsInfix i = case i of
SpanAST.InfixL _ -> AST.InfixL
SpanAST.InfixR _ -> AST.InfixR
SpanAST.Infix _ -> AST.Infix
-- |Remove span information from Precedence
rsPrecedence :: Maybe SpanAST.Precedence -> Maybe AST.Precedence
rsPrecedence p = case p of
Just (_, i) -> Just i
Nothing -> Nothing
-- |Remove span information from ConstrDecl
rsConstrDecl :: SpanAST.ConstrDecl -> AST.ConstrDecl
rsConstrDecl cd = case cd of
SpanAST.ConstrDecl is i tes
-> AST.ConstrDecl (idPos i) (map rsIdent is) (rsIdent i) (map rsTypeExpr tes)
SpanAST.ConOpDecl is te1 i te2
-> AST.ConOpDecl (idPos i) (map rsIdent is) (rsTypeExpr te1) (rsIdent i) (rsTypeExpr te2)
SpanAST.RecordDecl is i _ fds _ _
-> AST.RecordDecl (idPos i) (map rsIdent is) (rsIdent i) (map rsFieldDecl fds)
-- |Remove span information from NewConstrDecl
rsNewConstrDecl :: SpanAST.NewConstrDecl -> AST.NewConstrDecl
rsNewConstrDecl ncd = case ncd of
SpanAST.NewConstrDecl is i te
-> AST.NewConstrDecl (idPos i) (map rsIdent is) (rsIdent i) (rsTypeExpr te)
SpanAST.NewRecordDecl is i1 _ (i2, _, te) _
-> AST.NewRecordDecl (idPos i1) (map rsIdent is) (rsIdent i1) (rsIdent i2, rsTypeExpr te)
-- |Remove span information from FieldDecl
rsFieldDecl :: SpanAST.FieldDecl -> AST.FieldDecl
rsFieldDecl (SpanAST.FieldDecl is _ _ te)
= AST.FieldDecl (idPos $ head is) (map rsIdent is) (rsTypeExpr te)
-- |Remove span information from CallConv
rsCallConv :: SpanAST.CallConv -> AST.CallConv
rsCallConv cc = case cc of
SpanAST.CallConvPrimitive _ -> AST.CallConvPrimitive
SpanAST.CallConvCCall _ -> AST.CallConvCCall
-- |Remove span information from TypeExpr
rsTypeExpr :: SpanAST.TypeExpr -> AST.TypeExpr
rsTypeExpr te = case te of
SpanAST.ConstructorType _ qi tes _
-> AST.ConstructorType (rsQualIdent qi) (map rsTypeExpr tes)
SpanAST.VariableType i
-> AST.VariableType (rsIdent i)
SpanAST.TupleType _ tes _ _
-> AST.TupleType (map rsTypeExpr tes)
SpanAST.ListType _ te1 _
-> AST.ListType (rsTypeExpr te1)
SpanAST.ArrowType te1 _ te2
-> AST.ArrowType (rsTypeExpr te1) (rsTypeExpr te2)
SpanAST.ParenType _ te1 _
-> AST.ParenType (rsTypeExpr te1)
-- |Remove span information from Equation
rsEquation :: SpanAST.Equation -> AST.Equation
rsEquation (SpanAST.Equation lhs rhs)
= AST.Equation (lhsPos lhs) (rsLhs lhs) (rsRhs rhs)
-- |Remove span information from Lhs
rsLhs :: SpanAST.Lhs -> AST.Lhs
rsLhs lhs = case lhs of
SpanAST.FunLhs si ps -> AST.FunLhs (rsSymIdent si) (map rsPattern ps)
SpanAST.OpLhs p1 si p2 -> AST.OpLhs (rsPattern p1)
(rsSymIdent si)
(rsPattern p2)
SpanAST.ApLhs lhs1 ps -> AST.ApLhs (rsLhs lhs1) (map rsPattern ps)
-- |Remove span information from Rhs
rsRhs :: SpanAST.Rhs -> AST.Rhs
rsRhs rhs = case rhs of
SpanAST.SimpleRhs sp e _ ds -> AST.SimpleRhs (start sp) (rsExpression e)
(map rsDecl ds)
SpanAST.GuardedRhs _ ces _ _ ds -> AST.GuardedRhs (map rsCondExpr ces)
(map rsDecl ds)
-- |Remove span information from CondExpr
rsCondExpr :: SpanAST.CondExpr -> AST.CondExpr
rsCondExpr (SpanAST.CondExpr e1 _ e2)
= AST.CondExpr (exprPos e1) (rsExpression e1) (rsExpression e2)
-- |Remove span information from Literal
rsLiteral :: SpanAST.Literal -> AST.Literal
rsLiteral l = case l of
SpanAST.Char _ c -> AST.Char c
-- The 'Ident'-argument used for supporting ad-hoc polymorphism
-- on integer numbers gets lost here
SpanAST.Int _ i -> AST.Int (AST.Ident virtualPos "_" 0) i
SpanAST.Float _ d -> AST.Float d
SpanAST.String _ s -> AST.String s
-- |Remove span information from Pattern
rsPattern :: SpanAST.Pattern -> AST.Pattern
rsPattern p = case p of
SpanAST.LiteralPattern l -> AST.LiteralPattern (rsLiteral l)
SpanAST.NegativePattern i l -> AST.NegativePattern (rsIdent i) (rsLiteral l)
SpanAST.VariablePattern i -> AST.VariablePattern (rsIdent i)
SpanAST.ConstructorPattern qi ps
-> AST.ConstructorPattern (rsQualIdent qi) (map rsPattern ps)
SpanAST.InfixPattern p1 qi p2
-> AST.InfixPattern (rsPattern p1) (rsQualIdent qi) (rsPattern p2)
SpanAST.ParenPattern _ p1 _ -> AST.ParenPattern (rsPattern p1)
SpanAST.RecordPattern qi _ fps _ _
-> AST.RecordPattern (rsQualIdent qi) (map rsFieldP fps)
SpanAST.TuplePattern _ ps _ _ -> AST.TuplePattern (map rsPattern ps)
SpanAST.ListPattern _ ps _ _ -> AST.ListPattern (map rsPattern ps)
SpanAST.AsPattern i _ p1 -> AST.AsPattern (rsIdent i) (rsPattern p1)
SpanAST.LazyPattern _ p1 -> AST.LazyPattern (rsPattern p1)
SpanAST.FunctionPattern qi ps
-> AST.FunctionPattern (rsQualIdent qi) (map rsPattern ps)
SpanAST.InfixFuncPattern p1 qi p2
-> AST.InfixFuncPattern (rsPattern p1) (rsQualIdent qi) (rsPattern p2)
-- |Remove span information from Ident
rsIdent :: I.Ident -> AST.Ident
rsIdent (I.Ident sp n u) = AST.Ident (start sp) n u
-- |Remove span information from QualIdent
rsQualIdent :: I.QualIdent -> AST.QualIdent
rsQualIdent (I.QualIdent mmi i) = let i' = rsIdent i in case mmi of
Just mi -> AST.QualIdent (Just (rsMIdent mi)) i'
Nothing -> AST.QualIdent Nothing i'
-- |Remove span information from SymIdent and turn it back into Ident
rsSymIdent :: I.SymIdent -> AST.Ident
rsSymIdent (I.SymIdent _ i _) = rsIdent i
-- |Remove span information from SymQualIdent and turn it back into QualIdent
rsSymQualIdent :: I.SymQualIdent -> AST.QualIdent
rsSymQualIdent (I.SymQualIdent _ qi _) = rsQualIdent qi
-- |Remove span information from ModuleIdent
rsMIdent :: I.ModuleIdent -> AST.ModuleIdent
rsMIdent (I.ModuleIdent sp qs) = AST.ModuleIdent (start sp) qs
-- |Remove span information from Expression
rsExpression :: SpanAST.Expression -> AST.Expression
rsExpression e = case e of
SpanAST.Literal l -> AST.Literal (rsLiteral l)
SpanAST.Variable qsi -> AST.Variable (rsSymQualIdent qsi)
SpanAST.Constructor qsi -> AST.Constructor (rsSymQualIdent qsi)
SpanAST.Paren _ e1 _ -> AST.Paren (rsExpression e1)
SpanAST.Typed e1 _ te -> AST.Typed (rsExpression e1)
(rsTypeExpr te)
SpanAST.Record qi _ fes _ _ -> AST.Record (rsQualIdent qi) (map rsFieldE fes)
SpanAST.RecordUpdate e1 _ fes _ _
-> AST.RecordUpdate (rsExpression e1) (map rsFieldE fes)
SpanAST.Tuple _ es _ _ -> AST.Tuple (map rsExpression es)
SpanAST.List _ es _ _ -> AST.List (map rsExpression es)
SpanAST.ListCompr _ e1 _ sts _ _
-> AST.ListCompr (rsExpression e1) (map rsStatement sts)
SpanAST.EnumFrom _ e1 _ _ -> AST.EnumFrom (rsExpression e1)
SpanAST.EnumFromThen _ e1 _ e2 _ _
-> AST.EnumFromThen (rsExpression e1) (rsExpression e2)
SpanAST.EnumFromTo _ e1 _ e2 _
-> AST.EnumFromTo (rsExpression e1) (rsExpression e2)
SpanAST.EnumFromThenTo _ e1 _ e2 _ e3 _
-> AST.EnumFromThenTo (rsExpression e1) (rsExpression e2) (rsExpression e3)
SpanAST.UnaryMinus i e1
-> AST.UnaryMinus (rsIdent i) (rsExpression e1)
SpanAST.Apply e1 e2 -> AST.Apply (rsExpression e1) (rsExpression e2)
SpanAST.InfixApply e1 iop e2
-> AST.InfixApply (rsExpression e1) (rsInfixOp iop) (rsExpression e2)
SpanAST.LeftSection _ e1 iop _
-> AST.LeftSection (rsExpression e1) (rsInfixOp iop)
SpanAST.RightSection _ iop e1 _
-> AST.RightSection (rsInfixOp iop) (rsExpression e1)
SpanAST.Lambda _ ps _ e1 -> AST.Lambda (map rsPattern ps) (rsExpression e1)
SpanAST.Let _ ds _ e1 -> AST.Let (map rsDecl ds) (rsExpression e1)
SpanAST.Do _ sts e1 -> AST.Do (map rsStatement sts) (rsExpression e1)
SpanAST.IfThenElse _ e1 _ e2 _ e3
-> AST.IfThenElse (rsExpression e1) (rsExpression e2) (rsExpression e3)
SpanAST.Case ct _ e1 _ alts -> AST.Case (rsCaseType ct)
(rsExpression e1)
(map rsAlt alts)
-- |Remove span information from InfixOp
rsInfixOp :: SpanAST.InfixOp -> AST.InfixOp
rsInfixOp iop = case iop of
SpanAST.InfixOp qis -> AST.InfixOp (rsSymQualIdent qis)
SpanAST.InfixConstr qis -> AST.InfixConstr (rsSymQualIdent qis)
-- |Remove span information from Statement
rsStatement :: SpanAST.Statement -> AST.Statement
rsStatement s = case s of
SpanAST.StmtExpr e -> AST.StmtExpr (rsExpression e)
SpanAST.StmtDecl _ ds -> AST.StmtDecl (map rsDecl ds)
SpanAST.StmtBind _ p e -> AST.StmtBind (rsPattern p) (rsExpression e)
-- |Remove span information from CaseType
rsCaseType :: SpanAST.CaseType -> AST.CaseType
rsCaseType ct = case ct of
SpanAST.Rigid -> AST.Rigid
SpanAST.Flex -> AST.Flex
-- |Remove span information from Alt
rsAlt :: SpanAST.Alt -> AST.Alt
rsAlt (SpanAST.Alt p rhs) = AST.Alt (patPos p) (rsPattern p) (rsRhs rhs)
-- |Remove span information from Field Pattern
rsFieldP :: SpanAST.Field SpanAST.Pattern -> AST.Field AST.Pattern
rsFieldP (SpanAST.Field qi _ p) = AST.Field (qidPos qi) (rsQualIdent qi) (rsPattern p)
-- |Remove span information from Field Expression
rsFieldE :: SpanAST.Field SpanAST.Expression -> AST.Field AST.Expression
rsFieldE (SpanAST.Field qi _ e) = AST.Field (qidPos qi) (rsQualIdent qi) (rsExpression e)
{- |
Module : AST.SortSplit
Description : Functions for sorting and splitting declarations
Declarations in the AST are in a different order than they are in the
source code. There are two cases where this is important:
1) Equations of a single function may be scattered all over the source code
2) There are data declarations anywhere in the source code
Because we have to stay synchronous with the Tokenstream we have to rewrite
the AST by splitting FunctionDecls and sort all Decls by their position.
-}
module AST.SortSplit (sortSplitModule, lePos) where
import Sort (quickSortBy)
import AST.AST
import AST.Span (Pos)
import AST.PositionUtils (line)
-- |Reorganize the AST by splitting and sorting the declarations
sortSplitModule :: Module -> Module
sortSplitModule (Module mps mi mesp ids ds) =
(Module mps mi mesp ids (quickSortBy lePos (concatMap splitFunctionDecl ds)))
-- |Traverse AST
sortSplitEq :: Equation -> Equation
sortSplitEq (Equation p lhs rhs) = (Equation p lhs (sortSplitRhs rhs))
-- |Sort and split local declarations
sortSplitRhs :: Rhs -> Rhs
sortSplitRhs rhs = case rhs of
SimpleRhs p e ds -> SimpleRhs p e (qsDs ds)
GuardedRhs ces ds -> GuardedRhs ces (qsDs ds)
where qsDs ds = quickSortBy lePos $ concatMap splitFunctionDecl ds
-- |Split FunctionDecls with more than one Equation
-- |into many FunctionDecls with only one Equation
-- |and call same function for local declarations recursively (sortSplitEq)
splitFunctionDecl :: Decl -> [Decl]
splitFunctionDecl d = case d of
(FunctionDecl p i eqs) -> case eqs of
[] -> []
(eq : eqss) -> [(FunctionDecl (posEquation eq) i [sortSplitEq eq])]
++ (splitFunctionDecl (FunctionDecl p i eqss))
_ -> [d]
-- |Get the position of an equation
-- |This belongs here and not into the PositionUtils-Module,
-- |because it refers to the simple AST, not the extended PosAST.
posEquation :: Equation -> Pos
posEquation (Equation p _ _) = p
-- ----------------------------------------------------------------------------
-- Utils for quicksort-algorithm on Declarations
-- ----------------------------------------------------------------------------
-- |`Less or equal` on Decls
lePos :: Decl -> Decl -> Bool
lePos d1 d2 = (line $ declPos d1) <= (line $ declPos d2)
-- |Get the position of a declaration.
-- |This belongs here and not into the PositionUtils-Module,
-- |because it refers to the simple AST, not the extended PosAST.
declPos :: Decl -> Pos
declPos (InfixDecl p _ _ _ ) = p
declPos (DataDecl p _ _ _ ) = p
declPos (NewtypeDecl p _ _ _ ) = p
declPos (TypeDecl p _ _ _ ) = p
declPos (TypeSig p _ _ ) = p
declPos (FunctionDecl p _ _ ) = p
declPos (ForeignDecl p _ _ _ _) = p
declPos (ExternalDecl p _ ) = p
declPos (PatternDecl p _ _ ) = p
declPos (FreeDecl p _ ) = p
module AST.Span where
-- |Position
type Pos = (Int, Int)
--- Shows a position.
showPos :: Pos -> String
showPos (l,c) = show l ++ "." ++ show c
-- |Span (start and end position)
type Span = (Pos, Pos)
-- |start position of a span
start :: Span -> Pos
start = fst
-- |end position of a span
end :: Span -> Pos
end = snd
startPos :: Pos
startPos = (1,1)
-- |Virtual position for AST-elements that have no "physical" positions like
-- e.g. the import of Prelude
virtualPos :: Pos
virtualPos = (0, 0)
-- |Virtual span for AST-elements that have no "physical" spans like
-- e.g. the import of Prelude
virtualSpan :: Span
virtualSpan = (virtualPos, virtualPos)
-- |Is a position a virtual position?
isVirtualPos :: Pos -> Bool
isVirtualPos p = p == virtualPos
{- |
Module : AST.SpanAST
Description : Extension of Abstract Syntax Tree
This module contains the description of the AST which has been
extended by span information (i.e. start and end positions) (SpanAST).
The inline comments document for which tokens span information was added.
-}
module AST.SpanAST where
import AST.AST (KnownExtension (..), Tool (..))
import AST.Ident (ModuleIdent, Ident, QualIdent, SymIdent, SymQualIdent)
import AST.Span (Span)
-- ---------------------------------------------------------------------------
-- Modules
-- ---------------------------------------------------------------------------
-- |Curry module
-- 1. (Maybe Span) - KW_module
-- 2. (Maybe Span) - KW_where
data Module = Module [ModulePragma] (Maybe Span) ModuleIdent (Maybe Span)
(Maybe ExportSpec) [ImportDecl] [Decl]
deriving Show
-- |Module pragma
data ModulePragma
-- 1. Span - PragmaLanguage
-- 2. [Span] - Commas
-- 3. Span - PragmaEnd
= LanguagePragma Span [Extension] [Span] Span
-- 1. Span - PragmaOptions
-- 2. Span - PragmaEnd
| OptionsPragma Span (Maybe String) String Span
deriving Show
-- |Specified language extensions, either known or unknown.
data Extension
= KnownExtension Span KnownExtension -- 1. Span - Id "KnownExtension"
| UnknownExtension Span String -- 1. Span - Id "Name"
deriving Show
-- |Export specification
-- 1. Span - LeftParen
-- 2. [Span] - Commas
-- 3. Span - RightParen
data ExportSpec = Exporting Span [Export] [Span] Span
deriving Show
-- |Single exported entity
data Export
= Export SymQualIdent
-- 1. Span - LeftParen
-- 2. [Span] - Commas
-- 3. Span - RightParen
| ExportTypeWith QualIdent Span [Ident] [Span] Span
-- 1. Span - LeftParen
-- 2. Span - DotDot
-- 3. Span - RightParen
| ExportTypeAll QualIdent Span Span Span
-- 1. Span - KW_module
| ExportModule Span ModuleIdent
deriving Show
-- |Import declaration
-- 1. Span - KW_import
-- 2. (Maybe Span) - Id_qualified
-- 3. (Maybe Span) - Id_as
data ImportDecl = ImportDecl Span (Maybe Span) ModuleIdent (Maybe Span) Qualified
(Maybe ModuleIdent) (Maybe ImportSpec)
deriving Show
-- |Flag to signal qualified import
type Qualified = Bool
-- |Import specification
data ImportSpec
-- 1. Span - LeftParen
-- 2. [Span] - Commas
-- 3. Span - RightParen
= Importing Span [Import] [Span] Span
-- 1. Span - Id_hiding
-- 2. Span - LeftParen
-- 3. [Span] - Commas
-- 4. Span - RightParen
| Hiding Span Span [Import] [Span] Span
deriving Show
-- |Single imported entity