Commit f2fb0d3f authored by Michael Hanus 's avatar Michael Hanus
Browse files

CASC added to tools

parent bbcbe513
......@@ -10,6 +10,7 @@ browser/BrowserGUI
browser/GenInt
browser/ShowFlatCurry
browser/SourceProgGUI
casc/CASC
CASS/cass
CASS/cass_worker
createmakefile/CreateMakefile
......
{- |
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 :: 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
}
-- |Qualified identifier
data QualIdent = QualIdent
{ qidModule :: Maybe ModuleIdent -- ^ optional module identifier
, qidIdent :: Ident -- ^ identifier itself
}
-- | Module identifier
data ModuleIdent = ModuleIdent
{ midPosition :: Pos -- ^ source code 'Position'
, midQualifiers :: [String] -- ^ hierarchical idenfiers
}
-- |Specified language extensions, either known or unknown.
data Extension
= KnownExtension Pos KnownExtension -- ^ a known extension
| UnknownExtension Pos String -- ^ an unknown extension
data KnownExtension
= AnonFreeVars -- ^ anonymous free variables
| FunctionalPatterns -- ^ functional patterns
| NegativeLiterals -- ^ negative literals
| NoImplicitPrelude -- ^ no implicit import of the prelude
-- |Different Curry tools which may accept compiler options.
data Tool = KICS2 | PAKCS | CYMAKE | UnknownTool String
-- ---------------------------------------------------------------------------
-- 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]
-- |Module pragma
data ModulePragma
= LanguagePragma Pos [Extension]
| OptionsPragma Pos (Maybe Tool) String
-- |Export specification
data ExportSpec = Exporting Pos [Export]
-- |Single exported entity
data Export
= Export QualIdent
| ExportTypeWith QualIdent [Ident]
| ExportTypeAll QualIdent
| ExportModule ModuleIdent
-- |Import declaration
data ImportDecl = ImportDecl Pos ModuleIdent Qualified
(Maybe ModuleIdent) (Maybe ImportSpec)
-- |Flag to signal qualified import
type Qualified = Bool
-- |Import specification
data ImportSpec
= Importing Pos [Import]
| Hiding Pos [Import]
-- |Single imported entity
data Import
= Import Ident
| ImportTypeWith Ident [Ident]
| ImportTypeAll Ident
-- ---------------------------------------------------------------------------
-- 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]
-- ---------------------------------------------------------------------------
-- Infix declaration
-- ---------------------------------------------------------------------------
-- |Operator precedence
type Precedence = Int
-- |Fixity of operators
data Infix
= InfixL -- ^ left-associative
| InfixR -- ^ right-associative
| Infix -- ^ no associativity
-- |Constructor declaration for algebraic data types
data ConstrDecl
= ConstrDecl Pos [Ident] Ident [TypeExpr]
| ConOpDecl Pos [Ident] TypeExpr Ident TypeExpr
| RecordDecl Pos [Ident] Ident [FieldDecl]
-- |Constructor declaration for renaming types (newtypes)
data NewConstrDecl
= NewConstrDecl Pos [Ident] Ident TypeExpr
| NewRecordDecl Pos [Ident] Ident (Ident, TypeExpr)
-- |Declaration for labelled fields
data FieldDecl = FieldDecl Pos [Ident] TypeExpr
-- |Calling convention for C code
data CallConv
= CallConvPrimitive
| CallConvCCall
-- |Type expressions
data TypeExpr
= ConstructorType QualIdent [TypeExpr]
| VariableType Ident
| TupleType [TypeExpr]
| ListType TypeExpr
| ArrowType TypeExpr TypeExpr
| ParenType TypeExpr
-- ---------------------------------------------------------------------------
-- Functions
-- ---------------------------------------------------------------------------
-- |Equation
data Equation = Equation Pos Lhs Rhs
-- |Left-hand-side of an `Equation` (function identifier and patterns)
data Lhs
= FunLhs Ident [Pattern]
| OpLhs Pattern Ident Pattern
| ApLhs Lhs [Pattern]
-- |Right-hand-side of an `Equation`
data Rhs
= SimpleRhs Pos Expression [Decl]
| GuardedRhs [CondExpr] [Decl]
-- |Conditional expression (expression conditioned by a guard)
data CondExpr = CondExpr Pos Expression Expression
-- |Literal
data Literal
= Char Char
| Int Ident Int
| Float Float
| String String
-- |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
-- |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]
-- |Infix operation
data InfixOp
= InfixOp QualIdent
| InfixConstr QualIdent
-- |Statement (used for do-sequence and list comprehensions)
data Statement
= StmtExpr Expression
| StmtDecl [Decl]
| StmtBind Pattern Expression
-- |Type of case expressions
data CaseType
= Rigid
| Flex
-- |Single case alternative
data Alt = Alt Pos Pattern Rhs
-- |Record field
data Field a = Field Pos QualIdent a
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
}
-- |Qualified identifier
data QualIdent = QualIdent
{ qidModule :: Maybe ModuleIdent -- ^ optional module identifier
, qidIdent :: Ident -- ^ identifier itself
}
-- | Module identifier
data ModuleIdent = ModuleIdent
{ midSpan :: Span -- ^ source code 'Span'
, midQualifiers :: [String] -- ^ hierarchical idenfiers
}
-- |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)
data SymQualIdent = SymQualIdent (Maybe Span) QualIdent (Maybe Span)
-- |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