ddc-core-0.4.2.1: DDC/Core/Lexer/Tokens.hs
module DDC.Core.Lexer.Tokens
( -- * Tokens
Tok (..)
, renameTok
, describeTok
-- * Meta Tokens
, TokMeta (..)
, describeTokMeta
-- * Atomic Tokens
, TokAtom (..)
, describeTokAtom
-- * Named Tokens
, TokNamed (..)
, describeTokNamed)
where
import DDC.Core.Pretty
import DDC.Core.Exp
import Control.Monad
import Data.Text (Text)
import qualified Data.Text as T
-- TokenFamily ----------------------------------------------------------------
-- | The family of a token.
-- This is used to help generate parser error messages,
-- so we can say ''the constructor Cons''
-- and ''the keyword case'' etc.
data TokenFamily
= Symbol
| Keyword
| Constructor
| Index
| Literal
| Pragma
-- | Describe a token family, for parser error messages.
describeTokenFamily :: TokenFamily -> String
describeTokenFamily tf
= case tf of
Symbol -> "symbol"
Keyword -> "keyword"
Constructor -> "constructor"
Index -> "index"
Literal -> "literal"
Pragma -> "pragma"
-- Tok ------------------------------------------------------------------------
-- | Tokens accepted by the core language parser.
data Tok n
-- | Some junk symbol that isn't part of the language.
= KErrorJunk String
-- | The first part of an unterminated string.
| KErrorUnterm String
-- | Meta tokens contain out-of-band information that is eliminated
-- before parsing proper.
| KM !TokMeta
-- | Atomic tokens are keywords, punctuation and baked-in
-- constructor names.
| KA !TokAtom
-- | A named token that is specific to the language fragment
-- (maybe it's a primop), or a user defined name.
| KN !(TokNamed n)
deriving (Eq, Show)
-- | Apply a function to all the names in a `Tok`.
renameTok
:: Ord n2
=> (n1 -> Maybe n2)
-> Tok n1
-> Maybe (Tok n2)
renameTok f kk
= case kk of
KErrorJunk s
-> Just $ KErrorJunk s
KErrorUnterm s
-> Just $ KErrorUnterm s
KM t -> Just $ KM t
KA t -> Just $ KA t
KN t -> liftM KN $ renameTokNamed f t
-- | Describe a token for parser error messages.
describeTok :: Pretty n => Tok n -> String
describeTok kk
= case kk of
KErrorJunk c -> "character " ++ show c
KErrorUnterm _ -> "unterminated string"
KM tm -> describeTokMeta tm
KA ta -> describeTokAtom ta
KN tn -> describeTokNamed tn
-- TokMeta --------------------------------------------------------------------
-- | Meta tokens contain out-of-band information that is
-- eliminated before parsing proper.
data TokMeta
= KNewLine
| KCommentLineStart
| KCommentBlockStart
| KCommentBlockEnd
-- | This is injected by `dropCommentBlock` when it finds
-- an unterminated block comment.
| KCommentUnterminated
-- | This is injected by `applyOffside` when it finds an explit close
-- brace in a position where it would close a synthetic one.
| KOffsideClosingBrace
deriving (Eq, Show)
-- | Describe a TokMeta, for lexer error messages.
describeTokMeta :: TokMeta -> String
describeTokMeta tm
= case tm of
KNewLine -> "new line"
KCommentLineStart -> "comment start"
KCommentBlockStart -> "block comment start"
KCommentBlockEnd -> "block comment end"
KCommentUnterminated -> "unterminated block comment"
KOffsideClosingBrace -> "closing brace"
-- TokAtom --------------------------------------------------------------------
-- | Atomic tokens are keywords, punctuation and baked-in constructor names.
-- They don't contain user-defined names or primops specific to the
-- language fragment.
data TokAtom
-----------------------------------------
-- Single char parenthesis
= KRoundBra -- ^ Like '('
| KRoundKet -- ^ Like ')'
| KSquareBra -- ^ Like '['
| KSquareKet -- ^ Like ']'
| KBraceBra -- ^ Like '{'
| KBraceKet -- ^ Like '}'
-- Compound parenthesis
| KSquareColonBra -- ^ Like '[:'
| KSquareColonKet -- ^ Like ':]'
| KBraceColonBra -- ^ Like '{:'
| KBraceColonKet -- ^ Like ':}'
-----------------------------------------
-- Operator symbols
-- These can be used as part of an infix operator.
| KOp String -- ^ Naked operator, like in 1 + 2.
| KOpVar String -- ^ Wrapped operator, like in (+) 1 2.
-----------------------------------------
-- Operator body symbols.
-- These can be used in an operator body, but cannot start an operator.
-- Allowing '^' to start an operator causes problems in type signatures.
-- We end up lexing a '^^^' operator with '[^^^ : Int]'
-- and a '^:' operator in '[^:Int]'
| KHat
-----------------------------------------
-- Punctuation symbols.
-- These cannot be used as part of an infix operator.
-- Allowing '.' in an operator conflicts with trailing big-lambdas.
-- We end up lexing './' as an operator in '\(x:Int)./\(a : Data)'
| KDot
| KComma
| KSemiColon
| KUnderscore
| KBackSlash
| KEquals
| KBar
-----------------------------------------
-- Compound symbols.
| KBigLambdaSlash
| KBigLambda
| KLambda
-----------------------------------------
-- symbolic constructors
| KArrowTilde
| KArrowDash
| KArrowDashLeft
| KArrowEquals
-----------------------------------------
-- bottoms
| KBotEffect
| KBotClosure
-----------------------------------------
-- core keywords
| KModule
| KImport
| KExport
| KForeign
| KType
| KCapability
| KValue
| KData
| KWith
| KWhere
| KIn
| KLet
| KLetCase
| KLetRec
| KPrivate
| KExtend
| KUsing
| KWithRegion
| KCase
| KOf
| KWeakEff
| KWeakClo
| KPurify
| KForget
| KBox
| KRun
-----------------------------------------
-- sugar keywords
| KDo
| KMatch
| KIf
| KThen
| KElse
| KOtherwise
-----------------------------------------
-- debruijn indices
| KIndex Int
-- literal strings
| KString Text
-- pragmas
| KPragma Text
-----------------------------------------
-- builtin names
-- sort constructors.
| KSoConBuiltin SoCon
-- kind constructors.
| KKiConBuiltin KiCon
-- witness type constructors.
| KTwConBuiltin TwCon
-- other builtin spec constructors.
| KTcConBuiltin TcCon
-- the unit data constructor.
| KDaConUnit
deriving (Eq, Show)
-- | Describe a `TokAtom`, for parser error messages.
describeTokAtom :: TokAtom -> String
describeTokAtom ta
= let (family, str) = describeTokAtom' ta
in describeTokenFamily family ++ " " ++ show str
describeTokAtom' :: TokAtom -> (TokenFamily, String)
describeTokAtom' ta
= case ta of
-- parens
KRoundBra -> (Symbol, "(")
KRoundKet -> (Symbol, ")")
KSquareBra -> (Symbol, "[")
KSquareKet -> (Symbol, "]")
KBraceBra -> (Symbol, "{")
KBraceKet -> (Symbol, "}")
-- compound parens
KSquareColonBra -> (Symbol, "[:")
KSquareColonKet -> (Symbol, ":]")
KBraceColonBra -> (Symbol, "{:")
KBraceColonKet -> (Symbol, ":}")
-- operator symbols
KOp op -> (Symbol, op)
KOpVar op -> (Symbol, "(" ++ op ++ ")")
-- operator body symbols
KHat -> (Symbol, "^")
-- punctuation symbols
KDot -> (Symbol, ".")
KComma -> (Symbol, ",")
KSemiColon -> (Symbol, ";")
KUnderscore -> (Symbol, "_")
KBackSlash -> (Symbol, "\\")
KLambda -> (Symbol, "λ")
KBigLambdaSlash -> (Symbol, "/\\")
KBigLambda -> (Symbol, "Λ")
KEquals -> (Symbol, "=")
KBar -> (Symbol, "|")
-- symbolic constructors
KArrowTilde -> (Constructor, "~>")
KArrowDash -> (Constructor, "->")
KArrowDashLeft -> (Constructor, "<-")
KArrowEquals -> (Constructor, "=>")
-- bottoms
KBotEffect -> (Constructor, "Pure")
KBotClosure -> (Constructor, "Empty")
-- expression keywords
KModule -> (Keyword, "module")
KImport -> (Keyword, "import")
KExport -> (Keyword, "export")
KForeign -> (Keyword, "foreign")
KType -> (Keyword, "type")
KCapability -> (Keyword, "capability")
KValue -> (Keyword, "value")
KData -> (Keyword, "data")
KWith -> (Keyword, "with")
KWhere -> (Keyword, "where")
KIn -> (Keyword, "in")
KLet -> (Keyword, "let")
KLetCase -> (Keyword, "letcase")
KLetRec -> (Keyword, "letrec")
KPrivate -> (Keyword, "private")
KExtend -> (Keyword, "extend")
KUsing -> (Keyword, "using")
KWithRegion -> (Keyword, "withregion")
KCase -> (Keyword, "case")
KOf -> (Keyword, "of")
KWeakEff -> (Keyword, "weakeff")
KWeakClo -> (Keyword, "weakclo")
KPurify -> (Keyword, "purify")
KForget -> (Keyword, "forget")
KBox -> (Keyword, "box")
KRun -> (Keyword, "run")
-- sugar keywords
KDo -> (Keyword, "do")
KMatch -> (Keyword, "match")
KIf -> (Keyword, "if")
KThen -> (Keyword, "then")
KElse -> (Keyword, "else")
KOtherwise -> (Keyword, "otherwise")
-- debruijn indices
KIndex i -> (Index, "^" ++ show i)
KString s -> (Literal, show s)
KPragma p -> (Pragma, "{-#" ++ T.unpack p ++ "#-}")
-- builtin names
KSoConBuiltin so -> (Constructor, renderPlain $ ppr so)
KKiConBuiltin ki -> (Constructor, renderPlain $ ppr ki)
KTwConBuiltin tw -> (Constructor, renderPlain $ ppr tw)
KTcConBuiltin tc -> (Constructor, renderPlain $ ppr tc)
KDaConUnit -> (Constructor, "()")
-- TokNamed -------------------------------------------------------------------
-- | A token with a user-defined name.
data TokNamed n
= KCon n
| KVar n
| KLit n
deriving (Eq, Show)
-- | Describe a `TokNamed`, for parser error messages.
describeTokNamed :: Pretty n => TokNamed n -> String
describeTokNamed tn
= case tn of
KCon n -> renderPlain $ text "constructor" <+> (dquotes $ ppr n)
KVar n -> renderPlain $ text "variable" <+> (dquotes $ ppr n)
KLit n -> renderPlain $ text "literal" <+> (dquotes $ ppr n)
-- | Apply a function to all the names in a `TokNamed`.
renameTokNamed
:: Ord n2
=> (n1 -> Maybe n2)
-> TokNamed n1
-> Maybe (TokNamed n2)
renameTokNamed f kk
= case kk of
KCon c -> liftM KCon $ f c
KVar c -> liftM KVar $ f c
KLit c -> liftM KLit $ f c