module DDC.Core.Lexer.Tokens
(
Tok (..)
, renameTok
, describeTok
, TokMeta (..)
, describeTokMeta
, TokAtom (..)
, describeTokAtom
, TokNamed (..)
, describeTokNamed)
where
import DDC.Core.Pretty
import DDC.Core.Exp
import Control.Monad
data TokenFamily
= Symbol
| Keyword
| Constructor
| Index
describeTokenFamily :: TokenFamily -> String
describeTokenFamily tf
= case tf of
Symbol -> "symbol"
Keyword -> "keyword"
Constructor -> "constructor"
Index -> "index"
data Tok n
= KJunk String
| KM !TokMeta
| KA !TokAtom
| KN !(TokNamed n)
deriving (Eq, Show)
renameTok
:: Ord n2
=> (n1 -> Maybe n2)
-> Tok n1
-> Maybe (Tok n2)
renameTok f kk
= case kk of
KJunk s -> Just $ KJunk s
KM t -> Just $ KM t
KA t -> Just $ KA t
KN t -> liftM KN $ renameTokNamed f t
describeTok :: Pretty n => Tok n -> String
describeTok kk
= case kk of
KJunk c -> "character " ++ show c
KM tm -> describeTokMeta tm
KA ta -> describeTokAtom ta
KN tn -> describeTokNamed tn
data TokMeta
= KNewLine
| KCommentLineStart
| KCommentBlockStart
| KCommentBlockEnd
| KCommentUnterminated
| KOffsideClosingBrace
deriving (Eq, Show)
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"
data TokAtom
= KRoundBra
| KRoundKet
| KSquareBra
| KSquareKet
| KBraceBra
| KBraceKet
| KSquareColonBra
| KSquareColonKet
| KBraceColonBra
| KBraceColonKet
| KOp String
| KOpVar String
| KHat
| KDot
| KComma
| KSemiColon
| KUnderscore
| KBackSlash
| KBigLambda
| KArrowTilde
| KArrowDash
| KArrowDashLeft
| KArrowEquals
| KBotEffect
| KBotClosure
| KModule
| KImport
| KExport
| KForeign
| KType
| KValue
| KData
| KWith
| KWhere
| KIn
| KLet
| KLetCase
| KLetRec
| KPrivate
| KExtend
| KUsing
| KWithRegion
| KCase
| KOf
| KWeakEff
| KWeakClo
| KPurify
| KForget
| KBox
| KRun
| KDo
| KMatch
| KElse
| KIndex Int
| KSoConBuiltin SoCon
| KKiConBuiltin KiCon
| KTwConBuiltin TwCon
| KWbConBuiltin WbCon
| KTcConBuiltin TcCon
| KDaConUnit
deriving (Eq, Show)
describeTokAtom :: TokAtom -> String
describeTokAtom ta
= let (family, str) = describeTokAtom' ta
in describeTokenFamily family ++ " " ++ show str
describeTokAtom' :: TokAtom -> (TokenFamily, String)
describeTokAtom' ta
= case ta of
KRoundBra -> (Symbol, "(")
KRoundKet -> (Symbol, ")")
KSquareBra -> (Symbol, "[")
KSquareKet -> (Symbol, "]")
KBraceBra -> (Symbol, "{")
KBraceKet -> (Symbol, "}")
KSquareColonBra -> (Symbol, "[:")
KSquareColonKet -> (Symbol, ":]")
KBraceColonBra -> (Symbol, "{:")
KBraceColonKet -> (Symbol, ":}")
KOp op -> (Symbol, op)
KOpVar op -> (Symbol, "(" ++ op ++ ")")
KHat -> (Symbol, "^")
KDot -> (Symbol, ".")
KComma -> (Symbol, ",")
KSemiColon -> (Symbol, ";")
KUnderscore -> (Symbol, "_")
KBackSlash -> (Symbol, "\\")
KBigLambda -> (Symbol, "/\\")
KArrowTilde -> (Constructor, "~>")
KArrowDash -> (Constructor, "->")
KArrowDashLeft -> (Constructor, "<-")
KArrowEquals -> (Constructor, "=>")
KBotEffect -> (Constructor, "Pure")
KBotClosure -> (Constructor, "Empty")
KModule -> (Keyword, "module")
KImport -> (Keyword, "import")
KExport -> (Keyword, "export")
KForeign -> (Keyword, "foreign")
KType -> (Keyword, "type")
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")
KDo -> (Keyword, "do")
KMatch -> (Keyword, "match")
KElse -> (Keyword, "else")
KIndex i -> (Index, "^" ++ show i)
KSoConBuiltin so -> (Constructor, renderPlain $ ppr so)
KKiConBuiltin ki -> (Constructor, renderPlain $ ppr ki)
KTwConBuiltin tw -> (Constructor, renderPlain $ ppr tw)
KWbConBuiltin wi -> (Constructor, renderPlain $ ppr wi)
KTcConBuiltin tc -> (Constructor, renderPlain $ ppr tc)
KDaConUnit -> (Constructor, "()")
data TokNamed n
= KCon n
| KVar n
| KLit n
deriving (Eq, Show)
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)
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