Skip to content
GitLab
Menu
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
curry
curry-frontend
Commits
50d60cf5
Commit
50d60cf5
authored
Jun 21, 2011
by
Björn Peemöller
Browse files
Merge branch 'master' of /home/bjp/public_html/repos/curry-frontend
parents
62f8f62f
d0526478
Changes
16
Hide whitespace changes
Inline
Side-by-side
curry-frontend.cabal
View file @
50d60cf5
...
...
@@ -53,17 +53,6 @@ Executable cymake
, Check.SyntaxCheck
, Check.TypeCheck
, Check.WarnCheck
, Curry.IL
, Curry.IL.Pretty
, Curry.IL.Type
, Curry.IL.XML
, Curry.Syntax
, Curry.Syntax.Lexer
, Curry.Syntax.Parser
, Curry.Syntax.Pretty
, Curry.Syntax.ShowModule
, Curry.Syntax.Type
, Curry.Syntax.Utils
, Env.CurryEnv
, Env.NestEnv
, Env.OldScopeEnv
...
...
@@ -73,6 +62,10 @@ Executable cymake
, Gen.GenFlatCurry
, Html.CurryHtml
, Html.SyntaxColoring
, IL
, IL.Pretty
, IL.Type
, IL.XML
, CurryBuilder
, CompilerOpts
, CurryDeps
...
...
src/Curry/Syntax.hs
deleted
100644 → 0
View file @
62f8f62f
{- |A simple interface for reading and manipulating Curry source code.
(c) 2009, Holger Siegel
2011, Björn Peemöller
-}
module
Curry.Syntax
(
module
Curry
.
Syntax
.
Type
,
module
Curry
.
Syntax
.
Utils
,
lexFile
,
parseHeader
,
parseModule
,
ppModule
,
ppIDecl
,
showModule
)
where
import
Curry.Base.Position
(
Position
,
first
)
import
Curry.Base.MessageMonad
(
MsgMonad
)
import
Curry.Files.Unlit
(
unlit
)
import
qualified
Curry.Syntax.Lexer
as
Lexer
(
Token
,
lexFile
)
import
qualified
Curry.Syntax.Parser
as
Parser
(
parseHeader
,
parseSource
)
import
Curry.Syntax.Pretty
(
ppModule
,
ppIDecl
)
import
Curry.Syntax.ShowModule
(
showModule
)
import
Curry.Syntax.Type
import
Curry.Syntax.Utils
{- |Return the result of a lexical analysis of the source program 'src'.
The result is a list of tuples consisting of a 'Position' and a 'Token'
-}
lexFile
::
FilePath
->
String
->
MsgMonad
[(
Position
,
Lexer
.
Token
)]
lexFile
fn
src
=
unlit
fn
src
>>=
\
s
->
Lexer
.
lexFile
(
first
fn
)
s
False
[]
-- | Parse a curry header
parseHeader
::
FilePath
->
String
->
MsgMonad
Module
parseHeader
fn
src
=
unlit
fn
src
>>=
Parser
.
parseHeader
fn
-- | Parse a curry module
parseModule
::
Bool
->
FilePath
->
String
->
MsgMonad
Module
parseModule
likeFlat
fn
src
=
unlit
fn
src
>>=
Parser
.
parseSource
likeFlat
fn
src/Curry/Syntax/Lexer.lhs
deleted
100644 → 0
View file @
62f8f62f
% $Id: CurryLexer.lhs,v 1.40 2004/03/04 22:39:12 wlux Exp $
%
% Copyright (c) 1999-2004, Wolfgang Lux
% See LICENSE for the full license.
%
% Modified by Martin Engelke (men@informatik.uni-kiel.de)
% Modified by Bjoern Peemoeller (bjp@informatik.uni-kiel.de)
%
\nwfilename{CurryLexer.lhs}
\section{A Lexer for Curry}
In this section a lexer for Curry is implemented.
\begin{verbatim}
>
module
Curry.Syntax.Lexer
>
(
-- * Data types
>
Token
(
..
),
Category
(
..
),
Attributes
(
..
)
>
-- * lexing functions
>
,
lexFile
,
lexer
>
)
where
>
import
Prelude
hiding
(
fail
)
>
import
Data.Char
(
chr
,
ord
,
isAlpha
,
isAlphaNum
,
isSpace
,
isUpper
>
,
isDigit
,
isOctDigit
,
isHexDigit
)
>
import
Data.List
(
intercalate
)
>
import
qualified
Data.Map
as
Map
(
Map
,
union
,
lookup
,
fromList
)
>
import
Curry.Base.LexComb
>
import
Curry.Base.LLParseComb
(
Symbol
(
..
))
>
import
Curry.Base.Position
\end{verbatim}
\paragraph{Tokens} Note that the equality and ordering instances of
\texttt{Token} disregard the attributes.
\begin{verbatim}
>
-- |Data type for curry lexer tokens
>
data
Token
=
Token
Category
Attributes
>
instance
Eq
Token
where
>
Token
c1
_
==
Token
c2
_
=
c1
==
c2
>
instance
Ord
Token
where
>
Token
c1
_
`
compare
`
Token
c2
_
=
c1
`
compare
`
c2
>
instance
Symbol
Token
where
>
isEOF
(
Token
c
_
)
=
c
==
EOF
>
-- |Category of curry tokens
>
data
Category
>
-- literals
>
=
CharTok
>
|
IntTok
>
|
FloatTok
>
|
IntegerTok
>
|
StringTok
>
-- identifiers
>
|
Id
-- identifier
>
|
QId
-- qualified identifier
>
|
Sym
-- symbol
>
|
QSym
-- qualified symbol
>
-- punctuation symbols
>
|
LeftParen
-- (
>
|
RightParen
-- )
>
|
Semicolon
-- ;
>
|
LeftBrace
-- {
>
|
RightBrace
-- }
>
|
LeftBracket
-- [
>
|
RightBracket
-- ]
>
|
Comma
-- ,
>
|
Underscore
-- _
>
|
Backquote
-- `
>
-- layout (inserted by bbr)
>
|
LeftBraceSemicolon
-- {; (turn off layout)
>
|
VSemicolon
-- virtual ;
>
|
VRightBrace
-- virtual }
>
-- reserved keywords
>
|
KW_case
>
-- | KW_class -- not supported yet
>
|
KW_choice
-- deprecated
>
|
KW_data
>
-- | KW_deriving -- not supported yet
>
|
KW_do
>
|
KW_else
>
|
KW_eval
-- deprecated
>
|
KW_external
>
|
KW_free
>
|
KW_if
>
|
KW_import
>
|
KW_in
>
|
KW_infix
>
|
KW_infixl
>
|
KW_infixr
>
-- | KW_instance -- not supported yet
>
|
KW_let
>
|
KW_module
>
|
KW_newtype
>
|
KW_of
>
|
KW_rigid
-- deprecated
>
|
KW_then
>
|
KW_type
>
|
KW_where
>
-- reserved operators
>
|
At
-- @
>
|
Colon
-- :
>
|
DotDot
-- ..
>
|
DoubleColon
-- ::
>
|
Equals
-- =
>
|
Backslash
-- \
>
|
Bar
-- |
>
|
LeftArrow
-- <-
>
|
RightArrow
-- ->
>
|
Tilde
-- ~
>
|
Binds
-- :=
>
-- | Context -- => -- not supported yet
>
-- special identifiers
>
|
Id_as
>
|
Id_ccall
>
|
Id_forall
>
|
Id_hiding
>
|
Id_interface
>
|
Id_primitive
>
|
Id_qualified
>
-- special operators
>
|
SymDot
-- .
>
|
SymMinus
-- -
>
|
SymMinusDot
-- -.
>
-- compiler pragma (bjp)
>
|
Pragma
>
-- comments (only for full lexer) inserted by men & bbr
>
|
LineComment
>
|
NestedComment
>
-- end-of-file token
>
|
EOF
>
deriving
(
Eq
,
Ord
)
\end{verbatim}
There are different kinds of attributes associated with the tokens.
Most attributes simply save the string corresponding to the token.
However, for qualified identifiers, we also record the list of module
qualifiers. The values corresponding to a literal token are properly
converted already. To simplify the creation and extraction of
attribute values, we make use of records.
\begin{verbatim}
>
-- |Attributes associated to a token
>
data
Attributes
>
=
NoAttributes
>
|
CharAttributes
{
cval
::
Char
,
original
::
String
}
>
|
IntAttributes
{
ival
::
Int
,
original
::
String
}
>
|
FloatAttributes
{
fval
::
Double
,
original
::
String
}
>
|
IntegerAttributes
{
intval
::
Integer
,
original
::
String
}
>
|
StringAttributes
{
sval
::
String
,
original
::
String
}
>
|
IdentAttributes
{
modul
::
[
String
],
sval
::
String
}
>
instance
Show
Attributes
where
>
showsPrec
_
NoAttributes
=
showChar
'_'
>
showsPrec
_
(
CharAttributes
cv
_
)
=
shows
cv
>
showsPrec
_
(
IntAttributes
iv
_
)
=
shows
iv
>
showsPrec
_
(
FloatAttributes
fv
_
)
=
shows
fv
>
showsPrec
_
(
IntegerAttributes
iv
_
)
=
shows
iv
>
showsPrec
_
(
StringAttributes
sv
_
)
=
shows
sv
>
showsPrec
_
(
IdentAttributes
mIdent
ident
)
=
showsEscaped
>
$
intercalate
"."
>
$
mIdent
++
[
ident
]
\end{verbatim}
The following functions can be used to construct tokens with
specific attributes.
\begin{verbatim}
>
-- |Construct a simple 'Token' without 'Attributes'
>
tok
::
Category
->
Token
>
tok
t
=
Token
t
NoAttributes
>
-- |Construct a 'Token' for identifiers
>
idTok
::
Category
->
[
String
]
->
String
->
Token
>
idTok
t
mIdent
ident
=
Token
t
>
IdentAttributes
{
modul
=
mIdent
,
sval
=
ident
}
>
-- |Construct a 'Token' for a single 'Char'
>
charTok
::
Char
->
String
->
Token
>
charTok
c
o
=
Token
CharTok
CharAttributes
{
cval
=
c
,
original
=
o
}
>
-- |Construct a 'Token' for an int value
>
intTok
::
Int
->
String
->
Token
>
intTok
base
digits
=
>
Token
IntTok
IntAttributes
{
ival
=
convertIntegral
base
digits
>
,
original
=
digits
}
>
-- |Construct a 'Token' for a float value
>
floatTok
::
String
->
String
->
Int
->
String
->
Token
>
floatTok
mant
frac
expo
rest
=
>
Token
FloatTok
FloatAttributes
{
fval
=
convertFloating
mant
frac
expo
>
,
original
=
mant
++
"."
++
frac
++
rest
}
>
-- |Construct a 'Token' for an integer value
>
integerTok
::
Integer
->
String
->
Token
>
integerTok
base
digits
=
Token
IntegerTok
>
IntegerAttributes
{
intval
=
(
convertIntegral
base
digits
)
::
Integer
>
,
original
=
digits
}
>
-- |Construct a 'Token' for a string value
>
stringTok
::
String
->
String
->
Token
>
stringTok
cs
o
=
Token
StringTok
>
StringAttributes
{
sval
=
cs
,
original
=
o
}
>
-- |Construct a 'Token' for a line comment
>
lineCommentTok
::
String
->
Token
>
lineCommentTok
s
=
Token
LineComment
>
StringAttributes
{
sval
=
s
,
original
=
s
}
>
-- |Construct a 'Token' for a nested comment
>
nestedCommentTok
::
String
->
Token
>
nestedCommentTok
s
=
Token
NestedComment
>
StringAttributes
{
sval
=
s
,
original
=
s
}
>
-- |Construct a 'Token' for a compiler pragma
>
pragmaTok
::
String
->
Token
>
pragmaTok
s
=
Token
Pragma
StringAttributes
{
sval
=
s
,
original
=
s
}
\end{verbatim}
The \texttt{Show} instance of \texttt{Token} is designed to display
all tokens in their source representation.
\begin{verbatim}
-- Helper for showing
>
showsEscaped
::
String
->
ShowS
>
showsEscaped
s
=
showChar
'`'
.
showString
s
.
showChar
'
\'
'
>
showsIdentifier
::
Attributes
->
ShowS
>
showsIdentifier
a
=
showString
"identifier "
.
shows
a
>
showsSpecialIdentifier
::
String
->
ShowS
>
showsSpecialIdentifier
s
=
showString
"identifier "
.
showsEscaped
s
>
showsOperator
::
Attributes
->
ShowS
>
showsOperator
a
=
showString
"operator "
.
shows
a
>
showsSpecialOperator
::
String
->
ShowS
>
showsSpecialOperator
s
=
showString
"operator "
.
showsEscaped
s
>
instance
Show
Token
where
>
showsPrec
_
(
Token
Id
a
)
=
showsIdentifier
a
>
showsPrec
_
(
Token
QId
a
)
=
showString
"qualified "
>
.
showsIdentifier
a
>
showsPrec
_
(
Token
Sym
a
)
=
showsOperator
a
>
showsPrec
_
(
Token
QSym
a
)
=
showString
"qualified "
>
.
showsOperator
a
>
showsPrec
_
(
Token
IntTok
a
)
=
showString
"integer "
.
shows
a
>
showsPrec
_
(
Token
FloatTok
a
)
=
showString
"float "
.
shows
a
>
showsPrec
_
(
Token
CharTok
a
)
=
showString
"character "
.
shows
a
>
showsPrec
_
(
Token
IntegerTok
a
)
=
showString
"integer "
.
shows
a
>
showsPrec
_
(
Token
StringTok
a
)
=
showString
"string "
.
shows
a
>
showsPrec
_
(
Token
LeftParen
_
)
=
showsEscaped
"("
>
showsPrec
_
(
Token
RightParen
_
)
=
showsEscaped
")"
>
showsPrec
_
(
Token
Semicolon
_
)
=
showsEscaped
";"
>
showsPrec
_
(
Token
LeftBrace
_
)
=
showsEscaped
"{"
>
showsPrec
_
(
Token
RightBrace
_
)
=
showsEscaped
"}"
>
showsPrec
_
(
Token
LeftBracket
_
)
=
showsEscaped
"["
>
showsPrec
_
(
Token
RightBracket
_
)
=
showsEscaped
"]"
>
showsPrec
_
(
Token
Comma
_
)
=
showsEscaped
","
>
showsPrec
_
(
Token
Underscore
_
)
=
showsEscaped
"_"
>
showsPrec
_
(
Token
Backquote
_
)
=
showsEscaped
"`"
>
showsPrec
_
(
Token
LeftBraceSemicolon
_
)
=
showsEscaped
"{;"
>
.
showString
" (turn off layout)"
>
showsPrec
_
(
Token
VSemicolon
_
)
=
showsEscaped
";"
>
.
showString
" (inserted due to layout)"
>
showsPrec
_
(
Token
VRightBrace
_
)
=
showsEscaped
"}"
>
.
showString
" (inserted due to layout)"
>
showsPrec
_
(
Token
At
_
)
=
showsEscaped
"@"
>
showsPrec
_
(
Token
Colon
_
)
=
showsEscaped
":"
>
showsPrec
_
(
Token
DotDot
_
)
=
showsEscaped
".."
>
showsPrec
_
(
Token
DoubleColon
_
)
=
showsEscaped
"::"
>
showsPrec
_
(
Token
Equals
_
)
=
showsEscaped
"="
>
showsPrec
_
(
Token
Backslash
_
)
=
showsEscaped
"
\\
"
>
showsPrec
_
(
Token
Bar
_
)
=
showsEscaped
"|"
>
showsPrec
_
(
Token
LeftArrow
_
)
=
showsEscaped
"<-"
>
showsPrec
_
(
Token
RightArrow
_
)
=
showsEscaped
"->"
>
showsPrec
_
(
Token
Tilde
_
)
=
showsEscaped
"~"
>
showsPrec
_
(
Token
Binds
_
)
=
showsEscaped
":="
>
showsPrec
_
(
Token
SymDot
_
)
=
showsSpecialOperator
"."
>
showsPrec
_
(
Token
SymMinus
_
)
=
showsSpecialOperator
"-"
>
showsPrec
_
(
Token
SymMinusDot
_
)
=
showsSpecialOperator
"-."
>
showsPrec
_
(
Token
KW_case
_
)
=
showsEscaped
"case"
>
showsPrec
_
(
Token
KW_choice
_
)
=
showsEscaped
"choice"
>
showsPrec
_
(
Token
KW_data
_
)
=
showsEscaped
"data"
>
showsPrec
_
(
Token
KW_do
_
)
=
showsEscaped
"do"
>
showsPrec
_
(
Token
KW_else
_
)
=
showsEscaped
"else"
>
showsPrec
_
(
Token
KW_eval
_
)
=
showsEscaped
"eval"
>
showsPrec
_
(
Token
KW_external
_
)
=
showsEscaped
"external"
>
showsPrec
_
(
Token
KW_free
_
)
=
showsEscaped
"free"
>
showsPrec
_
(
Token
KW_if
_
)
=
showsEscaped
"if"
>
showsPrec
_
(
Token
KW_import
_
)
=
showsEscaped
"import"
>
showsPrec
_
(
Token
KW_in
_
)
=
showsEscaped
"in"
>
showsPrec
_
(
Token
KW_infix
_
)
=
showsEscaped
"infix"
>
showsPrec
_
(
Token
KW_infixl
_
)
=
showsEscaped
"infixl"
>
showsPrec
_
(
Token
KW_infixr
_
)
=
showsEscaped
"infixr"
>
showsPrec
_
(
Token
KW_let
_
)
=
showsEscaped
"let"
>
showsPrec
_
(
Token
KW_module
_
)
=
showsEscaped
"module"
>
showsPrec
_
(
Token
KW_newtype
_
)
=
showsEscaped
"newtype"
>
showsPrec
_
(
Token
KW_of
_
)
=
showsEscaped
"of"
>
showsPrec
_
(
Token
KW_rigid
_
)
=
showsEscaped
"rigid"
>
showsPrec
_
(
Token
KW_then
_
)
=
showsEscaped
"then"
>
showsPrec
_
(
Token
KW_type
_
)
=
showsEscaped
"type"
>
showsPrec
_
(
Token
KW_where
_
)
=
showsEscaped
"where"
>
showsPrec
_
(
Token
Id_as
_
)
=
showsSpecialIdentifier
"as"
>
showsPrec
_
(
Token
Id_ccall
_
)
=
showsSpecialIdentifier
"ccall"
>
showsPrec
_
(
Token
Id_forall
_
)
=
showsSpecialIdentifier
"forall"
>
showsPrec
_
(
Token
Id_hiding
_
)
=
showsSpecialIdentifier
"hiding"
>
showsPrec
_
(
Token
Id_interface
_
)
=
showsSpecialIdentifier
"interface"
>
showsPrec
_
(
Token
Id_primitive
_
)
=
showsSpecialIdentifier
"primitive"
>
showsPrec
_
(
Token
Id_qualified
_
)
=
showsSpecialIdentifier
"qualified"
>
showsPrec
_
(
Token
Pragma
a
)
=
shows
a
>
showsPrec
_
(
Token
LineComment
a
)
=
shows
a
>
showsPrec
_
(
Token
NestedComment
a
)
=
shows
a
>
showsPrec
_
(
Token
EOF
_
)
=
showString
"<end-of-file>"
\end{verbatim}
Maps for reserved operators and identifiers
\begin{verbatim}
>
-- |Map of reserved operators
>
reservedOps
::
Map
.
Map
String
Category
>
reservedOps
=
Map
.
fromList
>
[
(
"@"
,
At
)
>
,
(
":"
,
Colon
)
>
,
(
"::"
,
DoubleColon
)
>
,
(
".."
,
DotDot
)
>
,
(
"="
,
Equals
)
>
,
(
"
\\
"
,
Backslash
)
>
,
(
"|"
,
Bar
)
>
,
(
"<-"
,
LeftArrow
)
>
,
(
"->"
,
RightArrow
)
>
,
(
"~"
,
Tilde
)
>
,
(
":="
,
Binds
)
>
]
>
-- |Map of reserved and special operators
>
reservedSpecialOps
::
Map
.
Map
String
Category
>
reservedSpecialOps
=
Map
.
union
reservedOps
$
Map
.
fromList
>
[
(
"."
,
SymDot
)
>
,
(
"-"
,
SymMinus
)
>
,
(
"-."
,
SymMinusDot
)
>
]
>
-- |Map of keywords
>
keywords
::
Map
.
Map
String
Category
>
keywords
=
Map
.
fromList
>
[
(
"case"
,
KW_case
)
>
,
(
"choice"
,
KW_choice
)
>
,
(
"data"
,
KW_data
)
>
,
(
"do"
,
KW_do
)
>
,
(
"else"
,
KW_else
)
>
,
(
"eval"
,
KW_eval
)
>
,
(
"external"
,
KW_external
)
>
,
(
"free"
,
KW_free
)
>
,
(
"if"
,
KW_if
)
>
,
(
"import"
,
KW_import
)
>
,
(
"in"
,
KW_in
)
>
,
(
"infix"
,
KW_infix
)
>
,
(
"infixl"
,
KW_infixl
)
>
,
(
"infixr"
,
KW_infixr
)
>
,
(
"let"
,
KW_let
)
>
,
(
"module"
,
KW_module
)
>
,
(
"newtype"
,
KW_newtype
)
>
,
(
"of"
,
KW_of
)
>
,
(
"rigid"
,
KW_rigid
)
>
,
(
"then"
,
KW_then
)
>
,
(
"type"
,
KW_type
)
>
,
(
"where"
,
KW_where
)
>
]
>
-- |Map of reserved and special identifiers
>
keywordsSpecialIds
::
Map
.
Map
String
Category
>
keywordsSpecialIds
=
Map
.
union
keywords
$
Map
.
fromList
>
[
(
"as"
,
Id_as
)
>
,
(
"ccall"
,
Id_ccall
)
>
,
(
"forall"
,
Id_forall
)
>
,
(
"hiding"
,
Id_hiding
)
>
,
(
"interface"
,
Id_interface
)
>
,
(
"primitive"
,
Id_primitive
)
>
,
(
"qualified"
,
Id_qualified
)
>
]
\end{verbatim}
Character classes
\begin{verbatim}
>
isIdent
::
Char
->
Bool
>
isIdent
c
=
isAlphaNum
c
||
c
`
elem
`
"'_"
>
isSymbol
::
Char
->
Bool
>
isSymbol
c
=
c
`
elem
`
"~!@#$%^&*+-=<>:?./|
\\
"
\end{verbatim}
Lexing functions
\begin{verbatim}
>
type
SuccessP
a
=
Position
->
Token
->
P
a
>
type
FailP
a
=
Position
->
String
->
P
a
>
lexFile
::
P
[(
Position
,
Token
)]
>
lexFile
=
fullLexer
tokens
failP
>
where
tokens
p
t
@
(
Token
c
_
)
>
|
c
==
EOF
=
returnP
[(
p
,
t
)]
>
|
otherwise
=
lexFile
`
thenP
`
returnP
.
((
p
,
t
)
:
)
>
lexer
::
SuccessP
a
->
FailP
a
->
P
a
>
lexer
success
fail
=
skipBlanks
>
where
-- skipBlanks moves past whitespace and comments
>
skipBlanks
p
[]
bol
=
success
p
(
tok
EOF
)
p
[]
bol
>
skipBlanks
p
(
'
\t
'
:
s
)
bol
=
skipBlanks
(
tab
p
)
s
bol
>
skipBlanks
p
(
'
\n
'
:
s
)
_bol
=
skipBlanks
(
nl
p
)
s
True
>
skipBlanks
p
(
'-'
:
'-'
:
s
)
_bol
=
skipBlanks
(
nl
p
)
(
tail'
(
dropWhile
(
/=
'
\n
'
)
s
))
True
>
skipBlanks
p
(
'{'
:
'-'
:
'#'
:
s
)
bol
=
lexPragma
id
p
success
fail
(
incr
p
3
)
s
bol
>
skipBlanks
p
(
'{'
:
'-'
:
s
)
bol
=
>
skipNestedComment
p
skipBlanks
fail
(
incr
p
2
)
s
bol
>
skipBlanks
p
(
c
:
s
)
bol
>
|
isSpace
c
=
skipBlanks
(
next
p
)
s
bol
>
|
otherwise
=
>
(
if
bol
then
lexBOL
else
lexToken
)
success
fail
p
(
c
:
s
)
bol
>
tail'
[]
=
[]
>
tail'
(
_
:
tl
)
=
tl
>
fullLexer
::
SuccessP
a
->
FailP
a
->
P
a
>
fullLexer
success
fail
=
skipBlanks
>
where
-- skipBlanks moves past whitespace
>
skipBlanks
p
[]
bol
=
success
p
(
tok
EOF
)
p
[]
bol
>
skipBlanks
p
(
'
\t
'
:
s
)
bol
=
skipBlanks
(
tab
p
)
s
bol
>
skipBlanks
p
(
'
\n
'
:
s
)
_bol
=
skipBlanks
(
nl
p
)
s
True
>
skipBlanks
p
s
@
(
'-'
:
'-'
:
_
)
bol
=
lexLineComment
success
p
s
bol
>
skipBlanks
p
s
@
(
'{'
:
'-'
:
'#'
:
_
)
bol
=
lexPragma
id
p
success
fail
p
s
bol
>
skipBlanks
p
s
@
(
'{'
:
'-'
:
_
)
bol
=
lexNestedComment
0
id
p
success
fail
p
s
bol
>
skipBlanks
p
(
c
:
s
)
bol
>
|
isSpace
c
=
skipBlanks
(
next
p
)
s
bol
>
|
otherwise
=
>
(
if
bol
then
lexBOL
else
lexToken
)
success
fail
p
(
c
:
s
)
bol
>
lexLineComment
::
SuccessP
a
->
P
a
>
lexLineComment
success
p
s
=
case
break
(
==
'
\n
'
)
s
of
>
(
comment
,
rest
)
->
success
p
(
lineCommentTok
comment
)
(
incr
p
(
length
comment
))
rest
>
lexPragma
::
(
String
->
String
)
->
Position
->
SuccessP
a
->
FailP
a
->
P
a
>
lexPragma
prag
p0
success
_
p
(
'#'
:
'-'
:
'}'
:
s
)
>
=
success
p0
(
pragmaTok
(
prag
"#-}"
))
(
incr
p
3
)
s
>
lexPragma
prag
p0
success
fail
p
(
c
@
'
\t
'
:
s
)
>
=
lexPragma
(
prag
.
(
c
:
))
p0
success
fail
(
tab
p
)
s
>
lexPragma
prag
p0
success
fail
p
(
c
@
'
\n
'
:
s
)
>
=
lexPragma
(
prag
.
(
c
:
))
p0
success
fail
(
nl
p
)
s
>
lexPragma
prag
p0
success
fail
p
(
c
:
s
)
>
=
lexPragma
(
prag
.
(
c
:
))
p0
success
fail
(
next
p
)
s
>
lexPragma
_
p0
_
fail
p
""
>
=
fail
p0
"Unterminated pragma"
p
[]
>
lexNestedComment
::
Int
->
(
String
->
String
)
->
>
Position
->
SuccessP
a
->
FailP
a
->
P
a
>
lexNestedComment
1
comment
p0
success
_
p
(
'-'
:
'}'
:
s
)
=
>
success
p0
(
nestedCommentTok
(
comment
"-}"
)
)
(
incr
p
2
)
s
>
lexNestedComment
n
comment
p0
success
fail
p
(
'{'
:
'-'
:
s
)
=
>
lexNestedComment
(
n
+
1
)
(
comment
.
(
"{-"
++
))
p0
success
fail
(
incr
p
2
)
s
>
lexNestedComment
n
comment
p0
success
fail
p
(
'-'
:
'}'
:
s
)
=
>
lexNestedComment
(
n
-
1
)
(
comment
.
(
"-}"
++
))
p0
success
fail
(
incr
p
2
)
s
>
lexNestedComment
n
comment
p0
success
fail
p
(
c
@
'
\t
'
:
s
)
=
>
lexNestedComment
n
(
comment
.
(
c
:
))
p0
success
fail
(
tab
p
)
s
>
lexNestedComment
n
comment
p0
success
fail
p
(
c
@
'
\n
'
:
s
)
=
>
lexNestedComment
n
(
comment
.
(
c
:
))
p0
success
fail
(
nl
p
)
s
>
lexNestedComment
n
comment
p0
success
fail
p
(
c
:
s
)
=
>
lexNestedComment
n
(
comment
.
(
c
:
))
p0
success
fail
(
next
p
)
s
>
lexNestedComment
_
_
p0
_
fail
p
""
=
>
fail
p0
"Unterminated nested comment"
p
[]
>
skipNestedComment
::
Position
->
P
a
->
FailP
a
->
P
a
>
skipNestedComment
_
success
_
p
(
'-'
:
'}'
:
s
)
=
success
(
incr
p
2
)
s
>
skipNestedComment
p0
success
fail
p
(
'{'
:
'-'
:
s
)
=
>
skipNestedComment
p
(
skipNestedComment
p0
success
fail
)
fail
(
incr
p
2
)
s
>
skipNestedComment
p0
success
fail
p
(
'
\t
'
:
s
)
=
>
skipNestedComment
p0
success
fail
(
tab
p
)
s
>
skipNestedComment
p0
success
fail
p
(
'
\n
'
:
s
)
=
>
skipNestedComment
p0
success
fail
(
nl
p
)
s
>
skipNestedComment
p0
success
fail
p
(
_
:
s
)
=
>
skipNestedComment
p0
success
fail
(
next
p
)
s
>
skipNestedComment
p0
_
fail
p
[]
=
>
fail
p0
"Unterminated nested comment at end-of-file"
p
[]
>
lexBOL
::
SuccessP
a
->
FailP
a
->
P
a
>
lexBOL
success
fail
p
s
_
[]
=
lexToken
success
fail
p
s
False
[]
>
lexBOL
success
fail
p
s
_
ctxt
@
(
n
:
rest
)
>
|
col
<
n
=
success
p
(
tok
VRightBrace
)
p
s
True
rest
>
|
col
==
n
=
success
p
(
tok
VSemicolon
)
p
s
False
ctxt
>
|
otherwise
=
lexToken
success
fail
p
s
False
ctxt
>
where
col
=
column
p
>
lexToken
::
SuccessP
a
->
FailP
a
->
P
a
>
lexToken
success
_
p
[]
=
success
p
(
tok
EOF
)
p
[]
>
lexToken
success
fail
p
(
c
:
s
)
>
|
c
==
'('
=
token
LeftParen
>
|
c
==
')'
=
token
RightParen
>
|
c
==
','
=
token
Comma
>
|
c
==
';'
=
token
Semicolon
>
|
c
==
'['
=
token
LeftBracket
>
|
c
==
']'
=
token
RightBracket
>
|
c
==
'_'
=
token
Underscore
>
|
c
==
'`'
=
token
Backquote
>
|
c
==
'{'
=
lexLeftBrace
(
success
p
)
(
next
p
)
s
>
|
c
==
'}'
=
\
bol
->
token
RightBrace
bol
.
drop
1
>
|
c
==
'
\'
'
=
lexChar
p
success
fail
(
next
p
)
s
>
|
c
==
'
\"
'
=
lexString
p
success
fail
(
next
p
)
s
>
|
isAlpha
c
=
lexIdent
(
success
p
)
p
(
c
:
s
)
>
|
isSymbol
c
=
lexSymbol
(
success
p
)
p
(
c
:
s
)
>
|
isDigit
c
=
lexNumber
(
success
p
)
p
(
c
:
s
)
>