language-ats-0.3.0.2: src/Language/ATS/Lexer.x
{
{-# OPTIONS_GHC -fno-warn-unused-matches -fno-warn-incomplete-uni-patterns -fno-warn-unused-imports #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Module exporting the lexer itself as well as several data types for
-- working with tokens.
module Language.ATS.Lexer ( AlexPosn (..)
, Token (..)
, Keyword (..)
, Addendum (..)
, lexATS
, token_posn
, to_string
, get_addendum
, get_staload
) where
import Control.Composition
import Data.Data (Typeable, Data)
import Control.DeepSeq (NFData)
import GHC.Generics (Generic)
import Text.PrettyPrint.ANSI.Leijen hiding (line, bool, column, (<$>))
}
%wrapper "monad"
-- Digits
$digit = 0-9
$octal = 0-7
-- Characters
$special = [\+\-\&\|\[\]\{\}\(\)\_\=\!\%\^\$\@\;\~\,\.\\\#\<\>\:\?]
$alpha = [a-zA-Z]
$terminal = $printable # $white
$esc_char = \27
@escape_ch = \\ ([nt\'\\] | $octal+)
@escape_str = \\ ([nt\"\\] | $octal+)
@char = ($terminal # [\\\']) | " " | @escape_ch | $esc_char
@char_lit = \' @char \'
$br = [\<\>]
-- Integer
@integer = $digit+
@time_lit = $digit+ u
-- Floats
@decimals = $digit+
@float = @decimals \. @decimals ("f" | "")
-- Strings
@string = \" ($printable # [\"\\] | @escape_str | $esc_char | \\ \n | \n)* \"
-- Identifiers
@identifier = ($alpha | _) ($alpha | $digit | _ | ! | ')*
-- Multi-line comments
@not_close_paren = (\*+ [^\)] | [^\*] \))
@paren_comment = \(\* ([^\)\*] | @not_close_paren | \n)* \*\)
@not_close_slash = (\*+ [^\/] | [^\*] \/)
@slash_comment = \/\* ([^\/\*] | @not_close_slash | \n)* \*\/
@block_comment = @paren_comment | @slash_comment
@if_block = "#if" ([^\#] | "#then" | "#print" | \n)+ "#endif" .*
-- Basically anything that can go inside implicit arguments, i.e. anything
-- necessary to construct a type.
@ref_call = ($alpha | $digit | "(" | ")" | _ | (","))+ ">"
@not_close_c = \% [^\}]
@c_block = \%\{ ("#" | "$" | "^" | "") ([^\%] | @not_close_c | \n)* \%\}
@inner_signature = ("!wrt" | "!exn" | "!refwrt" | "!exnwrt" | "!exnrefwrt" | "!exnref" | "0" | "1" | "!all" | "!laz" | "lin" | "fun" | "clo" | "cloptr" | "cloref" | "!ntm" | "!ref" | "prf" | "fe" | @block_comment)
@inner_signature_mult = (@inner_signature (("," | "") @inner_signature)*) | ""
@lambda = "=>" | "=>>" | "=<" @inner_signature_mult ">"
@signature = ":<" @inner_signature_mult ">" | ":"
@func_type = "->" | "-<" @inner_signature_mult ">"
@at_brace = \@ ($white | @block_comment)* \{
$in_operator = $special # [\)\(\}\{\_\[\]\,]
$in_l = $in_operator # [\<]
$in_r = $in_operator # [\>]
@operator = "+" | "-" | "*" | "/" | "<" | ">" | "=" | "~" | "?" | "%" | "#[" | $in_r{2,} | $in_l{2,}
@double_parens = "(" (@block_comment | $white+ | \n | "//".*)+ ")" | "()"
@double_braces = "{" @block_comment "}" | "{}"
@double_brackets = "<" @block_comment ">" | "<>"
@view = v | view
@fixity_decl = "infixr" | "infixl" | "prefix" | "postfix"
@builtin = \$ (("effmask_" (wrt | all | ref)) | "extfcall" | "ldelay" | "delay" | "list_vt" | "tempenver" | "extype" | "mylocation" | "showtype")
@block_comment_start = \(\* | \/\*
@block_comment_end = \*\) | \*\/
@comment_in = [\*$white]
@comment_general = @comment_in | [\)\(\/]
tokens :-
<0> $white+ ;
<0> @block_comment_start { tok (\p s -> alex $ CommentBegin p) `andBegin` one }
<one> @block_comment_end { tok (\p s -> alex $ CommentEnd p) `andBegin` 0 }
<one> @block_comment_start { tok (\p s -> alex $ CommentContents p s) `andBegin` two }
<one> [^\*\(\)\/]+ { tok (\p s -> alex $ CommentContents p s) }
<one> @comment_in+ / [^\)] { tok (\p s -> alex $ CommentContents p s) }
<one> @comment_general { tok (\p s -> alex $ CommentContents p s) }
<two> @block_comment_end { tok (\p s -> alex $ CommentContents p s) `andBegin` one }
<two> [^\*\(\)\/]+ { tok (\p s -> alex $ CommentContents p s) }
<two> @comment_in+ / [^\)] { tok (\p s -> alex $ CommentContents p s) }
<two> @comment_general { tok (\p s -> alex $ CommentContents p s) }
<0> "//".* { tok (\p s -> alex $ CommentLex p s) }
<0> "#define".* { tok (\p s -> alex $ MacroBlock p s) }
<0> @if_block { tok (\p s -> alex $ MacroBlock p s) }
<0> @c_block { tok (\p s -> alex $ CBlockLex p s) }
<0> fun { tok (\p s -> alex $ Keyword p KwFun) }
<0> fn { tok (\p s -> alex $ Keyword p KwFn) }
<0> fnx { tok (\p s -> alex $ Keyword p KwFnx) }
<0> and { tok (\p s -> alex $ Keyword p KwAnd) }
<0> prval { tok (\p s -> alex $ Keyword p KwPrval) }
<0> prfn { tok (\p s -> alex $ Keyword p KwPrfn) }
<0> prfun { tok (\p s -> alex $ Keyword p KwPrfun) }
<0> datatype { tok (\p s -> alex $ Keyword p KwDatatype) }
<0> data @view type { tok (\p s -> alex $ Keyword p KwDatavtype) }
<0> @view type { tok (\p s -> alex $ Keyword p (KwVtype None)) }
<0> @view type"+" { tok (\p s -> alex $ Keyword p (KwVtype Plus)) }
<0> @view type"-" { tok (\p s -> alex $ Keyword p (KwVtype Minus)) }
<0> dataview { tok (\p s -> alex $ Keyword p KwDataview) }
<0> dataprop { tok (\p s -> alex $ Keyword p KwDataprop) }
<0> assume { tok (\p s -> alex $ Keyword p KwAssume) }
<0> typedef { tok (\p s -> alex $ Keyword p KwTypedef) }
<0> @view typedef { tok (\p s -> alex $ Keyword p KwVtypedef) }
<0> absprop { tok (\p s -> alex $ Keyword p KwAbsprop) }
<0> llam { tok (\p s -> alex $ Keyword p KwLinearLambda) }
<0> lam { tok (\p s -> alex $ Keyword p KwLambda) }
<0> staload { tok (\p s -> alex $ Keyword p (KwStaload False)) }
<0> "#"staload { tok (\p s -> alex $ Keyword p (KwStaload True)) }
<0> let { tok (\p s -> alex $ Keyword p KwLet) }
<0> in { tok (\p s -> alex $ Keyword p KwIn) }
<0> end { tok (\p s -> alex $ Keyword p KwEnd) }
<0> case"+" { tok (\p s -> alex $ Keyword p (KwCase Plus)) }
<0> case"-" { tok (\p s -> alex $ Keyword p (KwCase Minus)) }
<0> case { tok (\p s -> alex $ Keyword p (KwCase None)) }
<0> castfn { tok (\p s -> alex $ Keyword p KwCastfn) }
<0> val"+" { tok (\p s -> alex $ Keyword p (KwVal Plus)) }
<0> val"-" { tok (\p s -> alex $ Keyword p (KwVal Minus)) }
<0> val { tok (\p s -> alex $ Keyword p (KwVal None)) }
<0> var { tok (\p s -> alex $ Keyword p KwVar) }
<0> if { tok (\p s -> alex $ Keyword p KwIf) }
<0> sif { tok (\p s -> alex $ Keyword p KwSif) }
<0> then { tok (\p s -> alex $ Keyword p KwThen) }
<0> else { tok (\p s -> alex $ Keyword p KwElse) }
<0> implement { tok (\p s -> alex $ Keyword p KwImplement) }
<0> implmnt { tok (\p s -> alex $ Keyword p KwImplement) }
<0> primplmnt { tok (\p s -> alex $ Keyword p KwProofImplement) }
<0> primplement { tok (\p s -> alex $ Keyword p KwProofImplement) }
<0> abst"@"ype { tok (\p s -> alex $ Keyword p (KwAbst0p None)) }
<0> abst"@ype+" { tok (\p s -> alex $ Keyword p (KwAbst0p Plus)) }
<0> abst"@type-" { tok (\p s -> alex $ Keyword p (KwAbst0p Minus)) }
<0> abs@view"t@ype" { tok (\p s -> alex $ Keyword p (KwAbsvt0p None)) }
<0> t"@"ype"+" { tok (\p s -> alex $ Keyword p (KwT0p Plus)) }
<0> t"@"ype"-" { tok (\p s -> alex $ Keyword p (KwT0p Minus)) }
<0> t"@"ype { tok (\p s -> alex $ Keyword p (KwT0p None)) }
<0> @view"t@ype+" { tok (\p s -> alex $ Keyword p (KwVt0p Plus)) }
<0> @view"t@ype-" { tok (\p s -> alex $ Keyword p (KwVt0p Minus)) }
<0> @view"t@ype" { tok (\p s -> alex $ Keyword p (KwVt0p None)) }
<0> abstype { tok (\p s -> alex $ Keyword p KwAbstype) }
<0> abs @view type { tok (\p s -> alex $ Keyword p KwAbsvtype) }
<0> absview { tok (\p s -> alex $ Keyword p KwAbsview) }
<0> view { tok (\p s -> alex $ Keyword p (KwView None)) }
<0> view"+" { tok (\p s -> alex $ Keyword p (KwView Plus)) }
<0> view"-" { tok (\p s -> alex $ Keyword p (KwView Minus)) }
<0> viewdef { tok (\p s -> alex $ Keyword p KwViewdef) }
<0> "#"include { tok (\p s -> alex $ Keyword p KwInclude) }
<0> when { tok (\p s -> alex $ Keyword p KwWhen) }
<0> of { tok (\p s -> alex $ Keyword p KwOf) }
<0> ifcase { tok (\p s -> alex $ Keyword p KwIfCase) }
<0> stadef { tok (\p s -> alex $ Keyword p KwStadef) }
<0> stacst { tok (\p s -> alex $ Keyword p KwStacst) }
<0> local { tok (\p s -> alex $ Keyword p KwLocal) }
<0> praxi { tok (\p s -> alex $ Keyword p KwPraxi) }
<0> while { tok (\p s -> alex $ Keyword p KwWhile) }
<0> where { tok (\p s -> alex $ Keyword p KwWhere) }
<0> begin { tok (\p s -> alex $ Keyword p KwBegin) }
<0> overload { tok (\p s -> alex $ Keyword p KwOverload) }
<0> with { tok (\p s -> alex $ Keyword p KwWith) }
<0> extern { tok (\p s -> alex $ Keyword p KwExtern) }
<0> sortdef { tok (\p s -> alex $ Keyword p KwSortdef) }
<0> propdef { tok (\p s -> alex $ Keyword p KwPropdef) }
<0> tkindef { tok (\p s -> alex $ Keyword p KwTKind) }
<0> typekindef { tok (\p s -> alex $ Keyword p KwTKind) }
<0> "$raise" { tok (\p s -> alex $ Keyword p KwRaise) }
<0> macdef { tok (\p s -> alex $ Keyword p KwMacdef) }
<0> mod { tok (\p s -> alex $ Keyword p KwMod) }
<0> datasort { tok (\p s -> alex $ Keyword p KwDatasort) }
<0> "println!" { tok (\p s -> alex $ Identifier p s) }
<0> "prerrln!" { tok (\p s -> alex $ Identifier p s) }
<0> "fix@" { tok (\p s -> alex $ Keyword p KwFixAt) }
<0> "lam@" { tok (\p s -> alex $ Keyword p KwLambdaAt) }
<0> "addr" { tok (\p s -> alex $ Keyword p KwAddr) }
<0> "addr@" { tok (\p s -> alex $ Keyword p KwAddrAt) }
<0> "view@" { tok (\p s -> alex $ Keyword p KwViewAt) }
<0> sta { tok (\p s -> alex $ Keyword p KwSta) }
<0> symintr { tok (\p s -> alex $ Keyword p KwSymintr) }
<0> absview { tok (\p s -> alex $ Keyword p KwAbsview) }
<0> exception { tok (\p s -> alex $ Keyword p KwException) }
<0> "$list" { tok (\p s -> alex $ Keyword p (KwListLit "")) }
<0> "$list_vt" { tok (\p s -> alex $ Keyword p (KwListLit "_vt")) }
<0> "fold@" { tok (\p s -> alex $ IdentifierSpace p s) }
<0> "free@" { tok (\p s -> alex $ Identifier p s) }
<0> @fixity_decl { tok (\p s -> alex $ FixityTok p s) }
<0> @double_parens { tok (\p s -> alex $ DoubleParenTok p) }
<0> @double_braces { tok (\p s -> alex $ DoubleBracesTok p) }
<0> @double_brackets { tok (\p s -> alex $ DoubleBracketTok p) }
<0> @char_lit { tok (\p s -> alex $ CharTok p (toChar s)) }
<0> @lambda { tok (\p s -> alex $ Arrow p s) }
<0> @func_type { tok (\p s -> alex $ FuncType p s) }
<0> @time_lit { tok (\p s -> alex $ TimeTok p s) }
<0> @integer { tok (\p s -> alex $ IntTok p (read s)) } -- FIXME shouldn't fail silenty on overflow
<0> @float { tok (\p s -> alex $ FloatTok p (read s)) }
<0> @at_brace { tok (\p s -> alex $ Operator p "@{") } -- FIXME this is kinda sloppy
<0> $br / @ref_call { tok (\p s -> alex $ SpecialBracket p) }
<0> @signature { tok (\p s -> alex $ SignatureTok p (tail s)) }
<0> @operator { tok (\p s -> alex $ Operator p s) }
<0> @builtin { tok (\p s -> alex $ SpecialIdentifier p (tail s)) }
<0> $special { tok (\p s -> alex $ Special p s) }
<0> @identifier / " " { tok (\p s -> alex $ IdentifierSpace p s) }
<0> @identifier { tok (\p s -> alex $ Identifier p s) }
<0> @string { tok (\p s -> alex $ StringTok p s) }
{
alex :: a -> Alex a
alex = pure
deriving instance Generic AlexPosn
deriving instance NFData AlexPosn
deriving instance Data AlexPosn
deriving instance Typeable AlexPosn
tok f (p,_,_,s) len = f p (take len s)
-- | Determines the default behavior for incomplete pattern matches
data Addendum = None
| Plus
| Minus
deriving (Eq, Show, Generic, NFData, Data, Typeable)
-- TODO ideally we'd handle this as an internal error later in the parser.
get_staload (Keyword _ (KwStaload b)) = b
get_staload _ = undefined
get_addendum (Keyword _ (KwVal a)) = a
get_addendum (Keyword _ (KwVtype a)) = a
get_addendum _ = undefined
data Keyword = KwFun
| KwFnx
| KwAnd
| KwDatatype
| KwDatavtype
| KwAssume
| KwTypedef
| KwVtypedef
| KwVtype Addendum
| KwStaload Bool
| KwLet
| KwIn
| KwLocal
| KwEnd
| KwImplement
| KwCase Addendum
| KwIf
| KwSif
| KwThen
| KwElse
| KwVal Addendum
| KwVar
| KwLambda
| KwLinearLambda
| KwInclude
| KwWhen
| KwOf
| KwAbsprop
| KwPrval
| KwStadef
| KwPraxi
| KwWhile
| KwWhere
| KwBegin
| KwOverload
| KwWith
| KwIfCase
| KwDataview
| KwDataprop
| KwView Addendum
| KwAbstype
| KwType
| KwAbst0p Addendum
| KwAbsvt0p Addendum
| KwT0p Addendum
| KwVt0p Addendum
| KwPrfun
| KwPrfn
| KwCastfn
| KwExtern
| KwAbsvtype
| KwProofImplement
| KwSortdef
| KwPropdef
| KwRaise
| KwTKind
| KwMod
| KwFixAt
| KwLambdaAt
| KwAddrAt
| KwAddr
| KwSta
| KwViewAt
| KwViewdef
| KwSymintr
| KwAbsview
| KwFn
| KwInfix
| KwInfixr
| KwInfixl
| KwStacst
| KwListLit String
| KwMacdef
| KwDatasort
| KwException
deriving (Eq, Show, Generic, NFData)
data Token = Identifier AlexPosn String
| SpecialIdentifier AlexPosn String
| Keyword AlexPosn Keyword
| IntTok AlexPosn Int
| FloatTok AlexPosn Float
| CharTok AlexPosn Char
| StringTok AlexPosn String
| Special AlexPosn String
| CBlockLex AlexPosn String
| IdentifierSpace AlexPosn String
| Operator AlexPosn String
| Arrow AlexPosn String
| FuncType AlexPosn String
| CommentLex AlexPosn String
| CommentBegin AlexPosn
| CommentEnd AlexPosn
| CommentContents AlexPosn String
| MacroBlock AlexPosn String
| TimeTok AlexPosn String
| SignatureTok AlexPosn String
| DoubleParenTok AlexPosn
| DoubleBracesTok AlexPosn
| DoubleBracketTok AlexPosn
| SpecialBracket AlexPosn
| FixityTok AlexPosn String
| End
deriving (Eq, Show, Generic, NFData)
instance Pretty Addendum where
pretty Plus = "+"
pretty Minus = "-"
pretty None = ""
instance Pretty Keyword where
pretty KwFun = "fun"
pretty (KwVtype a) = "vtype" <> pretty a
pretty KwAnd = "and"
pretty KwDatatype = "datatype"
pretty KwDatavtype = "datavtype" -- FIXME this wrongly squashes dataviewtype
pretty KwFnx = "fnx"
pretty KwAssume = "assume"
pretty KwTypedef = "typedef"
pretty KwVtypedef = "vtypedef"
pretty (KwStaload b) = bool "" "#" b <> "staload"
pretty KwLet = "let"
pretty KwWhere = "where"
pretty KwLocal = "local"
pretty KwEnd = "end"
pretty KwBegin = "begin"
pretty KwDatasort = "datasort"
pretty KwIn = "in"
pretty KwImplement = "implement"
pretty (KwCase c) = "case" <> pretty c
pretty KwIfCase = "ifcase"
pretty KwIf = "if"
pretty KwException = "exception"
pretty KwSif = "sif"
pretty KwThen = "then"
pretty KwElse = "else"
pretty (KwVal c) = "val" <> pretty c
pretty KwVar = "var"
pretty KwLambda = "lam"
pretty KwLinearLambda = "llam"
pretty KwInclude = "include"
pretty KwWhen = "when"
pretty KwOf = "of"
pretty KwAbsprop = "absprop"
pretty KwPrval = "prval"
pretty KwStadef = "stadef"
pretty KwPraxi = "praxi"
pretty KwWhile = "while"
pretty KwOverload = "overload"
pretty KwWith = "with"
pretty KwDataview = "dataview"
pretty KwDataprop = "dataprop"
pretty (KwView c) = "view" <> pretty c
pretty KwAbstype = "abstype"
pretty KwAbsvtype = "absvtype"
pretty KwType = "type"
pretty (KwAbst0p c) = "abst@ype" <> pretty c
pretty (KwAbsvt0p c) = "absvt@ype" <> pretty c
pretty (KwT0p c) = "t@ype" <> pretty c
pretty (KwVt0p c) = "vt@ype" <> pretty c
pretty KwPrfun = "prfun"
pretty KwPrfn = "prfn"
pretty KwCastfn = "castfn"
pretty KwExtern = "extern"
pretty KwRaise = "$raise"
pretty KwProofImplement = "primplmnt"
pretty KwSortdef = "sortdef"
pretty KwPropdef = "propdef"
pretty KwTKind = "tkind"
pretty KwMod = "mod"
pretty KwFixAt = "fix@"
pretty KwLambdaAt = "lam@"
pretty KwAddrAt = "addr@"
pretty KwAddr = "addr"
pretty KwSta = "sta"
pretty KwStacst = "stacst"
pretty KwViewAt = "view@"
pretty KwViewdef = "viewdef"
pretty KwSymintr = "symintr"
pretty KwAbsview = "absview"
pretty KwFn = "fn"
pretty KwInfix = "infix"
pretty KwInfixr = "infixr"
pretty KwInfixl = "infixl"
pretty (KwListLit s) = "list" <> string s
pretty KwMacdef = "macdef"
instance Pretty Token where
pretty (SpecialIdentifier _ s) = text ('$' : s)
pretty (Identifier _ s) = text s
pretty (IdentifierSpace _ s) = text s
pretty (Keyword _ kw) = pretty kw
pretty (IntTok _ i) = pretty i
pretty (FloatTok _ x) = pretty x
pretty (CharTok _ c) = squotes (pretty c)
pretty (StringTok _ s) = dquotes (text s)
pretty (Special _ s) = text s
pretty CBlockLex{} = "%{"
pretty (Arrow _ s) = text s
pretty (CommentLex _ s) = text $ take 2 s
pretty CommentBegin{} = "(*"
pretty CommentEnd{} = "*)"
pretty (CommentContents _ s) = text s
pretty (FuncType _ s) = text s
pretty (TimeTok _ s) = text s
pretty (SignatureTok _ s) = ":" <> text s
pretty (Operator _ s) = text s
pretty (MacroBlock _ s) = "#"
pretty DoubleParenTok{} = "()"
pretty DoubleBracesTok{} = "{}"
pretty DoubleBracketTok{} = "<>"
pretty SpecialBracket{} = "<"
pretty (FixityTok _ s) = text s
pretty End = mempty
to_string (CommentLex _ s) = s
to_string (Identifier _ s) = s
to_string (IdentifierSpace _ s) = s
to_string (SpecialIdentifier _ s) = s
to_string (Operator _ s) = s
to_string (CommentContents _ s) = s
to_string _ = undefined
token_posn (SpecialIdentifier p _) = p
token_posn (Identifier p _) = p
token_posn (IdentifierSpace p _) = p
token_posn (Keyword p _) = p
token_posn (IntTok p _) = p
token_posn (FloatTok p _) = p
token_posn (StringTok p _) = p
token_posn (Special p _) = p
token_posn (CBlockLex p _) = p
token_posn (Operator p _) = p
token_posn (Arrow p _) = p
token_posn (FuncType p _) = p
token_posn (CharTok p _) = p
token_posn (CommentLex p _) = p
token_posn (MacroBlock p _) = p
token_posn (TimeTok p _) = p
token_posn (SignatureTok p _) = p
token_posn (DoubleParenTok p) = p
token_posn (DoubleBracesTok p) = p
token_posn (DoubleBracketTok p) = p
token_posn (SpecialBracket p) = p
token_posn (FixityTok p _) = p
token_posn (CommentContents p _) = p
token_posn (CommentBegin p) = p
token_posn (CommentEnd p) = p
token_posn End = undefined
toChar :: String -> Char
toChar "'\\n'" = '\n'
toChar "'\\t'" = '\t'
toChar "'\\\\'" = '\\'
toChar x = x !! 1
alexEOF :: Alex Token
alexEOF = pure End
-- | This function turns a string into a stream of tokens for the parser.
lexATS :: String -> Either String [Token]
lexATS str = runAlex str $ loop
loop :: Alex [Token]
loop = do
tok' <- alexMonadScan
if tok' == End then pure []
else (tok' :) <$> loop
}